From bbc1c339f4b0de238e8024fb632ecb30bcc686de Mon Sep 17 00:00:00 2001 From: No author Date: Mon, 1 Dec 2003 00:27:30 +0000 Subject: This commit was manufactured by cvs2svn to create branch 'newoolab'. git-svn-id: http://caml.inria.fr/svn/ocaml/branches/newoolab@5988 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02 --- .cvsignore | 13 - .depend | 772 --- Changes | 1657 ------ INSTALL | 263 - INSTALL.MPW | 89 - LICENSE | 618 -- Makefile | 671 --- Makefile.Mac | 488 -- Makefile.Mac.depend | 548 -- Makefile.nt | 622 --- README | 144 - README.win32 | 248 - Upgrading | 109 - asmrun/.cvsignore | 33 - asmrun/.depend | 498 -- asmrun/Makefile | 195 - asmrun/Makefile.nt | 77 - asmrun/alpha.S | 440 -- asmrun/amd64.S | 335 -- asmrun/arm.S | 339 -- asmrun/fail.c | 172 - asmrun/hppa.S | 550 -- asmrun/i386.S | 326 -- asmrun/i386nt.asm | 278 - asmrun/ia64.S | 530 -- asmrun/m68k.S | 244 - asmrun/mips.s | 386 -- asmrun/power-aix.S | 513 -- asmrun/power-elf.S | 421 -- asmrun/power-rhapsody.S | 416 -- asmrun/roots.c | 297 - asmrun/signals.c | 677 --- asmrun/sparc.S | 398 -- asmrun/stack.h | 105 - asmrun/startup.c | 158 - boot/.cvsignore | 4 - boot/ocamlc | Bin 948084 -> 0 bytes boot/ocamllex | Bin 147675 -> 0 bytes camlp4/CHANGES | 851 --- camlp4/ICHANGES | 20 - camlp4/Makefile | 190 - camlp4/Makefile.Mac | 204 - camlp4/boot/.cvsignore | 5 - camlp4/camlp4/.cvsignore | 6 - camlp4/camlp4/.depend | 21 - camlp4/camlp4/Makefile | 71 - camlp4/camlp4/Makefile.Mac | 69 - camlp4/camlp4/Makefile.Mac.depend | 15 - camlp4/camlp4/argl.ml | 424 -- camlp4/camlp4/ast2pt.ml | 867 --- camlp4/camlp4/ast2pt.mli | 23 - camlp4/camlp4/mLast.mli | 211 - camlp4/camlp4/pcaml.ml | 457 -- camlp4/camlp4/pcaml.mli | 157 - camlp4/camlp4/quotation.ml | 33 - camlp4/camlp4/quotation.mli | 48 - camlp4/camlp4/reloc.ml | 289 - camlp4/camlp4/reloc.mli | 16 - camlp4/camlp4/spretty.ml | 481 -- camlp4/camlp4/spretty.mli | 54 - camlp4/compile/.cvsignore | 4 - camlp4/compile/.depend | 4 - camlp4/compile/Makefile | 45 - camlp4/compile/comp_head.ml | 70 - camlp4/compile/comp_trail.ml | 33 - camlp4/compile/compile.ml | 571 -- camlp4/compile/compile.sh | 27 - camlp4/config/.cvsignore | 2 - camlp4/config/Makefile-nt.cnf | 7 - camlp4/config/Makefile.tpl | 28 - camlp4/config/config.mpw | 50 - camlp4/config/configure_batch | 113 - camlp4/etc/.cvsignore | 6 - camlp4/etc/.depend | 73 - camlp4/etc/Makefile | 107 - camlp4/etc/Makefile.Mac | 71 - camlp4/etc/Makefile.Mac.depend | 40 - camlp4/etc/lib.sml | 384 -- camlp4/etc/mkcamlp4.mpw.tpl | 33 - camlp4/etc/mkcamlp4.sh.tpl | 33 - camlp4/etc/pa_extfold.ml | 42 - camlp4/etc/pa_extfun.ml | 123 - camlp4/etc/pa_format.ml | 39 - camlp4/etc/pa_fstream.ml | 163 - camlp4/etc/pa_ifdef.ml | 87 - camlp4/etc/pa_lefteval.ml | 239 - camlp4/etc/pa_lisp.ml | 684 --- camlp4/etc/pa_lispr.ml | 665 --- camlp4/etc/pa_o.ml | 1293 ----- camlp4/etc/pa_ocamllex.ml | 344 -- camlp4/etc/pa_olabl.ml | 2005 ------- camlp4/etc/pa_oop.ml | 154 - camlp4/etc/pa_op.ml | 330 -- camlp4/etc/pa_ru.ml | 46 - camlp4/etc/pa_scheme.ml | 1002 ---- camlp4/etc/pa_schemer.ml | 1067 ---- camlp4/etc/pa_sml.ml | 947 ---- camlp4/etc/parserify.ml | 301 - camlp4/etc/parserify.mli | 12 - camlp4/etc/pr_depend.ml | 327 -- camlp4/etc/pr_extend.ml | 514 -- camlp4/etc/pr_extfun.ml | 92 - camlp4/etc/pr_null.ml | 16 - camlp4/etc/pr_o.ml | 2062 ------- camlp4/etc/pr_op.ml | 503 -- camlp4/etc/pr_op_main.ml | 214 - camlp4/etc/pr_r.ml | 1898 ------- camlp4/etc/pr_rp.ml | 504 -- camlp4/etc/pr_rp_main.ml | 206 - camlp4/etc/pr_scheme.ml | 813 --- camlp4/etc/pr_schp_main.ml | 119 - camlp4/etc/q_phony.ml | 49 - camlp4/lib/.cvsignore | 3 - camlp4/lib/.depend | 20 - camlp4/lib/Makefile | 48 - camlp4/lib/Makefile.Mac | 46 - camlp4/lib/Makefile.Mac.depend | 13 - camlp4/lib/extfold.ml | 91 - camlp4/lib/extfold.mli | 24 - camlp4/lib/extfun.ml | 109 - camlp4/lib/extfun.mli | 36 - camlp4/lib/fstream.ml | 77 - camlp4/lib/fstream.mli | 60 - camlp4/lib/gramext.ml | 565 -- camlp4/lib/gramext.mli | 81 - camlp4/lib/grammar.ml | 1064 ---- camlp4/lib/grammar.mli | 209 - camlp4/lib/plexer.ml | 1006 ---- camlp4/lib/plexer.mli | 72 - camlp4/lib/stdpp.ml | 79 - camlp4/lib/stdpp.mli | 37 - camlp4/lib/token.ml | 229 - camlp4/lib/token.mli | 133 - camlp4/man/.cvsignore | 2 - camlp4/man/Makefile | 28 - camlp4/man/Makefile.Mac | 31 - camlp4/man/camlp4.1.tpl | 302 - camlp4/man/camlp4.help.tpl | 1 - camlp4/meta/.cvsignore | 3 - camlp4/meta/.depend | 16 - camlp4/meta/Makefile | 59 - camlp4/meta/Makefile.Mac | 50 - camlp4/meta/Makefile.Mac.depend | 12 - camlp4/meta/mk_q_MLast.sh | 12 - camlp4/meta/pa_extend.ml | 916 --- camlp4/meta/pa_extend_m.ml | 26 - camlp4/meta/pa_ifdef.ml | 85 - camlp4/meta/pa_macro.ml | 251 - camlp4/meta/pa_r.ml | 943 ---- camlp4/meta/pa_rp.ml | 318 -- camlp4/meta/pr_dump.ml | 52 - camlp4/meta/q_MLast.ml | 1501 ----- camlp4/ocaml_src/.cvsignore | 1 - camlp4/ocaml_src/camlp4/.cvsignore | 3 - camlp4/ocaml_src/camlp4/.depend | 21 - camlp4/ocaml_src/camlp4/Makefile | 71 - camlp4/ocaml_src/camlp4/Makefile.Mac | 69 - camlp4/ocaml_src/camlp4/Makefile.Mac.depend | 15 - camlp4/ocaml_src/camlp4/argl.ml | 406 -- camlp4/ocaml_src/camlp4/ast2pt.ml | 880 --- camlp4/ocaml_src/camlp4/ast2pt.mli | 23 - camlp4/ocaml_src/camlp4/mLast.mli | 211 - camlp4/ocaml_src/camlp4/pcaml.ml | 464 -- camlp4/ocaml_src/camlp4/pcaml.mli | 158 - camlp4/ocaml_src/camlp4/quotation.ml | 33 - camlp4/ocaml_src/camlp4/quotation.mli | 48 - camlp4/ocaml_src/camlp4/reloc.ml | 337 -- camlp4/ocaml_src/camlp4/reloc.mli | 16 - camlp4/ocaml_src/camlp4/spretty.ml | 465 -- camlp4/ocaml_src/camlp4/spretty.mli | 59 - camlp4/ocaml_src/lib/.depend | 20 - camlp4/ocaml_src/lib/Makefile | 48 - camlp4/ocaml_src/lib/Makefile.Mac | 46 - camlp4/ocaml_src/lib/Makefile.Mac.depend | 13 - camlp4/ocaml_src/lib/extfold.ml | 124 - camlp4/ocaml_src/lib/extfold.mli | 24 - camlp4/ocaml_src/lib/extfun.ml | 105 - camlp4/ocaml_src/lib/extfun.mli | 37 - camlp4/ocaml_src/lib/fstream.ml | 84 - camlp4/ocaml_src/lib/fstream.mli | 60 - camlp4/ocaml_src/lib/gramext.ml | 531 -- camlp4/ocaml_src/lib/gramext.mli | 79 - camlp4/ocaml_src/lib/grammar.ml | 1119 ---- camlp4/ocaml_src/lib/grammar.mli | 200 - camlp4/ocaml_src/lib/plexer.ml | 1258 ----- camlp4/ocaml_src/lib/plexer.mli | 72 - camlp4/ocaml_src/lib/stdpp.ml | 99 - camlp4/ocaml_src/lib/stdpp.mli | 37 - camlp4/ocaml_src/lib/token.ml | 223 - camlp4/ocaml_src/lib/token.mli | 133 - camlp4/ocaml_src/meta/.cvsignore | 2 - camlp4/ocaml_src/meta/.depend | 16 - camlp4/ocaml_src/meta/Makefile | 59 - camlp4/ocaml_src/meta/Makefile.Mac | 50 - camlp4/ocaml_src/meta/Makefile.Mac.depend | 12 - camlp4/ocaml_src/meta/pa_extend.ml | 2027 ------- camlp4/ocaml_src/meta/pa_extend_m.ml | 40 - camlp4/ocaml_src/meta/pa_ifdef.ml | 216 - camlp4/ocaml_src/meta/pa_macro.ml | 392 -- camlp4/ocaml_src/meta/pa_r.ml | 2814 ---------- camlp4/ocaml_src/meta/pa_rp.ml | 641 --- camlp4/ocaml_src/meta/pr_dump.ml | 48 - camlp4/ocaml_src/meta/q_MLast.ml | 4700 ---------------- camlp4/ocaml_src/odyl/.cvsignore | 2 - camlp4/ocaml_src/odyl/.depend | 6 - camlp4/ocaml_src/odyl/Makefile | 61 - camlp4/ocaml_src/odyl/Makefile.Mac | 49 - camlp4/ocaml_src/odyl/Makefile.Mac.depend | 4 - camlp4/ocaml_src/odyl/odyl.ml | 50 - camlp4/ocaml_src/odyl/odyl_main.ml | 77 - camlp4/ocaml_src/odyl/odyl_main.mli | 13 - camlp4/ocaml_src/tools/camlp4_comm.mpw | 27 - camlp4/ocaml_src/tools/camlp4_comm.sh | 9 - camlp4/ocaml_src/tools/extract_crc.mpw | 3 - camlp4/ocaml_src/tools/extract_crc.sh | 0 camlp4/ocaml_src/tools/ocamlc.mpw | 3 - camlp4/ocaml_src/tools/ocamlc.sh | 8 - camlp4/ocaml_src/tools/ocamlopt.sh | 8 - camlp4/ocaml_stuff/otherlibs/dynlink/.depend | 0 camlp4/ocaml_stuff/parsing/.depend | 2 - camlp4/ocaml_stuff/utils/.depend | 2 - camlp4/ocpp/.cvsignore | 3 - camlp4/ocpp/.depend | 0 camlp4/ocpp/Makefile | 25 - camlp4/ocpp/Makefile.Mac | 41 - camlp4/ocpp/ocpp.ml | 140 - camlp4/odyl/.cvsignore | 4 - camlp4/odyl/.depend | 6 - camlp4/odyl/Makefile | 61 - camlp4/odyl/Makefile.Mac | 49 - camlp4/odyl/Makefile.Mac.depend | 4 - camlp4/odyl/odyl.ml | 51 - camlp4/odyl/odyl_main.ml | 82 - camlp4/odyl/odyl_main.mli | 13 - camlp4/tools/apply.sh | 31 - camlp4/tools/camlp4_comm.mpw | 53 - camlp4/tools/camlp4_comm.sh | 38 - camlp4/tools/conv.sh | 22 - camlp4/tools/extract_crc.mpw | 3 - camlp4/tools/extract_crc.sh | 0 camlp4/tools/ocamlc.mpw | 3 - camlp4/tools/ocamlc.sh | 8 - camlp4/tools/ocamlopt.sh | 8 - camlp4/top/.cvsignore | 1 - camlp4/top/.depend | 14 - camlp4/top/Makefile | 52 - camlp4/top/Makefile.Mac | 60 - camlp4/top/Makefile.Mac.depend | 2 - camlp4/top/camlp4_top.ml | 172 - camlp4/top/oprint.ml | 597 -- camlp4/top/rprint.ml | 422 -- config/.cvsignore | 4 - config/Makefile-templ | 310 -- config/Makefile.mingw | 123 - config/Makefile.msvc | 129 - config/auto-aux/align.c | 103 - config/auto-aux/ansi.c | 21 - config/auto-aux/async_io.c | 60 - config/auto-aux/bytecopy.c | 34 - config/auto-aux/dblalign.c | 55 - config/auto-aux/divmod.c | 47 - config/auto-aux/elf.c | 26 - config/auto-aux/endian.c | 41 - config/auto-aux/getgroups.c | 32 - config/auto-aux/gethostbyaddr.c | 51 - config/auto-aux/gethostbyname.c | 41 - config/auto-aux/hasgot | 28 - config/auto-aux/ia32sse2.c | 22 - config/auto-aux/int64align.c | 56 - config/auto-aux/longlong.c | 43 - config/auto-aux/runtest | 8 - config/auto-aux/schar.c | 23 - config/auto-aux/schar2.c | 23 - config/auto-aux/searchpath | 9 - config/auto-aux/sharpbang | 2 - config/auto-aux/sharpbang2 | 2 - config/auto-aux/sighandler.c | 23 - config/auto-aux/signals.c | 68 - config/auto-aux/sizes.c | 23 - config/auto-aux/solaris-ld | 7 - config/auto-aux/stackov.c | 68 - config/auto-aux/tclversion.c | 8 - config/auto-aux/trycompile | 7 - config/config.Mac | 76 - config/gnu/config.guess | 1366 ----- config/gnu/config.sub | 1375 ----- config/m-MacOS.h | 33 - config/m-nt.h | 34 - config/m-templ.h | 81 - config/s-MacOS.h | 20 - config/s-nt.h | 29 - config/s-templ.h | 207 - configure | 1533 ----- debugger/.cvsignore | 4 - debugger/.depend | 189 - debugger/Makefile | 114 - debugger/breakpoints.ml | 222 - debugger/breakpoints.mli | 61 - debugger/checkpoints.ml | 85 - debugger/checkpoints.mli | 58 - debugger/command_line.ml | 1084 ---- debugger/command_line.mli | 22 - debugger/debugcom.ml | 278 - debugger/debugcom.mli | 102 - debugger/debugger_config.ml | 75 - debugger/debugger_config.mli | 35 - debugger/envaux.ml | 83 - debugger/envaux.mli | 33 - debugger/eval.ml | 207 - debugger/eval.mli | 40 - debugger/events.ml | 65 - debugger/events.mli | 31 - debugger/exec.ml | 50 - debugger/exec.mli | 19 - debugger/frames.ml | 129 - debugger/frames.mli | 55 - debugger/history.ml | 44 - debugger/history.mli | 20 - debugger/input_handling.ml | 148 - debugger/input_handling.mli | 63 - debugger/int64ops.ml | 26 - debugger/int64ops.mli | 26 - debugger/lexer.mll | 98 - debugger/loadprinter.ml | 172 - debugger/loadprinter.mli | 34 - debugger/main.ml | 132 - debugger/parameters.ml | 35 - debugger/parameters.mli | 26 - debugger/parser.mly | 239 - debugger/parser_aux.mli | 34 - debugger/pattern_matching.ml | 251 - debugger/pattern_matching.mli | 21 - debugger/pos.ml | 37 - debugger/pos.mli | 15 - debugger/primitives.ml | 194 - debugger/primitives.mli | 86 - debugger/printval.ml | 111 - debugger/printval.mli | 33 - debugger/program_loading.ml | 114 - debugger/program_loading.mli | 34 - debugger/program_management.ml | 157 - debugger/program_management.mli | 27 - debugger/show_information.ml | 94 - debugger/show_information.mli | 26 - debugger/show_source.ml | 79 - debugger/show_source.mli | 23 - debugger/source.ml | 153 - debugger/source.mli | 58 - debugger/symbols.ml | 169 - debugger/symbols.mli | 44 - debugger/time_travel.ml | 642 --- debugger/time_travel.mli | 36 - debugger/trap_barrier.ml | 47 - debugger/trap_barrier.mli | 27 - debugger/unix_tools.ml | 141 - debugger/unix_tools.mli | 34 - driver/compile.ml | 121 - driver/compile.mli | 24 - driver/errors.ml | 69 - driver/errors.mli | 18 - driver/main.ml | 156 - driver/main.mli | 17 - driver/main_args.ml | 156 - driver/main_args.mli | 66 - driver/ocamlcomp.sh.in | 5 - driver/optcompile.ml | 110 - driver/optcompile.mli | 24 - driver/opterrors.ml | 71 - driver/opterrors.mli | 17 - driver/optmain.ml | 204 - driver/optmain.mli | 17 - driver/pparse.ml | 81 - driver/pparse.mli | 22 - emacs/.cvsignore | 2 - emacs/Makefile | 64 - emacs/README | 198 - emacs/README.itz | 177 - emacs/caml-compat.el | 28 - emacs/caml-emacs.el | 29 - emacs/caml-font.el | 125 - emacs/caml-help.el | 815 --- emacs/caml-hilit.el | 53 - emacs/caml-types.el | 572 -- emacs/caml-xemacs.el | 39 - emacs/caml.el | 1894 ------- emacs/camldebug.el | 754 --- emacs/inf-caml.el | 348 -- emacs/ocamltags.in | 128 - lex/.cvsignore | 6 - lex/.depend | 32 - lex/Makefile | 71 - lex/Makefile.Mac | 63 - lex/Makefile.Mac.depend | 17 - lex/Makefile.nt | 73 - lex/common.ml | 153 - lex/common.mli | 25 - lex/compact.ml | 234 - lex/compact.mli | 33 - lex/cset.ml | 94 - lex/cset.mli | 32 - lex/lexer.mli | 20 - lex/lexer.mll | 273 - lex/lexgen.ml | 1174 ---- lex/lexgen.mli | 59 - lex/main.ml | 102 - lex/output.ml | 140 - lex/output.mli | 25 - lex/outputbis.ml | 193 - lex/outputbis.mli | 21 - lex/parser.mly | 174 - lex/syntax.ml | 44 - lex/syntax.mli | 41 - lex/table.ml | 56 - lex/table.mli | 33 - maccaml/.cvsignore | 12 - maccaml/Makefile.Mac | 121 - maccaml/Makefile.Mac.depend | 2032 ------- maccaml/SHORTCUTS | 9 - maccaml/WASTE/.cvsignore | 1 - maccaml/WASTE/Makefile | 507 -- maccaml/WASTE/README | 5 - maccaml/aboutbox.c | 125 - maccaml/appleevents.c | 147 - maccaml/appli.r | 808 --- maccaml/clipboard.c | 40 - maccaml/drag.c | 241 - maccaml/dummy_fragment.c | 1 - maccaml/errors.c | 114 - maccaml/events.c | 319 -- maccaml/files.c | 427 -- maccaml/glue.c | 557 -- maccaml/graph.c | 1179 ---- maccaml/lcontrols.c | 246 - maccaml/lib.c | 35 - maccaml/main.c | 125 - maccaml/main.h | 264 - maccaml/mcmemory.c | 31 - maccaml/mcmisc.c | 24 - maccaml/menus.c | 339 -- maccaml/modalfilter.c | 83 - maccaml/ocaml.r | 479 -- maccaml/ocamlconstants.h | 187 - maccaml/ocamlmkappli | 89 - maccaml/prefs.c | 127 - maccaml/prim_bigarray | 18 - maccaml/prim_graph | 41 - maccaml/prim_num | 28 - maccaml/prim_str | 8 - maccaml/print.c | 131 - maccaml/scroll.c | 325 -- maccaml/windows.c | 852 --- man/Makefile | 22 - man/ocaml.help | 138 - man/ocaml.m | 101 - man/ocamlc.m | 247 - man/ocamlcp.m | 88 - man/ocamldebug.m | 37 - man/ocamldep.m | 79 - man/ocamllex.m | 71 - man/ocamlmktop.m | 85 - man/ocamlopt.m | 230 - man/ocamlprof.m | 57 - man/ocamlrun.m | 130 - man/ocamlyacc.m | 71 - ocamldoc/.cvsignore | 16 - ocamldoc/.depend | 222 - ocamldoc/Changes.txt | 101 - ocamldoc/Makefile | 361 -- ocamldoc/Makefile.nt | 344 -- ocamldoc/ocamldoc.hva | 10 - ocamldoc/ocamldoc.sty | 60 - ocamldoc/odoc.ml | 128 - ocamldoc/odoc_analyse.ml | 448 -- ocamldoc/odoc_analyse.mli | 32 - ocamldoc/odoc_args.ml | 306 - ocamldoc/odoc_args.mli | 181 - ocamldoc/odoc_ast.ml | 1536 ----- ocamldoc/odoc_ast.mli | 104 - ocamldoc/odoc_class.ml | 253 - ocamldoc/odoc_comments.ml | 315 -- ocamldoc/odoc_comments.mli | 57 - ocamldoc/odoc_comments_global.ml | 48 - ocamldoc/odoc_comments_global.mli | 47 - ocamldoc/odoc_control.ml | 13 - ocamldoc/odoc_cross.ml | 815 --- ocamldoc/odoc_cross.mli | 17 - ocamldoc/odoc_dag2html.ml | 1756 ------ ocamldoc/odoc_dag2html.mli | 31 - ocamldoc/odoc_dep.ml | 219 - ocamldoc/odoc_dot.ml | 130 - ocamldoc/odoc_env.ml | 245 - ocamldoc/odoc_env.mli | 76 - ocamldoc/odoc_exception.ml | 32 - ocamldoc/odoc_global.ml | 22 - ocamldoc/odoc_global.mli | 20 - ocamldoc/odoc_html.ml | 2018 ------- ocamldoc/odoc_info.ml | 254 - ocamldoc/odoc_info.mli | 1032 ---- ocamldoc/odoc_inherit.ml | 13 - ocamldoc/odoc_latex.ml | 986 ---- ocamldoc/odoc_latex_style.ml | 76 - ocamldoc/odoc_lexer.mll | 411 -- ocamldoc/odoc_man.ml | 941 ---- ocamldoc/odoc_merge.ml | 953 ---- ocamldoc/odoc_merge.mli | 32 - ocamldoc/odoc_messages.ml | 309 - ocamldoc/odoc_misc.ml | 454 -- ocamldoc/odoc_misc.mli | 112 - ocamldoc/odoc_module.ml | 510 -- ocamldoc/odoc_name.ml | 162 - ocamldoc/odoc_name.mli | 66 - ocamldoc/odoc_ocamlhtml.mll | 544 -- ocamldoc/odoc_opt.ml | 82 - ocamldoc/odoc_parameter.ml | 131 - ocamldoc/odoc_parser.mly | 158 - ocamldoc/odoc_scan.ml | 156 - ocamldoc/odoc_search.ml | 632 --- ocamldoc/odoc_search.mli | 199 - ocamldoc/odoc_see_lexer.mll | 102 - ocamldoc/odoc_sig.ml | 1330 ----- ocamldoc/odoc_sig.mli | 176 - ocamldoc/odoc_str.ml | 231 - ocamldoc/odoc_str.mli | 45 - ocamldoc/odoc_texi.ml | 1193 ---- ocamldoc/odoc_text.ml | 144 - ocamldoc/odoc_text.mli | 24 - ocamldoc/odoc_text_lexer.mll | 730 --- ocamldoc/odoc_text_parser.mly | 215 - ocamldoc/odoc_to_text.ml | 537 -- ocamldoc/odoc_type.ml | 52 - ocamldoc/odoc_types.ml | 130 - ocamldoc/odoc_types.mli | 130 - ocamldoc/odoc_value.ml | 133 - ocamldoc/remove_DEBUG | 8 - ocamldoc/runocamldoc | 12 - otherlibs/bigarray/.cvsignore | 3 - otherlibs/bigarray/.depend | 17 - otherlibs/bigarray/Makefile | 74 - otherlibs/bigarray/Makefile.Mac | 53 - otherlibs/bigarray/Makefile.Mac.depend | 42 - otherlibs/bigarray/Makefile.nt | 84 - otherlibs/bigarray/bigarray.h | 81 - otherlibs/bigarray/bigarray.ml | 226 - otherlibs/bigarray/bigarray.mli | 756 --- otherlibs/bigarray/bigarray_stubs.c | 1073 ---- otherlibs/bigarray/mmap_unix.c | 117 - otherlibs/bigarray/mmap_win32.c | 116 - otherlibs/db/.depend | 2 - otherlibs/dbm/.cvsignore | 1 - otherlibs/dbm/.depend | 2 - otherlibs/dbm/Makefile | 73 - otherlibs/dbm/cldbm.c | 166 - otherlibs/dbm/dbm.ml | 58 - otherlibs/dbm/dbm.mli | 80 - otherlibs/dynlink/.cvsignore | 1 - otherlibs/dynlink/.depend | 10 - otherlibs/dynlink/Makefile | 61 - otherlibs/dynlink/Makefile.Mac | 56 - otherlibs/dynlink/Makefile.Mac.depend | 4 - otherlibs/dynlink/Makefile.nt | 62 - otherlibs/dynlink/dynlink.ml | 248 - otherlibs/dynlink/dynlink.mli | 129 - otherlibs/dynlink/extract_crc.ml | 53 - otherlibs/graph/.cvsignore | 1 - otherlibs/graph/.depend | 48 - otherlibs/graph/Makefile | 75 - otherlibs/graph/Makefile.Mac | 40 - otherlibs/graph/Makefile.Mac.depend | 4 - otherlibs/graph/color.c | 230 - otherlibs/graph/draw.c | 131 - otherlibs/graph/dump_img.c | 55 - otherlibs/graph/events.c | 287 - otherlibs/graph/fill.c | 88 - otherlibs/graph/graphics.ml | 228 - otherlibs/graph/graphics.mli | 374 -- otherlibs/graph/graphicsX11.ml | 42 - otherlibs/graph/graphicsX11.mli | 31 - otherlibs/graph/image.c | 105 - otherlibs/graph/image.h | 29 - otherlibs/graph/libgraph.h | 84 - otherlibs/graph/make_img.c | 95 - otherlibs/graph/open.c | 366 -- otherlibs/graph/point_col.c | 32 - otherlibs/graph/sound.c | 34 - otherlibs/graph/subwindow.c | 45 - otherlibs/graph/text.c | 84 - otherlibs/labltk/.cvsignore | 4 - otherlibs/labltk/Changes | 13 - otherlibs/labltk/Makefile | 80 - otherlibs/labltk/Makefile.nt | 59 - otherlibs/labltk/README | 152 - otherlibs/labltk/Widgets.src | 2271 -------- otherlibs/labltk/browser/.cvsignore | 2 - otherlibs/labltk/browser/.depend | 66 - otherlibs/labltk/browser/Makefile | 64 - otherlibs/labltk/browser/Makefile.nt | 70 - otherlibs/labltk/browser/README | 170 - otherlibs/labltk/browser/dummyUnix.mli | 27 - otherlibs/labltk/browser/dummyWin.mli | 15 - otherlibs/labltk/browser/editor.ml | 671 --- otherlibs/labltk/browser/editor.mli | 20 - otherlibs/labltk/browser/fileselect.ml | 290 - otherlibs/labltk/browser/fileselect.mli | 39 - otherlibs/labltk/browser/help.ml | 168 - otherlibs/labltk/browser/help.txt | 166 - otherlibs/labltk/browser/jg_bind.ml | 28 - otherlibs/labltk/browser/jg_bind.mli | 21 - otherlibs/labltk/browser/jg_box.ml | 82 - otherlibs/labltk/browser/jg_button.ml | 25 - otherlibs/labltk/browser/jg_completion.ml | 53 - otherlibs/labltk/browser/jg_completion.mli | 25 - otherlibs/labltk/browser/jg_config.ml | 40 - otherlibs/labltk/browser/jg_config.mli | 17 - otherlibs/labltk/browser/jg_entry.ml | 27 - otherlibs/labltk/browser/jg_memo.ml | 35 - otherlibs/labltk/browser/jg_memo.mli | 19 - otherlibs/labltk/browser/jg_menu.ml | 42 - otherlibs/labltk/browser/jg_message.ml | 111 - otherlibs/labltk/browser/jg_message.mli | 33 - otherlibs/labltk/browser/jg_multibox.ml | 185 - otherlibs/labltk/browser/jg_multibox.mli | 35 - otherlibs/labltk/browser/jg_text.ml | 104 - otherlibs/labltk/browser/jg_text.mli | 28 - otherlibs/labltk/browser/jg_tk.ml | 24 - otherlibs/labltk/browser/jg_toplevel.ml | 25 - otherlibs/labltk/browser/lexical.ml | 143 - otherlibs/labltk/browser/lexical.mli | 20 - otherlibs/labltk/browser/list2.ml | 23 - otherlibs/labltk/browser/main.ml | 132 - otherlibs/labltk/browser/mytypes.mli | 29 - otherlibs/labltk/browser/searchid.ml | 532 -- otherlibs/labltk/browser/searchid.mli | 45 - otherlibs/labltk/browser/searchpos.ml | 875 --- otherlibs/labltk/browser/searchpos.mli | 78 - otherlibs/labltk/browser/setpath.ml | 162 - otherlibs/labltk/browser/setpath.mli | 25 - otherlibs/labltk/browser/shell.ml | 367 -- otherlibs/labltk/browser/shell.mli | 46 - otherlibs/labltk/browser/typecheck.ml | 181 - otherlibs/labltk/browser/typecheck.mli | 23 - otherlibs/labltk/browser/useunix.ml | 69 - otherlibs/labltk/browser/useunix.mli | 23 - otherlibs/labltk/browser/viewer.ml | 636 --- otherlibs/labltk/browser/viewer.mli | 31 - otherlibs/labltk/browser/winmain.c | 18 - otherlibs/labltk/builtin/LICENSE | 19 - otherlibs/labltk/builtin/builtin_FilePattern.ml | 20 - otherlibs/labltk/builtin/builtin_GetBitmap.ml | 22 - otherlibs/labltk/builtin/builtin_GetCursor.ml | 61 - otherlibs/labltk/builtin/builtin_GetPixel.ml | 28 - otherlibs/labltk/builtin/builtin_ScrollValue.ml | 22 - otherlibs/labltk/builtin/builtin_bind.ml | 469 -- otherlibs/labltk/builtin/builtin_bindtags.ml | 21 - otherlibs/labltk/builtin/builtin_font.ml | 4 - otherlibs/labltk/builtin/builtin_grab.ml | 3 - otherlibs/labltk/builtin/builtin_index.ml | 92 - otherlibs/labltk/builtin/builtin_palette.ml | 20 - otherlibs/labltk/builtin/builtin_text.ml | 50 - otherlibs/labltk/builtin/builtina_empty.ml | 0 otherlibs/labltk/builtin/builtinf_GetPixel.ml | 23 - otherlibs/labltk/builtin/builtinf_bind.ml | 133 - otherlibs/labltk/builtin/builtini_GetBitmap.ml | 28 - otherlibs/labltk/builtin/builtini_GetCursor.ml | 55 - otherlibs/labltk/builtin/builtini_GetPixel.ml | 43 - otherlibs/labltk/builtin/builtini_ScrollValue.ml | 45 - otherlibs/labltk/builtin/builtini_bind.ml | 136 - otherlibs/labltk/builtin/builtini_bindtags.ml | 29 - otherlibs/labltk/builtin/builtini_font.ml | 3 - otherlibs/labltk/builtin/builtini_grab.ml | 2 - otherlibs/labltk/builtin/builtini_index.ml | 140 - otherlibs/labltk/builtin/builtini_palette.ml | 19 - otherlibs/labltk/builtin/builtini_text.ml | 64 - otherlibs/labltk/builtin/canvas_bind.ml | 52 - otherlibs/labltk/builtin/canvas_bind.mli | 16 - otherlibs/labltk/builtin/dialog.ml | 45 - otherlibs/labltk/builtin/dialog.mli | 24 - otherlibs/labltk/builtin/image.ml | 33 - otherlibs/labltk/builtin/image.mli | 9 - otherlibs/labltk/builtin/optionmenu.ml | 54 - otherlibs/labltk/builtin/optionmenu.mli | 21 - otherlibs/labltk/builtin/rawimg.ml | 142 - otherlibs/labltk/builtin/rawimg.mli | 44 - otherlibs/labltk/builtin/report.ml | 17 - otherlibs/labltk/builtin/selection_handle_set.ml | 41 - otherlibs/labltk/builtin/selection_handle_set.mli | 13 - otherlibs/labltk/builtin/selection_own_set.ml | 29 - otherlibs/labltk/builtin/selection_own_set.mli | 12 - otherlibs/labltk/builtin/text_tag_bind.ml | 55 - otherlibs/labltk/builtin/text_tag_bind.mli | 13 - otherlibs/labltk/builtin/winfo_contained.ml | 13 - otherlibs/labltk/builtin/winfo_contained.mli | 11 - otherlibs/labltk/camltk/.cvsignore | 3 - otherlibs/labltk/camltk/Makefile | 45 - otherlibs/labltk/camltk/Makefile.gen | 46 - otherlibs/labltk/camltk/Makefile.gen.nt | 46 - otherlibs/labltk/camltk/Makefile.nt | 43 - otherlibs/labltk/camltk/modules | 80 - otherlibs/labltk/compiler/.cvsignore | 11 - otherlibs/labltk/compiler/.depend | 28 - otherlibs/labltk/compiler/Makefile | 63 - otherlibs/labltk/compiler/Makefile.nt | 63 - otherlibs/labltk/compiler/code.mli | 22 - otherlibs/labltk/compiler/compile.ml | 1074 ---- otherlibs/labltk/compiler/copyright | 15 - otherlibs/labltk/compiler/flags.ml | 17 - otherlibs/labltk/compiler/intf.ml | 191 - otherlibs/labltk/compiler/lexer.mll | 170 - otherlibs/labltk/compiler/maincompile.ml | 418 -- otherlibs/labltk/compiler/parser.mly | 330 -- otherlibs/labltk/compiler/pp.ml | 23 - otherlibs/labltk/compiler/ppexec.ml | 60 - otherlibs/labltk/compiler/pplex.mli | 18 - otherlibs/labltk/compiler/pplex.mll | 57 - otherlibs/labltk/compiler/ppparse.ml | 36 - otherlibs/labltk/compiler/ppyac.mly | 52 - otherlibs/labltk/compiler/printer.ml | 173 - otherlibs/labltk/compiler/tables.ml | 427 -- otherlibs/labltk/compiler/tsort.ml | 89 - otherlibs/labltk/example/.gitignore | 0 otherlibs/labltk/examples_camltk/.cvsignore | 8 - otherlibs/labltk/examples_camltk/Makefile | 52 - otherlibs/labltk/examples_camltk/Makefile.nt | 38 - otherlibs/labltk/examples_camltk/addition.ml | 53 - otherlibs/labltk/examples_camltk/eyes.ml | 67 - otherlibs/labltk/examples_camltk/fileinput.ml | 35 - otherlibs/labltk/examples_camltk/fileopen.ml | 56 - otherlibs/labltk/examples_camltk/helloworld.ml | 37 - .../labltk/examples_camltk/images/CamlBook.gif | Bin 15167 -> 0 bytes .../labltk/examples_camltk/images/Lambda2.back.gif | Bin 53441 -> 0 bytes .../labltk/examples_camltk/images/dojoji.back.gif | Bin 49934 -> 0 bytes otherlibs/labltk/examples_camltk/jptest.ml | 23 - otherlibs/labltk/examples_camltk/mytext.ml | 63 - otherlibs/labltk/examples_camltk/socketinput.ml | 43 - otherlibs/labltk/examples_camltk/taddition.ml | 53 - otherlibs/labltk/examples_camltk/tetris.ml | 685 --- otherlibs/labltk/examples_camltk/text.ml | 55 - otherlibs/labltk/examples_camltk/winskel.ml | 63 - otherlibs/labltk/examples_labltk/.cvsignore | 8 - otherlibs/labltk/examples_labltk/Lambda2.back.gif | Bin 53441 -> 0 bytes otherlibs/labltk/examples_labltk/Makefile | 53 - otherlibs/labltk/examples_labltk/Makefile.nt | 50 - otherlibs/labltk/examples_labltk/README | 20 - otherlibs/labltk/examples_labltk/calc.ml | 129 - otherlibs/labltk/examples_labltk/clock.ml | 133 - otherlibs/labltk/examples_labltk/demo.ml | 167 - otherlibs/labltk/examples_labltk/eyes.ml | 65 - otherlibs/labltk/examples_labltk/hello.ml | 38 - otherlibs/labltk/examples_labltk/hello.tcl | 5 - otherlibs/labltk/examples_labltk/lang.ml | 75 - otherlibs/labltk/examples_labltk/taquin.ml | 143 - otherlibs/labltk/examples_labltk/tetris.ml | 710 --- otherlibs/labltk/frx/.depend | 38 - otherlibs/labltk/frx/Makefile | 51 - otherlibs/labltk/frx/Makefile.nt | 53 - otherlibs/labltk/frx/README | 2 - otherlibs/labltk/frx/frx_after.ml | 24 - otherlibs/labltk/frx/frx_after.mli | 17 - otherlibs/labltk/frx/frx_color.ml | 35 - otherlibs/labltk/frx/frx_color.mli | 16 - otherlibs/labltk/frx/frx_ctext.ml | 66 - otherlibs/labltk/frx/frx_ctext.mli | 25 - otherlibs/labltk/frx/frx_dialog.ml | 115 - otherlibs/labltk/frx/frx_dialog.mli | 22 - otherlibs/labltk/frx/frx_entry.ml | 42 - otherlibs/labltk/frx/frx_entry.mli | 31 - otherlibs/labltk/frx/frx_fileinput.ml | 40 - otherlibs/labltk/frx/frx_fillbox.ml | 65 - otherlibs/labltk/frx/frx_fillbox.mli | 31 - otherlibs/labltk/frx/frx_fit.ml | 83 - otherlibs/labltk/frx/frx_fit.mli | 29 - otherlibs/labltk/frx/frx_focus.ml | 26 - otherlibs/labltk/frx/frx_focus.mli | 18 - otherlibs/labltk/frx/frx_font.ml | 51 - otherlibs/labltk/frx/frx_font.mli | 20 - otherlibs/labltk/frx/frx_group.ml | 22 - otherlibs/labltk/frx/frx_lbutton.ml | 50 - otherlibs/labltk/frx/frx_lbutton.mli | 24 - otherlibs/labltk/frx/frx_listbox.ml | 92 - otherlibs/labltk/frx/frx_listbox.mli | 32 - otherlibs/labltk/frx/frx_mem.ml | 89 - otherlibs/labltk/frx/frx_mem.mli | 22 - otherlibs/labltk/frx/frx_misc.ml | 69 - otherlibs/labltk/frx/frx_misc.mli | 21 - otherlibs/labltk/frx/frx_req.ml | 198 - otherlibs/labltk/frx/frx_req.mli | 43 - otherlibs/labltk/frx/frx_rpc.ml | 55 - otherlibs/labltk/frx/frx_rpc.mli | 25 - otherlibs/labltk/frx/frx_selection.ml | 45 - otherlibs/labltk/frx/frx_selection.mli | 17 - otherlibs/labltk/frx/frx_synth.ml | 88 - otherlibs/labltk/frx/frx_synth.mli | 31 - otherlibs/labltk/frx/frx_text.ml | 229 - otherlibs/labltk/frx/frx_text.mli | 46 - otherlibs/labltk/frx/frx_toplevel.mli | 17 - otherlibs/labltk/frx/frx_widget.ml | 24 - otherlibs/labltk/frx/frx_widget.mli | 18 - otherlibs/labltk/jpf/Makefile | 77 - otherlibs/labltk/jpf/Makefile.nt | 75 - otherlibs/labltk/jpf/README | 2 - otherlibs/labltk/jpf/balloon.ml | 102 - otherlibs/labltk/jpf/balloon.mli | 24 - otherlibs/labltk/jpf/balloontest.ml | 32 - otherlibs/labltk/jpf/fileselect.ml | 368 -- otherlibs/labltk/jpf/fileselect.mli | 37 - otherlibs/labltk/jpf/jpf_font.ml | 218 - otherlibs/labltk/jpf/jpf_font.mli | 54 - otherlibs/labltk/jpf/shell.ml | 36 - otherlibs/labltk/jpf/shell.mli | 17 - otherlibs/labltk/labl.gif | Bin 1533 -> 0 bytes otherlibs/labltk/labltk/.cvsignore | 3 - otherlibs/labltk/labltk/Makefile | 43 - otherlibs/labltk/labltk/Makefile.gen | 45 - otherlibs/labltk/labltk/Makefile.gen.nt | 40 - otherlibs/labltk/labltk/Makefile.nt | 43 - otherlibs/labltk/labltk/modules | 77 - otherlibs/labltk/lib/.cvsignore | 8 - otherlibs/labltk/lib/Makefile | 74 - otherlibs/labltk/lib/Makefile.nt | 60 - otherlibs/labltk/support/.depend | 24 - otherlibs/labltk/support/Makefile | 59 - otherlibs/labltk/support/Makefile.common | 26 - otherlibs/labltk/support/Makefile.common.nt | 29 - otherlibs/labltk/support/Makefile.nt | 69 - otherlibs/labltk/support/camltk.h | 56 - otherlibs/labltk/support/camltkwrap.ml | 77 - otherlibs/labltk/support/camltkwrap.mli | 251 - otherlibs/labltk/support/cltkCaml.c | 83 - otherlibs/labltk/support/cltkDMain.c | 247 - otherlibs/labltk/support/cltkEval.c | 245 - otherlibs/labltk/support/cltkEvent.c | 55 - otherlibs/labltk/support/cltkFile.c | 158 - otherlibs/labltk/support/cltkImg.c | 115 - otherlibs/labltk/support/cltkMain.c | 181 - otherlibs/labltk/support/cltkMisc.c | 64 - otherlibs/labltk/support/cltkTimer.c | 45 - otherlibs/labltk/support/cltkUtf.c | 89 - otherlibs/labltk/support/cltkVar.c | 128 - otherlibs/labltk/support/cltkWait.c | 102 - otherlibs/labltk/support/fileevent.ml | 81 - otherlibs/labltk/support/fileevent.mli | 25 - otherlibs/labltk/support/protocol.ml | 276 - otherlibs/labltk/support/protocol.mli | 115 - otherlibs/labltk/support/rawwidget.ml | 176 - otherlibs/labltk/support/rawwidget.mli | 109 - otherlibs/labltk/support/slave.ml | 51 - otherlibs/labltk/support/support.ml | 48 - otherlibs/labltk/support/support.mli | 21 - otherlibs/labltk/support/textvariable.ml | 152 - otherlibs/labltk/support/textvariable.mli | 45 - otherlibs/labltk/support/timer.ml | 58 - otherlibs/labltk/support/timer.mli | 23 - otherlibs/labltk/support/tkwait.ml | 22 - otherlibs/labltk/support/widget.ml | 23 - otherlibs/labltk/support/widget.mli | 109 - otherlibs/labltk/tkanim/.cvsignore | 2 - otherlibs/labltk/tkanim/.depend | 2 - otherlibs/labltk/tkanim/Makefile | 70 - otherlibs/labltk/tkanim/Makefile.nt | 78 - otherlibs/labltk/tkanim/README | 5 - otherlibs/labltk/tkanim/cltkaniminit.c | 28 - otherlibs/labltk/tkanim/gifanimtest.ml | 71 - otherlibs/labltk/tkanim/mmm.anim.gif | Bin 18501 -> 0 bytes otherlibs/labltk/tkanim/tkAnimGIF.c | 911 --- otherlibs/labltk/tkanim/tkAppInit.c | 141 - otherlibs/labltk/tkanim/tkanim.ml | 230 - otherlibs/labltk/tkanim/tkanim.mli | 95 - otherlibs/macosunix/.cvsignore | 71 - otherlibs/macosunix/Makefile.Mac | 152 - otherlibs/macosunix/Makefile.Mac.depend | 872 --- otherlibs/macosunix/macosunix.c | 119 - otherlibs/macosunix/macosunix_startup.ml | 17 - otherlibs/macosunix/macosunix_startup.mli | 16 - otherlibs/macosunix/unix-primitives | 113 - otherlibs/macosunix/unixsupport.h | 43 - otherlibs/num/.cvsignore | 3 - otherlibs/num/.depend | 35 - otherlibs/num/.depend.nt | 56 - otherlibs/num/Makefile | 86 - otherlibs/num/Makefile.Mac | 64 - otherlibs/num/Makefile.Mac.depend | 33 - otherlibs/num/Makefile.nt | 97 - otherlibs/num/README | 55 - otherlibs/num/arith_flags.ml | 25 - otherlibs/num/arith_flags.mli | 20 - otherlibs/num/arith_status.ml | 100 - otherlibs/num/arith_status.mli | 60 - otherlibs/num/big_int.ml | 603 -- otherlibs/num/big_int.mli | 143 - otherlibs/num/bignum/.cvsignore | 1 - otherlibs/num/bng.c | 434 -- otherlibs/num/bng.h | 156 - otherlibs/num/bng_alpha.c | 23 - otherlibs/num/bng_amd64.c | 196 - otherlibs/num/bng_digit.c | 171 - otherlibs/num/bng_ia32.c | 412 -- otherlibs/num/bng_mips.c | 24 - otherlibs/num/bng_ppc.c | 86 - otherlibs/num/bng_sparc.c | 77 - otherlibs/num/int_misc.ml | 36 - otherlibs/num/int_misc.mli | 25 - otherlibs/num/nat.h | 19 - otherlibs/num/nat.ml | 570 -- otherlibs/num/nat.mli | 71 - otherlibs/num/nat_stubs.c | 369 -- otherlibs/num/num.ml | 396 -- otherlibs/num/num.mli | 171 - otherlibs/num/ratio.ml | 577 -- otherlibs/num/ratio.mli | 88 - otherlibs/num/string_misc.ml | 20 - otherlibs/num/string_misc.mli | 16 - otherlibs/num/test/.depend | 10 - otherlibs/num/test/Makefile | 61 - otherlibs/num/test/Makefile.Mac | 40 - otherlibs/num/test/Makefile.Mac.depend | 10 - otherlibs/num/test/Makefile.nt | 59 - otherlibs/num/test/end_test.ml | 1 - otherlibs/num/test/test.ml | 77 - otherlibs/num/test/test_big_ints.ml | 468 -- otherlibs/num/test/test_bng.c | 408 -- otherlibs/num/test/test_io.ml | 64 - otherlibs/num/test/test_nats.ml | 142 - otherlibs/num/test/test_nums.ml | 220 - otherlibs/num/test/test_ratios.ml | 928 --- otherlibs/str/.cvsignore | 3 - otherlibs/str/.depend | 7 - otherlibs/str/Makefile | 75 - otherlibs/str/Makefile.Mac | 53 - otherlibs/str/Makefile.Mac.depend | 16 - otherlibs/str/Makefile.nt | 83 - otherlibs/str/str.ml | 716 --- otherlibs/str/str.mli | 239 - otherlibs/str/strstubs.c | 527 -- otherlibs/systhreads/.cvsignore | 3 - otherlibs/systhreads/.depend | 27 - otherlibs/systhreads/Makefile | 102 - otherlibs/systhreads/Makefile.Mac | 78 - otherlibs/systhreads/Makefile.Mac.depend | 131 - otherlibs/systhreads/Makefile.nt | 96 - otherlibs/systhreads/Tests/Makefile | 44 - otherlibs/systhreads/Tests/Makefile.nt | 43 - otherlibs/systhreads/condition.ml | 20 - otherlibs/systhreads/condition.mli | 53 - otherlibs/systhreads/event.ml | 274 - otherlibs/systhreads/event.mli | 82 - otherlibs/systhreads/mutex.ml | 20 - otherlibs/systhreads/mutex.mli | 50 - otherlibs/systhreads/posix.c | 820 --- otherlibs/systhreads/thread.mli | 111 - otherlibs/systhreads/threadUnix.ml | 59 - otherlibs/systhreads/threadUnix.mli | 85 - otherlibs/systhreads/thread_posix.ml | 73 - otherlibs/systhreads/thread_win32.ml | 75 - otherlibs/systhreads/win32.c | 719 --- otherlibs/threads/.cvsignore | 3 - otherlibs/threads/.depend | 27 - otherlibs/threads/Makefile | 126 - otherlibs/threads/Tests/.cvsignore | 1 - otherlibs/threads/Tests/Makefile | 38 - otherlibs/threads/Tests/close.ml | 14 - otherlibs/threads/Tests/sieve.ml | 33 - otherlibs/threads/Tests/sorts.ml | 228 - otherlibs/threads/Tests/test1.ml | 57 - otherlibs/threads/Tests/test2.ml | 15 - otherlibs/threads/Tests/test3.ml | 8 - otherlibs/threads/Tests/test4.ml | 13 - otherlibs/threads/Tests/test5.ml | 21 - otherlibs/threads/Tests/test6.ml | 17 - otherlibs/threads/Tests/test7.ml | 28 - otherlibs/threads/Tests/test8.ml | 46 - otherlibs/threads/Tests/test9.ml | 26 - otherlibs/threads/Tests/testA.ml | 24 - otherlibs/threads/Tests/testexit.ml | 22 - otherlibs/threads/Tests/testio.ml | 119 - otherlibs/threads/Tests/testsieve.ml | 42 - otherlibs/threads/Tests/testsignal.ml | 13 - otherlibs/threads/Tests/testsignal2.ml | 10 - otherlibs/threads/Tests/testsocket.ml | 31 - otherlibs/threads/Tests/token1.ml | 36 - otherlibs/threads/Tests/token2.ml | 36 - otherlibs/threads/Tests/torture.ml | 46 - otherlibs/threads/condition.ml | 36 - otherlibs/threads/condition.mli | 53 - otherlibs/threads/event.ml | 274 - otherlibs/threads/event.mli | 82 - otherlibs/threads/marshal.ml | 57 - otherlibs/threads/mutex.ml | 39 - otherlibs/threads/mutex.mli | 50 - otherlibs/threads/pervasives.ml | 528 -- otherlibs/threads/scheduler.c | 876 --- otherlibs/threads/thread.ml | 141 - otherlibs/threads/thread.mli | 141 - otherlibs/threads/threadUnix.ml | 60 - otherlibs/threads/threadUnix.mli | 89 - otherlibs/threads/unix.ml | 929 --- otherlibs/unix/.cvsignore | 1 - otherlibs/unix/.depend | 283 - otherlibs/unix/Makefile | 92 - otherlibs/unix/accept.c | 52 - otherlibs/unix/access.c | 51 - otherlibs/unix/addrofstr.c | 44 - otherlibs/unix/alarm.c | 23 - otherlibs/unix/bind.c | 40 - otherlibs/unix/chdir.c | 25 - otherlibs/unix/chmod.c | 27 - otherlibs/unix/chown.c | 25 - otherlibs/unix/chroot.c | 25 - otherlibs/unix/close.c | 23 - otherlibs/unix/closedir.c | 29 - otherlibs/unix/connect.c | 43 - otherlibs/unix/cst2constr.c | 26 - otherlibs/unix/cst2constr.h | 20 - otherlibs/unix/cstringv.c | 32 - otherlibs/unix/dup.c | 25 - otherlibs/unix/dup2.c | 49 - otherlibs/unix/envir.c | 26 - otherlibs/unix/errmsg.c | 49 - otherlibs/unix/execv.c | 32 - otherlibs/unix/execve.c | 35 - otherlibs/unix/execvp.c | 51 - otherlibs/unix/exit.c | 26 - otherlibs/unix/fchmod.c | 34 - otherlibs/unix/fchown.c | 33 - otherlibs/unix/fcntl.c | 77 - otherlibs/unix/fork.c | 26 - otherlibs/unix/ftruncate.c | 45 - otherlibs/unix/getcwd.c | 57 - otherlibs/unix/getegid.c | 22 - otherlibs/unix/geteuid.c | 22 - otherlibs/unix/getgid.c | 22 - otherlibs/unix/getgr.c | 56 - otherlibs/unix/getgroups.c | 48 - otherlibs/unix/gethost.c | 167 - otherlibs/unix/gethostname.c | 57 - otherlibs/unix/getlogin.c | 29 - otherlibs/unix/getpeername.c | 40 - otherlibs/unix/getpid.c | 22 - otherlibs/unix/getppid.c | 22 - otherlibs/unix/getproto.c | 70 - otherlibs/unix/getpw.c | 65 - otherlibs/unix/getserv.c | 76 - otherlibs/unix/getsockname.c | 40 - otherlibs/unix/gettimeofday.c | 37 - otherlibs/unix/getuid.c | 22 - otherlibs/unix/gmtime.c | 93 - otherlibs/unix/itimer.c | 74 - otherlibs/unix/kill.c | 29 - otherlibs/unix/link.c | 23 - otherlibs/unix/listen.c | 34 - otherlibs/unix/lockf.c | 110 - otherlibs/unix/lseek.c | 57 - otherlibs/unix/mkdir.c | 25 - otherlibs/unix/mkfifo.c | 49 - otherlibs/unix/nice.c | 50 - otherlibs/unix/open.c | 57 - otherlibs/unix/opendir.c | 31 - otherlibs/unix/pipe.c | 29 - otherlibs/unix/putenv.c | 45 - otherlibs/unix/read.c | 38 - otherlibs/unix/readdir.c | 36 - otherlibs/unix/readlink.c | 47 - otherlibs/unix/rename.c | 25 - otherlibs/unix/rewinddir.c | 38 - otherlibs/unix/rmdir.c | 23 - otherlibs/unix/select.c | 109 - otherlibs/unix/sendrecv.c | 139 - otherlibs/unix/setgid.c | 23 - otherlibs/unix/setsid.c | 30 - otherlibs/unix/setuid.c | 23 - otherlibs/unix/shutdown.c | 39 - otherlibs/unix/signals.c | 105 - otherlibs/unix/sleep.c | 26 - otherlibs/unix/socket.c | 48 - otherlibs/unix/socketaddr.c | 110 - otherlibs/unix/socketaddr.h | 44 - otherlibs/unix/socketpair.c | 45 - otherlibs/unix/sockopt.c | 236 - otherlibs/unix/stat.c | 140 - otherlibs/unix/strofaddr.c | 36 - otherlibs/unix/symlink.c | 33 - otherlibs/unix/termios.c | 316 -- otherlibs/unix/time.c | 24 - otherlibs/unix/times.c | 44 - otherlibs/unix/truncate.c | 45 - otherlibs/unix/umask.c | 24 - otherlibs/unix/unix.ml | 776 --- otherlibs/unix/unix.mli | 1206 ---- otherlibs/unix/unixLabels.ml | 18 - otherlibs/unix/unixLabels.mli | 1242 ----- otherlibs/unix/unixsupport.c | 285 - otherlibs/unix/unixsupport.h | 25 - otherlibs/unix/unlink.c | 23 - otherlibs/unix/utimes.c | 71 - otherlibs/unix/wait.c | 101 - otherlibs/unix/write.c | 56 - otherlibs/win32graph/Makefile.nt | 94 - otherlibs/win32graph/dib.c | 496 -- otherlibs/win32graph/draw.c | 784 --- otherlibs/win32graph/libgraph.h | 86 - otherlibs/win32graph/open.c | 400 -- otherlibs/win32unix/.cvsignore | 3 - otherlibs/win32unix/.depend | 5 - otherlibs/win32unix/Makefile.nt | 120 - otherlibs/win32unix/accept.c | 67 - otherlibs/win32unix/bind.c | 34 - otherlibs/win32unix/channels.c | 43 - otherlibs/win32unix/close.c | 33 - otherlibs/win32unix/close_on.c | 46 - otherlibs/win32unix/connect.c | 38 - otherlibs/win32unix/createprocess.c | 87 - otherlibs/win32unix/dup.c | 34 - otherlibs/win32unix/dup2.c | 43 - otherlibs/win32unix/errmsg.c | 44 - otherlibs/win32unix/getpeername.c | 35 - otherlibs/win32unix/getpid.c | 24 - otherlibs/win32unix/getsockname.c | 32 - otherlibs/win32unix/gettimeofday.c | 35 - otherlibs/win32unix/link.c | 42 - otherlibs/win32unix/listen.c | 27 - otherlibs/win32unix/lockf.c | 206 - otherlibs/win32unix/lseek.c | 76 - otherlibs/win32unix/mkdir.c | 24 - otherlibs/win32unix/nonblock.c | 42 - otherlibs/win32unix/open.c | 66 - otherlibs/win32unix/pipe.c | 45 - otherlibs/win32unix/read.c | 55 - otherlibs/win32unix/rename.c | 29 - otherlibs/win32unix/select.c | 99 - otherlibs/win32unix/sendrecv.c | 133 - otherlibs/win32unix/shutdown.c | 32 - otherlibs/win32unix/sleep.c | 27 - otherlibs/win32unix/socket.c | 55 - otherlibs/win32unix/socketaddr.h | 38 - otherlibs/win32unix/sockopt.c | 157 - otherlibs/win32unix/startup.c | 43 - otherlibs/win32unix/stat.c | 93 - otherlibs/win32unix/system.c | 41 - otherlibs/win32unix/unix.ml | 797 --- otherlibs/win32unix/unixsupport.c | 259 - otherlibs/win32unix/unixsupport.h | 54 - otherlibs/win32unix/windir.c | 80 - otherlibs/win32unix/winwait.c | 62 - otherlibs/win32unix/write.c | 64 - parsing/.cvsignore | 7 - parsing/asttypes.mli | 36 - parsing/lexer.mli | 36 - parsing/lexer.mll | 514 -- parsing/linenum.mli | 23 - parsing/linenum.mll | 74 - parsing/location.ml | 239 - parsing/location.mli | 54 - parsing/longident.ml | 38 - parsing/longident.mli | 23 - parsing/parse.ml | 64 - parsing/parse.mli | 21 - parsing/parser.mly | 1505 ----- parsing/parsetree.mli | 272 - parsing/printast.ml | 684 --- parsing/printast.mli | 20 - parsing/syntaxerr.ml | 41 - parsing/syntaxerr.mli | 26 - test/.cvsignore | 2 - test/.depend | 28 - test/KB/equations.ml | 115 - test/KB/equations.mli | 32 - test/KB/kb.ml | 188 - test/KB/kb.mli | 29 - test/KB/kbmain.ml | 81 - test/KB/orderings.ml | 99 - test/KB/orderings.mli | 31 - test/KB/terms.ml | 137 - test/KB/terms.mli | 31 - test/Lex/.cvsignore | 5 - test/Lex/gram_aux.ml | 47 - test/Lex/grammar.mly | 114 - test/Lex/lexgen.ml | 266 - test/Lex/main.ml | 118 - test/Lex/output.ml | 169 - test/Lex/scan_aux.ml | 60 - test/Lex/scanner.mll | 132 - test/Lex/syntax.ml | 40 - test/Lex/testmain.ml | 48 - test/Lex/testscanner.mll | 135 - test/Makefile | 195 - test/Makefile.Mac | 125 - test/Makefile.Mac.depend | 28 - test/Moretest/.cvsignore | 2 - test/Moretest/.depend | 6 - test/Moretest/Makefile | 177 - test/Moretest/Makefile.Mac | 76 - test/Moretest/Makefile.Mac.depend | 4 - test/Moretest/arrays.ml | 86 - test/Moretest/bigarrays.ml | 720 --- test/Moretest/bigarrf.f | 26 - test/Moretest/bigarrfml.ml | 63 - test/Moretest/bigarrfstub.c | 60 - test/Moretest/bigints.ml | 12 - test/Moretest/bounds.ml | 28 - test/Moretest/boxedints.ml | 569 -- test/Moretest/callbackprim.c | 54 - test/Moretest/cmcaml.ml | 17 - test/Moretest/cmmain.c | 21 - test/Moretest/cmstub.c | 17 - test/Moretest/equality.ml | 71 - test/Moretest/fftba.ml | 191 - test/Moretest/float.ml | 1 - test/Moretest/globroots.ml | 25 - test/Moretest/globrootsprim.c | 29 - test/Moretest/graph_example.ml | 131 - test/Moretest/graph_test.ml | 288 - test/Moretest/includestruct.ml | 92 - test/Moretest/intext.ml | 452 -- test/Moretest/intextaux.c | 13 - test/Moretest/io.ml | 101 - test/Moretest/manyargs.ml | 18 - test/Moretest/manyargsprim.c | 24 - test/Moretest/md5.ml | 219 - test/Moretest/morematch.ml | 1107 ---- test/Moretest/multdef.ml | 2 - test/Moretest/multdef.mli | 3 - test/Moretest/patmatch.ml | 78 - test/Moretest/recvalues.ml | 38 - test/Moretest/regexp.ml | 975 ---- test/Moretest/sets.ml | 39 - test/Moretest/signals.ml | 32 - test/Moretest/stackoverflow.ml | 15 - test/Moretest/syserror.ml | 1 - test/Moretest/tailcalls.ml | 28 - test/Moretest/tcallback.ml | 69 - test/Moretest/testrandom.ml | 13 - test/Moretest/tscanf.ml | 826 --- test/Moretest/usemultdef.ml | 1 - test/Moretest/warnings.ml | 44 - test/Moretest/wc.ml | 54 - test/Results/almabench.fast.out | 8 - test/Results/almabench.out | 8 - test/Results/bdd.out | 1 - test/Results/boyer.out | 1 - test/Results/fft.fast.runtest | 4 - test/Results/fft.fast.runtest.Mac | 12 - test/Results/fft.runtest | 4 - test/Results/fft.runtest.Mac | 12 - test/Results/fib.out | 1 - test/Results/genlex.runtest | 5 - test/Results/genlex.runtest.Mac | 7 - test/Results/hamming.out | 100 - test/Results/kb.out | 273 - test/Results/nucleic.out | 1 - test/Results/quicksort.fast.out | 2 - test/Results/quicksort.out | 2 - test/Results/runtest | 1 - test/Results/sieve.out | 1 - test/Results/soli.fast.out | 50 - test/Results/soli.out | 50 - test/Results/sorts.out | 198 - test/Results/takc.out | 1 - test/Results/taku.out | 1 - test/alloc.ml | 51 - test/almabench.ml | 324 -- test/bdd.ml | 231 - test/boyer.ml | 907 --- test/fft.ml | 188 - test/fib.ml | 24 - test/hamming.ml | 105 - test/nucleic.ml | 3236 ----------- test/quicksort.ml | 92 - test/sieve.ml | 56 - test/soli.ml | 111 - test/sorts.ml | 4477 --------------- test/takc.ml | 23 - test/taku.ml | 22 - test/testinterp/.cvsignore | 3 - test/testinterp/Makefile.Mac | 37 - test/testinterp/addbytecode.mpw | 42 - test/testinterp/coverage | 133 - test/testinterp/lib.ml | 42 - test/testinterp/no68k.rez | 1 - test/testinterp/noppc.rez | 1 - test/testinterp/runtest.mpw | 105 - test/testinterp/t000.ml | 7 - test/testinterp/t010-const0.ml | 8 - test/testinterp/t010-const1.ml | 8 - test/testinterp/t010-const2.ml | 8 - test/testinterp/t010-const3.ml | 8 - test/testinterp/t011-constint.ml | 8 - test/testinterp/t020.ml | 10 - test/testinterp/t021-pushconst1.ml | 10 - test/testinterp/t021-pushconst2.ml | 10 - test/testinterp/t021-pushconst3.ml | 10 - test/testinterp/t022-pushconstint.ml | 10 - test/testinterp/t040-makeblock1.ml | 13 - test/testinterp/t040-makeblock2.ml | 15 - test/testinterp/t040-makeblock3.ml | 17 - test/testinterp/t041-makeblock.ml | 19 - test/testinterp/t050-getglobal.ml | 8 - test/testinterp/t050-pushgetglobal.ml | 10 - test/testinterp/t051-getglobalfield.ml | 13 - test/testinterp/t051-pushgetglobalfield.ml | 15 - test/testinterp/t060-raise.ml | 15 - test/testinterp/t070-branch.ml | 20 - test/testinterp/t070-branchif.ml | 20 - test/testinterp/t070-branchifnot.ml | 18 - test/testinterp/t071-boolnot.ml | 19 - test/testinterp/t080-eq.ml | 21 - test/testinterp/t080-geint.ml | 21 - test/testinterp/t080-gtint.ml | 20 - test/testinterp/t080-leint.ml | 21 - test/testinterp/t080-ltint.ml | 20 - test/testinterp/t080-neq.ml | 20 - test/testinterp/t090-acc0.ml | 25 - test/testinterp/t090-acc1.ml | 27 - test/testinterp/t090-acc2.ml | 29 - test/testinterp/t090-acc3.ml | 31 - test/testinterp/t090-acc4.ml | 33 - test/testinterp/t090-acc5.ml | 35 - test/testinterp/t090-acc6.ml | 37 - test/testinterp/t090-acc7.ml | 39 - test/testinterp/t091-acc.ml | 41 - test/testinterp/t092-pushacc.ml | 38 - test/testinterp/t092-pushacc0.ml | 22 - test/testinterp/t092-pushacc1.ml | 24 - test/testinterp/t092-pushacc2.ml | 26 - test/testinterp/t092-pushacc3.ml | 28 - test/testinterp/t092-pushacc4.ml | 30 - test/testinterp/t092-pushacc5.ml | 32 - test/testinterp/t092-pushacc6.ml | 34 - test/testinterp/t092-pushacc7.ml | 36 - test/testinterp/t093-pushacc.ml | 38 - test/testinterp/t100-pushtrap.ml | 21 - test/testinterp/t101-poptrap.ml | 21 - test/testinterp/t110-addint.ml | 26 - test/testinterp/t110-andint.ml | 22 - test/testinterp/t110-asrint-1.ml | 22 - test/testinterp/t110-asrint-2.ml | 22 - test/testinterp/t110-divint-1.ml | 22 - test/testinterp/t110-divint-2.ml | 22 - test/testinterp/t110-divint-3.ml | 33 - test/testinterp/t110-lslint.ml | 22 - test/testinterp/t110-lsrint.ml | 22 - test/testinterp/t110-modint-1.ml | 22 - test/testinterp/t110-modint-2.ml | 34 - test/testinterp/t110-mulint.ml | 22 - test/testinterp/t110-negint.ml | 25 - test/testinterp/t110-offsetint.ml | 21 - test/testinterp/t110-orint.ml | 22 - test/testinterp/t110-subint.ml | 26 - test/testinterp/t110-xorint.ml | 22 - test/testinterp/t120-getstringchar.ml | 22 - test/testinterp/t121-setstringchar.ml | 31 - test/testinterp/t130-getvectitem.ml | 24 - test/testinterp/t130-vectlength.ml | 23 - test/testinterp/t131-setvectitem.ml | 33 - test/testinterp/t140-switch-1.ml | 32 - test/testinterp/t140-switch-2.ml | 32 - test/testinterp/t140-switch-3.ml | 31 - test/testinterp/t140-switch-4.ml | 31 - test/testinterp/t141-switch-5.ml | 38 - test/testinterp/t141-switch-6.ml | 38 - test/testinterp/t141-switch-7.ml | 37 - test/testinterp/t142-switch-8.ml | 34 - test/testinterp/t142-switch-9.ml | 34 - test/testinterp/t142-switch-A.ml | 34 - test/testinterp/t150-push-1.ml | 24 - test/testinterp/t150-push-2.ml | 39 - test/testinterp/t160-closure.ml | 19 - test/testinterp/t161-apply1.ml | 42 - test/testinterp/t162-return.ml | 21 - test/testinterp/t163.ml | 23 - test/testinterp/t164-apply2.ml | 24 - test/testinterp/t164-apply3.ml | 25 - test/testinterp/t165-apply.ml | 28 - test/testinterp/t170-envacc2.ml | 37 - test/testinterp/t170-envacc3.ml | 42 - test/testinterp/t170-envacc4.ml | 47 - test/testinterp/t171-envacc.ml | 52 - test/testinterp/t172-pushenvacc1.ml | 34 - test/testinterp/t172-pushenvacc2.ml | 37 - test/testinterp/t172-pushenvacc3.ml | 42 - test/testinterp/t172-pushenvacc4.ml | 47 - test/testinterp/t173-pushenvacc.ml | 52 - test/testinterp/t180-appterm1.ml | 35 - test/testinterp/t180-appterm2.ml | 38 - test/testinterp/t180-appterm3.ml | 39 - test/testinterp/t181-appterm.ml | 40 - test/testinterp/t190-makefloatblock-1.ml | 17 - test/testinterp/t190-makefloatblock-2.ml | 18 - test/testinterp/t190-makefloatblock-3.ml | 19 - test/testinterp/t191-vectlength.ml | 26 - test/testinterp/t192-getfloatfield-1.ml | 23 - test/testinterp/t192-getfloatfield-2.ml | 23 - test/testinterp/t193-setfloatfield-1.ml | 36 - test/testinterp/t193-setfloatfield-2.ml | 36 - test/testinterp/t200-getfield0.ml | 25 - test/testinterp/t200-getfield1.ml | 26 - test/testinterp/t200-getfield2.ml | 27 - test/testinterp/t200-getfield3.ml | 28 - test/testinterp/t201-getfield.ml | 29 - test/testinterp/t210-setfield0.ml | 36 - test/testinterp/t210-setfield1.ml | 38 - test/testinterp/t210-setfield2.ml | 40 - test/testinterp/t210-setfield3.ml | 42 - test/testinterp/t211-setfield.ml | 44 - test/testinterp/t220-assign.ml | 27 - test/testinterp/t230-check_signals.ml | 28 - test/testinterp/t240-c_call1.ml | 21 - test/testinterp/t240-c_call2.ml | 22 - test/testinterp/t240-c_call3.ml | 23 - test/testinterp/t240-c_call4.ml | 32 - test/testinterp/t240-c_call5.ml | 33 - test/testinterp/t250-closurerec-1.ml | 19 - test/testinterp/t250-closurerec-2.ml | 29 - test/testinterp/t251-pushoffsetclosure0.ml | 39 - test/testinterp/t251-pushoffsetclosure2.ml | 34 - test/testinterp/t251-pushoffsetclosurem2.ml | 34 - test/testinterp/t252-pushoffsetclosure.ml | 38 - test/testinterp/t253-offsetclosure0.ml | 34 - test/testinterp/t253-offsetclosure2.ml | 34 - test/testinterp/t253-offsetclosurem2.ml | 34 - test/testinterp/t254-offsetclosure.ml | 37 - test/testinterp/t260-offsetref.ml | 31 - test/testinterp/t270-push_retaddr.ml | 36 - test/testinterp/t300-getmethod.ml | 5885 -------------------- test/testinterp/t310-alloc-1.ml | 1587 ------ test/testinterp/t310-alloc-2.ml | 2313 -------- test/testinterp/t320-gc-1.ml | 1589 ------ test/testinterp/t320-gc-2.ml | 1589 ------ test/testinterp/t320-gc-3.ml | 1589 ------ test/testinterp/t330-compact-1.ml | 15 - test/testinterp/t330-compact-2.ml | 755 --- test/testinterp/t330-compact-3.ml | 1589 ------ test/testinterp/t330-compact-4.ml | 1589 ------ test/testinterp/t340-weak.ml | 2551 --------- test/testinterp/t350-heapcheck.ml | 2554 --------- test/testinterp/t360-stacks-1.ml | 43 - test/testinterp/t360-stacks-2.ml | 54 - testasmcomp/.cvsignore | 5 - testasmcomp/.depend | 17 - testasmcomp/Makefile | 159 - testasmcomp/alpha.S | 62 - testasmcomp/amd64.S | 53 - testasmcomp/arith.cmm | 222 - testasmcomp/arm.S | 45 - testasmcomp/checkbound.cmm | 21 - testasmcomp/fib.cmm | 19 - testasmcomp/hppa.S | 162 - testasmcomp/i386.S | 56 - testasmcomp/i386nt.asm | 67 - testasmcomp/ia64.S | 118 - testasmcomp/integr.cmm | 30 - testasmcomp/lexcmm.mli | 24 - testasmcomp/lexcmm.mll | 228 - testasmcomp/m68k.S | 59 - testasmcomp/main.c | 126 - testasmcomp/main.ml | 60 - testasmcomp/mainarith.c | 304 - testasmcomp/mips.s | 71 - testasmcomp/parsecmm.mly | 325 -- testasmcomp/parsecmmaux.ml | 40 - testasmcomp/parsecmmaux.mli | 26 - testasmcomp/power-aix.S | 152 - testasmcomp/power-elf.S | 131 - testasmcomp/power-rhapsody.S | 129 - testasmcomp/quicksort.cmm | 43 - testasmcomp/quicksort2.cmm | 49 - testasmcomp/soli.cmm | 109 - testasmcomp/sparc.S | 41 - testasmcomp/tagged-fib.cmm | 19 - testasmcomp/tagged-integr.cmm | 45 - testasmcomp/tagged-quicksort.cmm | 46 - testasmcomp/tagged-tak.cmm | 23 - testasmcomp/tak.cmm | 23 - testlabl/.cvsignore | 1 - testlabl/Makefile | 17 - testlabl/bugs/yamagata021012.ml | 193 - testlabl/dirs_multimatch | 1 - testlabl/dirs_poly | 1 - testlabl/mixin.ml | 146 - testlabl/mixin2.ml | 179 - testlabl/mixin3.ml | 173 - testlabl/multimatch.ml | 157 - testlabl/newlabels.ps | 1458 ----- testlabl/poly.exp | 332 -- testlabl/poly.exp2 | 339 -- testlabl/poly.ml | 468 -- testlabl/printers.ml | 11 - testlabl/tests.ml | 22 - testobjects/Exemples.exp | 301 - testobjects/Exemples.ml | 333 -- testobjects/Makefile | 25 - testobjects/Tests.exp | 228 - testobjects/Tests.ml | 316 -- tools/.cvsignore | 22 - tools/.depend | 49 - tools/Characters | 16 - tools/DoMake | 61 - tools/MakeDepend | 17 - tools/Makefile | 264 - tools/Makefile.Mac | 137 - tools/Makefile.Mac.depend | 30 - tools/Makefile.nt | 172 - tools/OCamlc-custom | 10 - tools/Time | 10 - tools/addlabels.ml | 451 -- tools/checkstack.c | 41 - tools/cleanup-header | 15 - tools/cvt_emit.mll | 84 - tools/depend.ml | 291 - tools/depend.mli | 23 - tools/dumpapprox.ml | 100 - tools/dumpobj.ml | 534 -- tools/keywords.r | 121 - tools/lexer299.mll | 472 -- tools/lexer301.mll | 474 -- tools/magic | 11 - tools/make-opcodes | 2 - tools/make-opcodes.Mac | 14 - tools/make-package-macosx | 52 - tools/objinfo.ml | 101 - tools/ocaml299to3.ml | 139 - tools/ocamlcp.ml | 134 - tools/ocamldep.ml | 228 - tools/ocamlmklib.mlp | 250 - tools/ocamlmktop.ml | 17 - tools/ocamlmktop.tpl | 26 - tools/ocamlprof.ml | 482 -- tools/ocamlsize | 49 - tools/primreq.ml | 90 - tools/profiling.ml | 53 - tools/profiling.mli | 19 - tools/scrapelabels.ml | 289 - toplevel/expunge.ml | 83 - toplevel/genprintval.ml | 363 -- toplevel/genprintval.mli | 52 - toplevel/topdirs.ml | 297 - toplevel/topdirs.mli | 34 - toplevel/toploop.ml | 409 -- toplevel/toploop.mli | 107 - toplevel/topmain.ml | 90 - toplevel/topmain.mli | 17 - toplevel/topstart.ml | 15 - toplevel/trace.ml | 144 - toplevel/trace.mli | 35 - typing/btype.ml | 465 -- typing/btype.mli | 147 - typing/ctype.ml | 3243 ----------- typing/ctype.mli | 238 - typing/datarepr.ml | 96 - typing/datarepr.mli | 34 - typing/env.ml | 784 --- typing/env.mli | 139 - typing/ident.ml | 172 - typing/ident.mli | 57 - typing/includeclass.ml | 104 - typing/includeclass.mli | 31 - typing/includecore.ml | 123 - typing/includecore.mli | 31 - typing/includemod.ml | 376 -- typing/includemod.mli | 46 - typing/mtype.ml | 179 - typing/mtype.mli | 32 - typing/oprint.ml | 453 -- typing/oprint.mli | 24 - typing/outcometree.mli | 96 - typing/parmatch.ml | 1617 ------ typing/parmatch.mli | 52 - typing/path.ml | 49 - typing/path.mli | 29 - typing/predef.ml | 187 - typing/predef.mli | 65 - typing/primitive.ml | 56 - typing/primitive.mli | 26 - typing/printtyp.ml | 1000 ---- typing/printtyp.mli | 67 - typing/stypes.ml | 130 - typing/stypes.mli | 33 - typing/subst.ml | 295 - typing/subst.mli | 51 - typing/typeclass.ml | 1495 ----- typing/typeclass.mli | 78 - typing/typecore.ml | 2028 ------- typing/typecore.mli | 108 - typing/typedecl.ml | 717 --- typing/typedecl.mli | 69 - typing/typedtree.ml | 228 - typing/typedtree.mli | 164 - typing/typemod.ml | 842 --- typing/typemod.mli | 54 - typing/types.ml | 193 - typing/types.mli | 195 - typing/typetexp.ml | 597 -- typing/typetexp.mli | 60 - utils/.cvsignore | 1 - utils/ccomp.ml | 99 - utils/ccomp.mli | 22 - utils/clflags.ml | 87 - utils/config.mli | 111 - utils/config.mlp | 77 - utils/consistbl.ml | 57 - utils/consistbl.mli | 60 - utils/misc.ml | 183 - utils/misc.mli | 94 - utils/tbl.ml | 104 - utils/tbl.mli | 30 - utils/terminfo.ml | 25 - utils/terminfo.mli | 25 - utils/warnings.ml | 148 - utils/warnings.mli | 43 - win32caml/Makefile | 52 - win32caml/inria.h | 115 - win32caml/inriares.h | 48 - win32caml/libgraph.h | 108 - win32caml/menu.c | 592 -- win32caml/ocaml.c | 816 --- win32caml/ocaml.ico | Bin 766 -> 0 bytes win32caml/ocaml.rc | 114 - win32caml/startocaml.c | 364 -- yacc/.cvsignore | 3 - yacc/Makefile | 46 - yacc/Makefile.Mac | 54 - yacc/Makefile.nt | 49 - yacc/closure.c | 283 - yacc/defs.h | 377 -- yacc/error.c | 313 -- yacc/lalr.c | 663 --- yacc/lr0.c | 621 --- yacc/main.c | 402 -- yacc/mkpar.c | 366 -- yacc/output.c | 984 ---- yacc/reader.c | 1839 ------ yacc/skeleton.c | 58 - yacc/symtab.c | 129 - yacc/verbose.c | 350 -- yacc/warshall.c | 96 - 1632 files changed, 281639 deletions(-) delete mode 100644 .cvsignore delete mode 100644 .depend delete mode 100644 Changes delete mode 100644 INSTALL delete mode 100644 INSTALL.MPW delete mode 100644 LICENSE delete mode 100644 Makefile delete mode 100644 Makefile.Mac delete mode 100644 Makefile.Mac.depend delete mode 100644 Makefile.nt delete mode 100644 README delete mode 100644 README.win32 delete mode 100644 Upgrading delete mode 100644 asmrun/.cvsignore delete mode 100644 asmrun/.depend delete mode 100644 asmrun/Makefile delete mode 100644 asmrun/Makefile.nt delete mode 100644 asmrun/alpha.S delete mode 100644 asmrun/amd64.S delete mode 100644 asmrun/arm.S delete mode 100644 asmrun/fail.c delete mode 100644 asmrun/hppa.S delete mode 100644 asmrun/i386.S delete mode 100644 asmrun/i386nt.asm delete mode 100644 asmrun/ia64.S delete mode 100644 asmrun/m68k.S delete mode 100644 asmrun/mips.s delete mode 100644 asmrun/power-aix.S delete mode 100644 asmrun/power-elf.S delete mode 100644 asmrun/power-rhapsody.S delete mode 100644 asmrun/roots.c delete mode 100644 asmrun/signals.c delete mode 100644 asmrun/sparc.S delete mode 100644 asmrun/stack.h delete mode 100644 asmrun/startup.c delete mode 100644 boot/.cvsignore delete mode 100755 boot/ocamlc delete mode 100755 boot/ocamllex delete mode 100644 camlp4/CHANGES delete mode 100644 camlp4/ICHANGES delete mode 100644 camlp4/Makefile delete mode 100644 camlp4/Makefile.Mac delete mode 100644 camlp4/boot/.cvsignore delete mode 100644 camlp4/camlp4/.cvsignore delete mode 100644 camlp4/camlp4/.depend delete mode 100644 camlp4/camlp4/Makefile delete mode 100644 camlp4/camlp4/Makefile.Mac delete mode 100644 camlp4/camlp4/Makefile.Mac.depend delete mode 100644 camlp4/camlp4/argl.ml delete mode 100644 camlp4/camlp4/ast2pt.ml delete mode 100644 camlp4/camlp4/ast2pt.mli delete mode 100644 camlp4/camlp4/mLast.mli delete mode 100644 camlp4/camlp4/pcaml.ml delete mode 100644 camlp4/camlp4/pcaml.mli delete mode 100644 camlp4/camlp4/quotation.ml delete mode 100644 camlp4/camlp4/quotation.mli delete mode 100644 camlp4/camlp4/reloc.ml delete mode 100644 camlp4/camlp4/reloc.mli delete mode 100644 camlp4/camlp4/spretty.ml delete mode 100644 camlp4/camlp4/spretty.mli delete mode 100644 camlp4/compile/.cvsignore delete mode 100644 camlp4/compile/.depend delete mode 100644 camlp4/compile/Makefile delete mode 100644 camlp4/compile/comp_head.ml delete mode 100644 camlp4/compile/comp_trail.ml delete mode 100644 camlp4/compile/compile.ml delete mode 100755 camlp4/compile/compile.sh delete mode 100644 camlp4/config/.cvsignore delete mode 100644 camlp4/config/Makefile-nt.cnf delete mode 100644 camlp4/config/Makefile.tpl delete mode 100644 camlp4/config/config.mpw delete mode 100755 camlp4/config/configure_batch delete mode 100644 camlp4/etc/.cvsignore delete mode 100644 camlp4/etc/.depend delete mode 100644 camlp4/etc/Makefile delete mode 100644 camlp4/etc/Makefile.Mac delete mode 100644 camlp4/etc/Makefile.Mac.depend delete mode 100644 camlp4/etc/lib.sml delete mode 100644 camlp4/etc/mkcamlp4.mpw.tpl delete mode 100755 camlp4/etc/mkcamlp4.sh.tpl delete mode 100644 camlp4/etc/pa_extfold.ml delete mode 100644 camlp4/etc/pa_extfun.ml delete mode 100644 camlp4/etc/pa_format.ml delete mode 100644 camlp4/etc/pa_fstream.ml delete mode 100644 camlp4/etc/pa_ifdef.ml delete mode 100644 camlp4/etc/pa_lefteval.ml delete mode 100644 camlp4/etc/pa_lisp.ml delete mode 100644 camlp4/etc/pa_lispr.ml delete mode 100644 camlp4/etc/pa_o.ml delete mode 100644 camlp4/etc/pa_ocamllex.ml delete mode 100644 camlp4/etc/pa_olabl.ml delete mode 100644 camlp4/etc/pa_oop.ml delete mode 100644 camlp4/etc/pa_op.ml delete mode 100644 camlp4/etc/pa_ru.ml delete mode 100644 camlp4/etc/pa_scheme.ml delete mode 100644 camlp4/etc/pa_schemer.ml delete mode 100644 camlp4/etc/pa_sml.ml delete mode 100644 camlp4/etc/parserify.ml delete mode 100644 camlp4/etc/parserify.mli delete mode 100644 camlp4/etc/pr_depend.ml delete mode 100644 camlp4/etc/pr_extend.ml delete mode 100644 camlp4/etc/pr_extfun.ml delete mode 100644 camlp4/etc/pr_null.ml delete mode 100644 camlp4/etc/pr_o.ml delete mode 100644 camlp4/etc/pr_op.ml delete mode 100644 camlp4/etc/pr_op_main.ml delete mode 100644 camlp4/etc/pr_r.ml delete mode 100644 camlp4/etc/pr_rp.ml delete mode 100644 camlp4/etc/pr_rp_main.ml delete mode 100644 camlp4/etc/pr_scheme.ml delete mode 100644 camlp4/etc/pr_schp_main.ml delete mode 100644 camlp4/etc/q_phony.ml delete mode 100644 camlp4/lib/.cvsignore delete mode 100644 camlp4/lib/.depend delete mode 100644 camlp4/lib/Makefile delete mode 100644 camlp4/lib/Makefile.Mac delete mode 100644 camlp4/lib/Makefile.Mac.depend delete mode 100644 camlp4/lib/extfold.ml delete mode 100644 camlp4/lib/extfold.mli delete mode 100644 camlp4/lib/extfun.ml delete mode 100644 camlp4/lib/extfun.mli delete mode 100644 camlp4/lib/fstream.ml delete mode 100644 camlp4/lib/fstream.mli delete mode 100644 camlp4/lib/gramext.ml delete mode 100644 camlp4/lib/gramext.mli delete mode 100644 camlp4/lib/grammar.ml delete mode 100644 camlp4/lib/grammar.mli delete mode 100644 camlp4/lib/plexer.ml delete mode 100644 camlp4/lib/plexer.mli delete mode 100644 camlp4/lib/stdpp.ml delete mode 100644 camlp4/lib/stdpp.mli delete mode 100644 camlp4/lib/token.ml delete mode 100644 camlp4/lib/token.mli delete mode 100644 camlp4/man/.cvsignore delete mode 100644 camlp4/man/Makefile delete mode 100644 camlp4/man/Makefile.Mac delete mode 100644 camlp4/man/camlp4.1.tpl delete mode 100644 camlp4/man/camlp4.help.tpl delete mode 100644 camlp4/meta/.cvsignore delete mode 100644 camlp4/meta/.depend delete mode 100644 camlp4/meta/Makefile delete mode 100644 camlp4/meta/Makefile.Mac delete mode 100644 camlp4/meta/Makefile.Mac.depend delete mode 100755 camlp4/meta/mk_q_MLast.sh delete mode 100644 camlp4/meta/pa_extend.ml delete mode 100644 camlp4/meta/pa_extend_m.ml delete mode 100644 camlp4/meta/pa_ifdef.ml delete mode 100644 camlp4/meta/pa_macro.ml delete mode 100644 camlp4/meta/pa_r.ml delete mode 100644 camlp4/meta/pa_rp.ml delete mode 100644 camlp4/meta/pr_dump.ml delete mode 100644 camlp4/meta/q_MLast.ml delete mode 100644 camlp4/ocaml_src/.cvsignore delete mode 100644 camlp4/ocaml_src/camlp4/.cvsignore delete mode 100644 camlp4/ocaml_src/camlp4/.depend delete mode 100644 camlp4/ocaml_src/camlp4/Makefile delete mode 100644 camlp4/ocaml_src/camlp4/Makefile.Mac delete mode 100644 camlp4/ocaml_src/camlp4/Makefile.Mac.depend delete mode 100644 camlp4/ocaml_src/camlp4/argl.ml delete mode 100644 camlp4/ocaml_src/camlp4/ast2pt.ml delete mode 100644 camlp4/ocaml_src/camlp4/ast2pt.mli delete mode 100644 camlp4/ocaml_src/camlp4/mLast.mli delete mode 100644 camlp4/ocaml_src/camlp4/pcaml.ml delete mode 100644 camlp4/ocaml_src/camlp4/pcaml.mli delete mode 100644 camlp4/ocaml_src/camlp4/quotation.ml delete mode 100644 camlp4/ocaml_src/camlp4/quotation.mli delete mode 100644 camlp4/ocaml_src/camlp4/reloc.ml delete mode 100644 camlp4/ocaml_src/camlp4/reloc.mli delete mode 100644 camlp4/ocaml_src/camlp4/spretty.ml delete mode 100644 camlp4/ocaml_src/camlp4/spretty.mli delete mode 100644 camlp4/ocaml_src/lib/.depend delete mode 100644 camlp4/ocaml_src/lib/Makefile delete mode 100644 camlp4/ocaml_src/lib/Makefile.Mac delete mode 100644 camlp4/ocaml_src/lib/Makefile.Mac.depend delete mode 100644 camlp4/ocaml_src/lib/extfold.ml delete mode 100644 camlp4/ocaml_src/lib/extfold.mli delete mode 100644 camlp4/ocaml_src/lib/extfun.ml delete mode 100644 camlp4/ocaml_src/lib/extfun.mli delete mode 100644 camlp4/ocaml_src/lib/fstream.ml delete mode 100644 camlp4/ocaml_src/lib/fstream.mli delete mode 100644 camlp4/ocaml_src/lib/gramext.ml delete mode 100644 camlp4/ocaml_src/lib/gramext.mli delete mode 100644 camlp4/ocaml_src/lib/grammar.ml delete mode 100644 camlp4/ocaml_src/lib/grammar.mli delete mode 100644 camlp4/ocaml_src/lib/plexer.ml delete mode 100644 camlp4/ocaml_src/lib/plexer.mli delete mode 100644 camlp4/ocaml_src/lib/stdpp.ml delete mode 100644 camlp4/ocaml_src/lib/stdpp.mli delete mode 100644 camlp4/ocaml_src/lib/token.ml delete mode 100644 camlp4/ocaml_src/lib/token.mli delete mode 100644 camlp4/ocaml_src/meta/.cvsignore delete mode 100644 camlp4/ocaml_src/meta/.depend delete mode 100644 camlp4/ocaml_src/meta/Makefile delete mode 100644 camlp4/ocaml_src/meta/Makefile.Mac delete mode 100644 camlp4/ocaml_src/meta/Makefile.Mac.depend delete mode 100644 camlp4/ocaml_src/meta/pa_extend.ml delete mode 100644 camlp4/ocaml_src/meta/pa_extend_m.ml delete mode 100644 camlp4/ocaml_src/meta/pa_ifdef.ml delete mode 100644 camlp4/ocaml_src/meta/pa_macro.ml delete mode 100644 camlp4/ocaml_src/meta/pa_r.ml delete mode 100644 camlp4/ocaml_src/meta/pa_rp.ml delete mode 100644 camlp4/ocaml_src/meta/pr_dump.ml delete mode 100644 camlp4/ocaml_src/meta/q_MLast.ml delete mode 100644 camlp4/ocaml_src/odyl/.cvsignore delete mode 100644 camlp4/ocaml_src/odyl/.depend delete mode 100644 camlp4/ocaml_src/odyl/Makefile delete mode 100644 camlp4/ocaml_src/odyl/Makefile.Mac delete mode 100644 camlp4/ocaml_src/odyl/Makefile.Mac.depend delete mode 100644 camlp4/ocaml_src/odyl/odyl.ml delete mode 100644 camlp4/ocaml_src/odyl/odyl_main.ml delete mode 100644 camlp4/ocaml_src/odyl/odyl_main.mli delete mode 100644 camlp4/ocaml_src/tools/camlp4_comm.mpw delete mode 100755 camlp4/ocaml_src/tools/camlp4_comm.sh delete mode 100644 camlp4/ocaml_src/tools/extract_crc.mpw delete mode 100755 camlp4/ocaml_src/tools/extract_crc.sh delete mode 100644 camlp4/ocaml_src/tools/ocamlc.mpw delete mode 100755 camlp4/ocaml_src/tools/ocamlc.sh delete mode 100755 camlp4/ocaml_src/tools/ocamlopt.sh delete mode 100644 camlp4/ocaml_stuff/otherlibs/dynlink/.depend delete mode 100644 camlp4/ocaml_stuff/parsing/.depend delete mode 100644 camlp4/ocaml_stuff/utils/.depend delete mode 100644 camlp4/ocpp/.cvsignore delete mode 100644 camlp4/ocpp/.depend delete mode 100644 camlp4/ocpp/Makefile delete mode 100644 camlp4/ocpp/Makefile.Mac delete mode 100644 camlp4/ocpp/ocpp.ml delete mode 100644 camlp4/odyl/.cvsignore delete mode 100644 camlp4/odyl/.depend delete mode 100644 camlp4/odyl/Makefile delete mode 100644 camlp4/odyl/Makefile.Mac delete mode 100644 camlp4/odyl/Makefile.Mac.depend delete mode 100644 camlp4/odyl/odyl.ml delete mode 100644 camlp4/odyl/odyl_main.ml delete mode 100644 camlp4/odyl/odyl_main.mli delete mode 100755 camlp4/tools/apply.sh delete mode 100644 camlp4/tools/camlp4_comm.mpw delete mode 100755 camlp4/tools/camlp4_comm.sh delete mode 100755 camlp4/tools/conv.sh delete mode 100644 camlp4/tools/extract_crc.mpw delete mode 100755 camlp4/tools/extract_crc.sh delete mode 100644 camlp4/tools/ocamlc.mpw delete mode 100755 camlp4/tools/ocamlc.sh delete mode 100755 camlp4/tools/ocamlopt.sh delete mode 100644 camlp4/top/.cvsignore delete mode 100644 camlp4/top/.depend delete mode 100644 camlp4/top/Makefile delete mode 100644 camlp4/top/Makefile.Mac delete mode 100644 camlp4/top/Makefile.Mac.depend delete mode 100644 camlp4/top/camlp4_top.ml delete mode 100644 camlp4/top/oprint.ml delete mode 100644 camlp4/top/rprint.ml delete mode 100644 config/.cvsignore delete mode 100644 config/Makefile-templ delete mode 100644 config/Makefile.mingw delete mode 100644 config/Makefile.msvc delete mode 100644 config/auto-aux/align.c delete mode 100644 config/auto-aux/ansi.c delete mode 100644 config/auto-aux/async_io.c delete mode 100644 config/auto-aux/bytecopy.c delete mode 100644 config/auto-aux/dblalign.c delete mode 100644 config/auto-aux/divmod.c delete mode 100644 config/auto-aux/elf.c delete mode 100644 config/auto-aux/endian.c delete mode 100644 config/auto-aux/getgroups.c delete mode 100644 config/auto-aux/gethostbyaddr.c delete mode 100644 config/auto-aux/gethostbyname.c delete mode 100755 config/auto-aux/hasgot delete mode 100644 config/auto-aux/ia32sse2.c delete mode 100644 config/auto-aux/int64align.c delete mode 100644 config/auto-aux/longlong.c delete mode 100755 config/auto-aux/runtest delete mode 100644 config/auto-aux/schar.c delete mode 100644 config/auto-aux/schar2.c delete mode 100755 config/auto-aux/searchpath delete mode 100755 config/auto-aux/sharpbang delete mode 100755 config/auto-aux/sharpbang2 delete mode 100644 config/auto-aux/sighandler.c delete mode 100644 config/auto-aux/signals.c delete mode 100644 config/auto-aux/sizes.c delete mode 100644 config/auto-aux/solaris-ld delete mode 100644 config/auto-aux/stackov.c delete mode 100644 config/auto-aux/tclversion.c delete mode 100755 config/auto-aux/trycompile delete mode 100644 config/config.Mac delete mode 100755 config/gnu/config.guess delete mode 100755 config/gnu/config.sub delete mode 100644 config/m-MacOS.h delete mode 100644 config/m-nt.h delete mode 100644 config/m-templ.h delete mode 100644 config/s-MacOS.h delete mode 100644 config/s-nt.h delete mode 100644 config/s-templ.h delete mode 100755 configure delete mode 100644 debugger/.cvsignore delete mode 100644 debugger/.depend delete mode 100644 debugger/Makefile delete mode 100644 debugger/breakpoints.ml delete mode 100644 debugger/breakpoints.mli delete mode 100644 debugger/checkpoints.ml delete mode 100644 debugger/checkpoints.mli delete mode 100644 debugger/command_line.ml delete mode 100644 debugger/command_line.mli delete mode 100644 debugger/debugcom.ml delete mode 100644 debugger/debugcom.mli delete mode 100644 debugger/debugger_config.ml delete mode 100644 debugger/debugger_config.mli delete mode 100644 debugger/envaux.ml delete mode 100644 debugger/envaux.mli delete mode 100644 debugger/eval.ml delete mode 100644 debugger/eval.mli delete mode 100644 debugger/events.ml delete mode 100644 debugger/events.mli delete mode 100644 debugger/exec.ml delete mode 100644 debugger/exec.mli delete mode 100644 debugger/frames.ml delete mode 100644 debugger/frames.mli delete mode 100644 debugger/history.ml delete mode 100644 debugger/history.mli delete mode 100644 debugger/input_handling.ml delete mode 100644 debugger/input_handling.mli delete mode 100644 debugger/int64ops.ml delete mode 100644 debugger/int64ops.mli delete mode 100644 debugger/lexer.mll delete mode 100644 debugger/loadprinter.ml delete mode 100644 debugger/loadprinter.mli delete mode 100644 debugger/main.ml delete mode 100644 debugger/parameters.ml delete mode 100644 debugger/parameters.mli delete mode 100644 debugger/parser.mly delete mode 100644 debugger/parser_aux.mli delete mode 100644 debugger/pattern_matching.ml delete mode 100644 debugger/pattern_matching.mli delete mode 100644 debugger/pos.ml delete mode 100644 debugger/pos.mli delete mode 100644 debugger/primitives.ml delete mode 100644 debugger/primitives.mli delete mode 100644 debugger/printval.ml delete mode 100644 debugger/printval.mli delete mode 100644 debugger/program_loading.ml delete mode 100644 debugger/program_loading.mli delete mode 100644 debugger/program_management.ml delete mode 100644 debugger/program_management.mli delete mode 100644 debugger/show_information.ml delete mode 100644 debugger/show_information.mli delete mode 100644 debugger/show_source.ml delete mode 100644 debugger/show_source.mli delete mode 100644 debugger/source.ml delete mode 100644 debugger/source.mli delete mode 100644 debugger/symbols.ml delete mode 100644 debugger/symbols.mli delete mode 100644 debugger/time_travel.ml delete mode 100644 debugger/time_travel.mli delete mode 100644 debugger/trap_barrier.ml delete mode 100644 debugger/trap_barrier.mli delete mode 100644 debugger/unix_tools.ml delete mode 100644 debugger/unix_tools.mli delete mode 100644 driver/compile.ml delete mode 100644 driver/compile.mli delete mode 100644 driver/errors.ml delete mode 100644 driver/errors.mli delete mode 100644 driver/main.ml delete mode 100644 driver/main.mli delete mode 100644 driver/main_args.ml delete mode 100644 driver/main_args.mli delete mode 100644 driver/ocamlcomp.sh.in delete mode 100644 driver/optcompile.ml delete mode 100644 driver/optcompile.mli delete mode 100644 driver/opterrors.ml delete mode 100644 driver/opterrors.mli delete mode 100644 driver/optmain.ml delete mode 100644 driver/optmain.mli delete mode 100644 driver/pparse.ml delete mode 100644 driver/pparse.mli delete mode 100644 emacs/.cvsignore delete mode 100644 emacs/Makefile delete mode 100644 emacs/README delete mode 100644 emacs/README.itz delete mode 100644 emacs/caml-compat.el delete mode 100644 emacs/caml-emacs.el delete mode 100644 emacs/caml-font.el delete mode 100644 emacs/caml-help.el delete mode 100644 emacs/caml-hilit.el delete mode 100644 emacs/caml-types.el delete mode 100644 emacs/caml-xemacs.el delete mode 100644 emacs/caml.el delete mode 100644 emacs/camldebug.el delete mode 100644 emacs/inf-caml.el delete mode 100644 emacs/ocamltags.in delete mode 100644 lex/.cvsignore delete mode 100644 lex/.depend delete mode 100644 lex/Makefile delete mode 100644 lex/Makefile.Mac delete mode 100644 lex/Makefile.Mac.depend delete mode 100644 lex/Makefile.nt delete mode 100644 lex/common.ml delete mode 100644 lex/common.mli delete mode 100644 lex/compact.ml delete mode 100644 lex/compact.mli delete mode 100644 lex/cset.ml delete mode 100644 lex/cset.mli delete mode 100644 lex/lexer.mli delete mode 100644 lex/lexer.mll delete mode 100644 lex/lexgen.ml delete mode 100644 lex/lexgen.mli delete mode 100644 lex/main.ml delete mode 100644 lex/output.ml delete mode 100644 lex/output.mli delete mode 100644 lex/outputbis.ml delete mode 100644 lex/outputbis.mli delete mode 100644 lex/parser.mly delete mode 100644 lex/syntax.ml delete mode 100644 lex/syntax.mli delete mode 100644 lex/table.ml delete mode 100644 lex/table.mli delete mode 100644 maccaml/.cvsignore delete mode 100644 maccaml/Makefile.Mac delete mode 100644 maccaml/Makefile.Mac.depend delete mode 100644 maccaml/SHORTCUTS delete mode 100644 maccaml/WASTE/.cvsignore delete mode 100644 maccaml/WASTE/Makefile delete mode 100644 maccaml/WASTE/README delete mode 100644 maccaml/aboutbox.c delete mode 100644 maccaml/appleevents.c delete mode 100644 maccaml/appli.r delete mode 100644 maccaml/clipboard.c delete mode 100644 maccaml/drag.c delete mode 100644 maccaml/dummy_fragment.c delete mode 100644 maccaml/errors.c delete mode 100644 maccaml/events.c delete mode 100644 maccaml/files.c delete mode 100644 maccaml/glue.c delete mode 100644 maccaml/graph.c delete mode 100644 maccaml/lcontrols.c delete mode 100644 maccaml/lib.c delete mode 100644 maccaml/main.c delete mode 100644 maccaml/main.h delete mode 100644 maccaml/mcmemory.c delete mode 100644 maccaml/mcmisc.c delete mode 100644 maccaml/menus.c delete mode 100644 maccaml/modalfilter.c delete mode 100644 maccaml/ocaml.r delete mode 100644 maccaml/ocamlconstants.h delete mode 100644 maccaml/ocamlmkappli delete mode 100644 maccaml/prefs.c delete mode 100644 maccaml/prim_bigarray delete mode 100644 maccaml/prim_graph delete mode 100644 maccaml/prim_num delete mode 100644 maccaml/prim_str delete mode 100644 maccaml/print.c delete mode 100644 maccaml/scroll.c delete mode 100644 maccaml/windows.c delete mode 100644 man/Makefile delete mode 100644 man/ocaml.help delete mode 100644 man/ocaml.m delete mode 100644 man/ocamlc.m delete mode 100644 man/ocamlcp.m delete mode 100644 man/ocamldebug.m delete mode 100644 man/ocamldep.m delete mode 100644 man/ocamllex.m delete mode 100644 man/ocamlmktop.m delete mode 100644 man/ocamlopt.m delete mode 100644 man/ocamlprof.m delete mode 100644 man/ocamlrun.m delete mode 100644 man/ocamlyacc.m delete mode 100644 ocamldoc/.cvsignore delete mode 100644 ocamldoc/.depend delete mode 100644 ocamldoc/Changes.txt delete mode 100644 ocamldoc/Makefile delete mode 100644 ocamldoc/Makefile.nt delete mode 100644 ocamldoc/ocamldoc.hva delete mode 100644 ocamldoc/ocamldoc.sty delete mode 100644 ocamldoc/odoc.ml delete mode 100644 ocamldoc/odoc_analyse.ml delete mode 100644 ocamldoc/odoc_analyse.mli delete mode 100644 ocamldoc/odoc_args.ml delete mode 100644 ocamldoc/odoc_args.mli delete mode 100644 ocamldoc/odoc_ast.ml delete mode 100644 ocamldoc/odoc_ast.mli delete mode 100644 ocamldoc/odoc_class.ml delete mode 100644 ocamldoc/odoc_comments.ml delete mode 100644 ocamldoc/odoc_comments.mli delete mode 100644 ocamldoc/odoc_comments_global.ml delete mode 100644 ocamldoc/odoc_comments_global.mli delete mode 100644 ocamldoc/odoc_control.ml delete mode 100644 ocamldoc/odoc_cross.ml delete mode 100644 ocamldoc/odoc_cross.mli delete mode 100644 ocamldoc/odoc_dag2html.ml delete mode 100644 ocamldoc/odoc_dag2html.mli delete mode 100644 ocamldoc/odoc_dep.ml delete mode 100644 ocamldoc/odoc_dot.ml delete mode 100644 ocamldoc/odoc_env.ml delete mode 100644 ocamldoc/odoc_env.mli delete mode 100644 ocamldoc/odoc_exception.ml delete mode 100644 ocamldoc/odoc_global.ml delete mode 100644 ocamldoc/odoc_global.mli delete mode 100644 ocamldoc/odoc_html.ml delete mode 100644 ocamldoc/odoc_info.ml delete mode 100644 ocamldoc/odoc_info.mli delete mode 100644 ocamldoc/odoc_inherit.ml delete mode 100644 ocamldoc/odoc_latex.ml delete mode 100644 ocamldoc/odoc_latex_style.ml delete mode 100644 ocamldoc/odoc_lexer.mll delete mode 100644 ocamldoc/odoc_man.ml delete mode 100644 ocamldoc/odoc_merge.ml delete mode 100644 ocamldoc/odoc_merge.mli delete mode 100644 ocamldoc/odoc_messages.ml delete mode 100644 ocamldoc/odoc_misc.ml delete mode 100644 ocamldoc/odoc_misc.mli delete mode 100644 ocamldoc/odoc_module.ml delete mode 100644 ocamldoc/odoc_name.ml delete mode 100644 ocamldoc/odoc_name.mli delete mode 100644 ocamldoc/odoc_ocamlhtml.mll delete mode 100644 ocamldoc/odoc_opt.ml delete mode 100644 ocamldoc/odoc_parameter.ml delete mode 100644 ocamldoc/odoc_parser.mly delete mode 100644 ocamldoc/odoc_scan.ml delete mode 100644 ocamldoc/odoc_search.ml delete mode 100644 ocamldoc/odoc_search.mli delete mode 100644 ocamldoc/odoc_see_lexer.mll delete mode 100644 ocamldoc/odoc_sig.ml delete mode 100644 ocamldoc/odoc_sig.mli delete mode 100644 ocamldoc/odoc_str.ml delete mode 100644 ocamldoc/odoc_str.mli delete mode 100644 ocamldoc/odoc_texi.ml delete mode 100644 ocamldoc/odoc_text.ml delete mode 100644 ocamldoc/odoc_text.mli delete mode 100644 ocamldoc/odoc_text_lexer.mll delete mode 100644 ocamldoc/odoc_text_parser.mly delete mode 100644 ocamldoc/odoc_to_text.ml delete mode 100644 ocamldoc/odoc_type.ml delete mode 100644 ocamldoc/odoc_types.ml delete mode 100644 ocamldoc/odoc_types.mli delete mode 100644 ocamldoc/odoc_value.ml delete mode 100755 ocamldoc/remove_DEBUG delete mode 100644 ocamldoc/runocamldoc delete mode 100644 otherlibs/bigarray/.cvsignore delete mode 100644 otherlibs/bigarray/.depend delete mode 100644 otherlibs/bigarray/Makefile delete mode 100644 otherlibs/bigarray/Makefile.Mac delete mode 100644 otherlibs/bigarray/Makefile.Mac.depend delete mode 100644 otherlibs/bigarray/Makefile.nt delete mode 100644 otherlibs/bigarray/bigarray.h delete mode 100644 otherlibs/bigarray/bigarray.ml delete mode 100644 otherlibs/bigarray/bigarray.mli delete mode 100644 otherlibs/bigarray/bigarray_stubs.c delete mode 100644 otherlibs/bigarray/mmap_unix.c delete mode 100644 otherlibs/bigarray/mmap_win32.c delete mode 100644 otherlibs/db/.depend delete mode 100644 otherlibs/dbm/.cvsignore delete mode 100644 otherlibs/dbm/.depend delete mode 100644 otherlibs/dbm/Makefile delete mode 100644 otherlibs/dbm/cldbm.c delete mode 100644 otherlibs/dbm/dbm.ml delete mode 100644 otherlibs/dbm/dbm.mli delete mode 100644 otherlibs/dynlink/.cvsignore delete mode 100644 otherlibs/dynlink/.depend delete mode 100644 otherlibs/dynlink/Makefile delete mode 100644 otherlibs/dynlink/Makefile.Mac delete mode 100644 otherlibs/dynlink/Makefile.Mac.depend delete mode 100644 otherlibs/dynlink/Makefile.nt delete mode 100644 otherlibs/dynlink/dynlink.ml delete mode 100644 otherlibs/dynlink/dynlink.mli delete mode 100644 otherlibs/dynlink/extract_crc.ml delete mode 100644 otherlibs/graph/.cvsignore delete mode 100644 otherlibs/graph/.depend delete mode 100644 otherlibs/graph/Makefile delete mode 100644 otherlibs/graph/Makefile.Mac delete mode 100644 otherlibs/graph/Makefile.Mac.depend delete mode 100644 otherlibs/graph/color.c delete mode 100644 otherlibs/graph/draw.c delete mode 100644 otherlibs/graph/dump_img.c delete mode 100644 otherlibs/graph/events.c delete mode 100644 otherlibs/graph/fill.c delete mode 100644 otherlibs/graph/graphics.ml delete mode 100644 otherlibs/graph/graphics.mli delete mode 100644 otherlibs/graph/graphicsX11.ml delete mode 100644 otherlibs/graph/graphicsX11.mli delete mode 100644 otherlibs/graph/image.c delete mode 100644 otherlibs/graph/image.h delete mode 100644 otherlibs/graph/libgraph.h delete mode 100644 otherlibs/graph/make_img.c delete mode 100644 otherlibs/graph/open.c delete mode 100644 otherlibs/graph/point_col.c delete mode 100644 otherlibs/graph/sound.c delete mode 100644 otherlibs/graph/subwindow.c delete mode 100644 otherlibs/graph/text.c delete mode 100644 otherlibs/labltk/.cvsignore delete mode 100644 otherlibs/labltk/Changes delete mode 100644 otherlibs/labltk/Makefile delete mode 100644 otherlibs/labltk/Makefile.nt delete mode 100644 otherlibs/labltk/README delete mode 100644 otherlibs/labltk/Widgets.src delete mode 100644 otherlibs/labltk/browser/.cvsignore delete mode 100644 otherlibs/labltk/browser/.depend delete mode 100644 otherlibs/labltk/browser/Makefile delete mode 100644 otherlibs/labltk/browser/Makefile.nt delete mode 100644 otherlibs/labltk/browser/README delete mode 100644 otherlibs/labltk/browser/dummyUnix.mli delete mode 100644 otherlibs/labltk/browser/dummyWin.mli delete mode 100644 otherlibs/labltk/browser/editor.ml delete mode 100644 otherlibs/labltk/browser/editor.mli delete mode 100644 otherlibs/labltk/browser/fileselect.ml delete mode 100644 otherlibs/labltk/browser/fileselect.mli delete mode 100644 otherlibs/labltk/browser/help.ml delete mode 100644 otherlibs/labltk/browser/help.txt delete mode 100644 otherlibs/labltk/browser/jg_bind.ml delete mode 100644 otherlibs/labltk/browser/jg_bind.mli delete mode 100644 otherlibs/labltk/browser/jg_box.ml delete mode 100644 otherlibs/labltk/browser/jg_button.ml delete mode 100644 otherlibs/labltk/browser/jg_completion.ml delete mode 100644 otherlibs/labltk/browser/jg_completion.mli delete mode 100644 otherlibs/labltk/browser/jg_config.ml delete mode 100644 otherlibs/labltk/browser/jg_config.mli delete mode 100644 otherlibs/labltk/browser/jg_entry.ml delete mode 100644 otherlibs/labltk/browser/jg_memo.ml delete mode 100644 otherlibs/labltk/browser/jg_memo.mli delete mode 100644 otherlibs/labltk/browser/jg_menu.ml delete mode 100644 otherlibs/labltk/browser/jg_message.ml delete mode 100644 otherlibs/labltk/browser/jg_message.mli delete mode 100644 otherlibs/labltk/browser/jg_multibox.ml delete mode 100644 otherlibs/labltk/browser/jg_multibox.mli delete mode 100644 otherlibs/labltk/browser/jg_text.ml delete mode 100644 otherlibs/labltk/browser/jg_text.mli delete mode 100644 otherlibs/labltk/browser/jg_tk.ml delete mode 100644 otherlibs/labltk/browser/jg_toplevel.ml delete mode 100644 otherlibs/labltk/browser/lexical.ml delete mode 100644 otherlibs/labltk/browser/lexical.mli delete mode 100644 otherlibs/labltk/browser/list2.ml delete mode 100644 otherlibs/labltk/browser/main.ml delete mode 100644 otherlibs/labltk/browser/mytypes.mli delete mode 100644 otherlibs/labltk/browser/searchid.ml delete mode 100644 otherlibs/labltk/browser/searchid.mli delete mode 100644 otherlibs/labltk/browser/searchpos.ml delete mode 100644 otherlibs/labltk/browser/searchpos.mli delete mode 100644 otherlibs/labltk/browser/setpath.ml delete mode 100644 otherlibs/labltk/browser/setpath.mli delete mode 100644 otherlibs/labltk/browser/shell.ml delete mode 100644 otherlibs/labltk/browser/shell.mli delete mode 100644 otherlibs/labltk/browser/typecheck.ml delete mode 100644 otherlibs/labltk/browser/typecheck.mli delete mode 100644 otherlibs/labltk/browser/useunix.ml delete mode 100644 otherlibs/labltk/browser/useunix.mli delete mode 100644 otherlibs/labltk/browser/viewer.ml delete mode 100644 otherlibs/labltk/browser/viewer.mli delete mode 100644 otherlibs/labltk/browser/winmain.c delete mode 100644 otherlibs/labltk/builtin/LICENSE delete mode 100644 otherlibs/labltk/builtin/builtin_FilePattern.ml delete mode 100644 otherlibs/labltk/builtin/builtin_GetBitmap.ml delete mode 100644 otherlibs/labltk/builtin/builtin_GetCursor.ml delete mode 100644 otherlibs/labltk/builtin/builtin_GetPixel.ml delete mode 100644 otherlibs/labltk/builtin/builtin_ScrollValue.ml delete mode 100644 otherlibs/labltk/builtin/builtin_bind.ml delete mode 100644 otherlibs/labltk/builtin/builtin_bindtags.ml delete mode 100644 otherlibs/labltk/builtin/builtin_font.ml delete mode 100644 otherlibs/labltk/builtin/builtin_grab.ml delete mode 100644 otherlibs/labltk/builtin/builtin_index.ml delete mode 100644 otherlibs/labltk/builtin/builtin_palette.ml delete mode 100644 otherlibs/labltk/builtin/builtin_text.ml delete mode 100644 otherlibs/labltk/builtin/builtina_empty.ml delete mode 100644 otherlibs/labltk/builtin/builtinf_GetPixel.ml delete mode 100644 otherlibs/labltk/builtin/builtinf_bind.ml delete mode 100644 otherlibs/labltk/builtin/builtini_GetBitmap.ml delete mode 100644 otherlibs/labltk/builtin/builtini_GetCursor.ml delete mode 100644 otherlibs/labltk/builtin/builtini_GetPixel.ml delete mode 100644 otherlibs/labltk/builtin/builtini_ScrollValue.ml delete mode 100644 otherlibs/labltk/builtin/builtini_bind.ml delete mode 100644 otherlibs/labltk/builtin/builtini_bindtags.ml delete mode 100644 otherlibs/labltk/builtin/builtini_font.ml delete mode 100644 otherlibs/labltk/builtin/builtini_grab.ml delete mode 100644 otherlibs/labltk/builtin/builtini_index.ml delete mode 100644 otherlibs/labltk/builtin/builtini_palette.ml delete mode 100644 otherlibs/labltk/builtin/builtini_text.ml delete mode 100644 otherlibs/labltk/builtin/canvas_bind.ml delete mode 100644 otherlibs/labltk/builtin/canvas_bind.mli delete mode 100644 otherlibs/labltk/builtin/dialog.ml delete mode 100644 otherlibs/labltk/builtin/dialog.mli delete mode 100644 otherlibs/labltk/builtin/image.ml delete mode 100644 otherlibs/labltk/builtin/image.mli delete mode 100644 otherlibs/labltk/builtin/optionmenu.ml delete mode 100644 otherlibs/labltk/builtin/optionmenu.mli delete mode 100644 otherlibs/labltk/builtin/rawimg.ml delete mode 100644 otherlibs/labltk/builtin/rawimg.mli delete mode 100644 otherlibs/labltk/builtin/report.ml delete mode 100644 otherlibs/labltk/builtin/selection_handle_set.ml delete mode 100644 otherlibs/labltk/builtin/selection_handle_set.mli delete mode 100644 otherlibs/labltk/builtin/selection_own_set.ml delete mode 100644 otherlibs/labltk/builtin/selection_own_set.mli delete mode 100644 otherlibs/labltk/builtin/text_tag_bind.ml delete mode 100644 otherlibs/labltk/builtin/text_tag_bind.mli delete mode 100644 otherlibs/labltk/builtin/winfo_contained.ml delete mode 100644 otherlibs/labltk/builtin/winfo_contained.mli delete mode 100644 otherlibs/labltk/camltk/.cvsignore delete mode 100644 otherlibs/labltk/camltk/Makefile delete mode 100644 otherlibs/labltk/camltk/Makefile.gen delete mode 100644 otherlibs/labltk/camltk/Makefile.gen.nt delete mode 100644 otherlibs/labltk/camltk/Makefile.nt delete mode 100644 otherlibs/labltk/camltk/modules delete mode 100644 otherlibs/labltk/compiler/.cvsignore delete mode 100644 otherlibs/labltk/compiler/.depend delete mode 100644 otherlibs/labltk/compiler/Makefile delete mode 100644 otherlibs/labltk/compiler/Makefile.nt delete mode 100644 otherlibs/labltk/compiler/code.mli delete mode 100644 otherlibs/labltk/compiler/compile.ml delete mode 100644 otherlibs/labltk/compiler/copyright delete mode 100644 otherlibs/labltk/compiler/flags.ml delete mode 100644 otherlibs/labltk/compiler/intf.ml delete mode 100644 otherlibs/labltk/compiler/lexer.mll delete mode 100644 otherlibs/labltk/compiler/maincompile.ml delete mode 100644 otherlibs/labltk/compiler/parser.mly delete mode 100644 otherlibs/labltk/compiler/pp.ml delete mode 100644 otherlibs/labltk/compiler/ppexec.ml delete mode 100644 otherlibs/labltk/compiler/pplex.mli delete mode 100644 otherlibs/labltk/compiler/pplex.mll delete mode 100644 otherlibs/labltk/compiler/ppparse.ml delete mode 100644 otherlibs/labltk/compiler/ppyac.mly delete mode 100644 otherlibs/labltk/compiler/printer.ml delete mode 100644 otherlibs/labltk/compiler/tables.ml delete mode 100644 otherlibs/labltk/compiler/tsort.ml create mode 100644 otherlibs/labltk/example/.gitignore delete mode 100644 otherlibs/labltk/examples_camltk/.cvsignore delete mode 100644 otherlibs/labltk/examples_camltk/Makefile delete mode 100644 otherlibs/labltk/examples_camltk/Makefile.nt delete mode 100644 otherlibs/labltk/examples_camltk/addition.ml delete mode 100644 otherlibs/labltk/examples_camltk/eyes.ml delete mode 100644 otherlibs/labltk/examples_camltk/fileinput.ml delete mode 100644 otherlibs/labltk/examples_camltk/fileopen.ml delete mode 100644 otherlibs/labltk/examples_camltk/helloworld.ml delete mode 100644 otherlibs/labltk/examples_camltk/images/CamlBook.gif delete mode 100644 otherlibs/labltk/examples_camltk/images/Lambda2.back.gif delete mode 100644 otherlibs/labltk/examples_camltk/images/dojoji.back.gif delete mode 100644 otherlibs/labltk/examples_camltk/jptest.ml delete mode 100644 otherlibs/labltk/examples_camltk/mytext.ml delete mode 100644 otherlibs/labltk/examples_camltk/socketinput.ml delete mode 100644 otherlibs/labltk/examples_camltk/taddition.ml delete mode 100644 otherlibs/labltk/examples_camltk/tetris.ml delete mode 100644 otherlibs/labltk/examples_camltk/text.ml delete mode 100644 otherlibs/labltk/examples_camltk/winskel.ml delete mode 100644 otherlibs/labltk/examples_labltk/.cvsignore delete mode 100644 otherlibs/labltk/examples_labltk/Lambda2.back.gif delete mode 100644 otherlibs/labltk/examples_labltk/Makefile delete mode 100644 otherlibs/labltk/examples_labltk/Makefile.nt delete mode 100644 otherlibs/labltk/examples_labltk/README delete mode 100644 otherlibs/labltk/examples_labltk/calc.ml delete mode 100644 otherlibs/labltk/examples_labltk/clock.ml delete mode 100644 otherlibs/labltk/examples_labltk/demo.ml delete mode 100644 otherlibs/labltk/examples_labltk/eyes.ml delete mode 100644 otherlibs/labltk/examples_labltk/hello.ml delete mode 100755 otherlibs/labltk/examples_labltk/hello.tcl delete mode 100644 otherlibs/labltk/examples_labltk/lang.ml delete mode 100644 otherlibs/labltk/examples_labltk/taquin.ml delete mode 100644 otherlibs/labltk/examples_labltk/tetris.ml delete mode 100644 otherlibs/labltk/frx/.depend delete mode 100644 otherlibs/labltk/frx/Makefile delete mode 100644 otherlibs/labltk/frx/Makefile.nt delete mode 100644 otherlibs/labltk/frx/README delete mode 100644 otherlibs/labltk/frx/frx_after.ml delete mode 100644 otherlibs/labltk/frx/frx_after.mli delete mode 100644 otherlibs/labltk/frx/frx_color.ml delete mode 100644 otherlibs/labltk/frx/frx_color.mli delete mode 100644 otherlibs/labltk/frx/frx_ctext.ml delete mode 100644 otherlibs/labltk/frx/frx_ctext.mli delete mode 100644 otherlibs/labltk/frx/frx_dialog.ml delete mode 100644 otherlibs/labltk/frx/frx_dialog.mli delete mode 100644 otherlibs/labltk/frx/frx_entry.ml delete mode 100644 otherlibs/labltk/frx/frx_entry.mli delete mode 100644 otherlibs/labltk/frx/frx_fileinput.ml delete mode 100644 otherlibs/labltk/frx/frx_fillbox.ml delete mode 100644 otherlibs/labltk/frx/frx_fillbox.mli delete mode 100644 otherlibs/labltk/frx/frx_fit.ml delete mode 100644 otherlibs/labltk/frx/frx_fit.mli delete mode 100644 otherlibs/labltk/frx/frx_focus.ml delete mode 100644 otherlibs/labltk/frx/frx_focus.mli delete mode 100644 otherlibs/labltk/frx/frx_font.ml delete mode 100644 otherlibs/labltk/frx/frx_font.mli delete mode 100644 otherlibs/labltk/frx/frx_group.ml delete mode 100644 otherlibs/labltk/frx/frx_lbutton.ml delete mode 100644 otherlibs/labltk/frx/frx_lbutton.mli delete mode 100644 otherlibs/labltk/frx/frx_listbox.ml delete mode 100644 otherlibs/labltk/frx/frx_listbox.mli delete mode 100644 otherlibs/labltk/frx/frx_mem.ml delete mode 100644 otherlibs/labltk/frx/frx_mem.mli delete mode 100644 otherlibs/labltk/frx/frx_misc.ml delete mode 100644 otherlibs/labltk/frx/frx_misc.mli delete mode 100644 otherlibs/labltk/frx/frx_req.ml delete mode 100644 otherlibs/labltk/frx/frx_req.mli delete mode 100644 otherlibs/labltk/frx/frx_rpc.ml delete mode 100644 otherlibs/labltk/frx/frx_rpc.mli delete mode 100644 otherlibs/labltk/frx/frx_selection.ml delete mode 100644 otherlibs/labltk/frx/frx_selection.mli delete mode 100644 otherlibs/labltk/frx/frx_synth.ml delete mode 100644 otherlibs/labltk/frx/frx_synth.mli delete mode 100644 otherlibs/labltk/frx/frx_text.ml delete mode 100644 otherlibs/labltk/frx/frx_text.mli delete mode 100644 otherlibs/labltk/frx/frx_toplevel.mli delete mode 100644 otherlibs/labltk/frx/frx_widget.ml delete mode 100644 otherlibs/labltk/frx/frx_widget.mli delete mode 100644 otherlibs/labltk/jpf/Makefile delete mode 100644 otherlibs/labltk/jpf/Makefile.nt delete mode 100644 otherlibs/labltk/jpf/README delete mode 100644 otherlibs/labltk/jpf/balloon.ml delete mode 100644 otherlibs/labltk/jpf/balloon.mli delete mode 100644 otherlibs/labltk/jpf/balloontest.ml delete mode 100644 otherlibs/labltk/jpf/fileselect.ml delete mode 100644 otherlibs/labltk/jpf/fileselect.mli delete mode 100644 otherlibs/labltk/jpf/jpf_font.ml delete mode 100644 otherlibs/labltk/jpf/jpf_font.mli delete mode 100644 otherlibs/labltk/jpf/shell.ml delete mode 100644 otherlibs/labltk/jpf/shell.mli delete mode 100644 otherlibs/labltk/labl.gif delete mode 100644 otherlibs/labltk/labltk/.cvsignore delete mode 100644 otherlibs/labltk/labltk/Makefile delete mode 100644 otherlibs/labltk/labltk/Makefile.gen delete mode 100644 otherlibs/labltk/labltk/Makefile.gen.nt delete mode 100644 otherlibs/labltk/labltk/Makefile.nt delete mode 100644 otherlibs/labltk/labltk/modules delete mode 100644 otherlibs/labltk/lib/.cvsignore delete mode 100644 otherlibs/labltk/lib/Makefile delete mode 100644 otherlibs/labltk/lib/Makefile.nt delete mode 100644 otherlibs/labltk/support/.depend delete mode 100644 otherlibs/labltk/support/Makefile delete mode 100644 otherlibs/labltk/support/Makefile.common delete mode 100644 otherlibs/labltk/support/Makefile.common.nt delete mode 100644 otherlibs/labltk/support/Makefile.nt delete mode 100644 otherlibs/labltk/support/camltk.h delete mode 100644 otherlibs/labltk/support/camltkwrap.ml delete mode 100644 otherlibs/labltk/support/camltkwrap.mli delete mode 100644 otherlibs/labltk/support/cltkCaml.c delete mode 100644 otherlibs/labltk/support/cltkDMain.c delete mode 100644 otherlibs/labltk/support/cltkEval.c delete mode 100644 otherlibs/labltk/support/cltkEvent.c delete mode 100644 otherlibs/labltk/support/cltkFile.c delete mode 100644 otherlibs/labltk/support/cltkImg.c delete mode 100644 otherlibs/labltk/support/cltkMain.c delete mode 100644 otherlibs/labltk/support/cltkMisc.c delete mode 100644 otherlibs/labltk/support/cltkTimer.c delete mode 100644 otherlibs/labltk/support/cltkUtf.c delete mode 100644 otherlibs/labltk/support/cltkVar.c delete mode 100644 otherlibs/labltk/support/cltkWait.c delete mode 100644 otherlibs/labltk/support/fileevent.ml delete mode 100644 otherlibs/labltk/support/fileevent.mli delete mode 100644 otherlibs/labltk/support/protocol.ml delete mode 100644 otherlibs/labltk/support/protocol.mli delete mode 100644 otherlibs/labltk/support/rawwidget.ml delete mode 100644 otherlibs/labltk/support/rawwidget.mli delete mode 100644 otherlibs/labltk/support/slave.ml delete mode 100644 otherlibs/labltk/support/support.ml delete mode 100644 otherlibs/labltk/support/support.mli delete mode 100644 otherlibs/labltk/support/textvariable.ml delete mode 100644 otherlibs/labltk/support/textvariable.mli delete mode 100644 otherlibs/labltk/support/timer.ml delete mode 100644 otherlibs/labltk/support/timer.mli delete mode 100644 otherlibs/labltk/support/tkwait.ml delete mode 100644 otherlibs/labltk/support/widget.ml delete mode 100644 otherlibs/labltk/support/widget.mli delete mode 100644 otherlibs/labltk/tkanim/.cvsignore delete mode 100644 otherlibs/labltk/tkanim/.depend delete mode 100644 otherlibs/labltk/tkanim/Makefile delete mode 100644 otherlibs/labltk/tkanim/Makefile.nt delete mode 100644 otherlibs/labltk/tkanim/README delete mode 100644 otherlibs/labltk/tkanim/cltkaniminit.c delete mode 100644 otherlibs/labltk/tkanim/gifanimtest.ml delete mode 100644 otherlibs/labltk/tkanim/mmm.anim.gif delete mode 100644 otherlibs/labltk/tkanim/tkAnimGIF.c delete mode 100644 otherlibs/labltk/tkanim/tkAppInit.c delete mode 100644 otherlibs/labltk/tkanim/tkanim.ml delete mode 100644 otherlibs/labltk/tkanim/tkanim.mli delete mode 100644 otherlibs/macosunix/.cvsignore delete mode 100644 otherlibs/macosunix/Makefile.Mac delete mode 100644 otherlibs/macosunix/Makefile.Mac.depend delete mode 100644 otherlibs/macosunix/macosunix.c delete mode 100644 otherlibs/macosunix/macosunix_startup.ml delete mode 100644 otherlibs/macosunix/macosunix_startup.mli delete mode 100644 otherlibs/macosunix/unix-primitives delete mode 100644 otherlibs/macosunix/unixsupport.h delete mode 100644 otherlibs/num/.cvsignore delete mode 100644 otherlibs/num/.depend delete mode 100644 otherlibs/num/.depend.nt delete mode 100644 otherlibs/num/Makefile delete mode 100644 otherlibs/num/Makefile.Mac delete mode 100644 otherlibs/num/Makefile.Mac.depend delete mode 100644 otherlibs/num/Makefile.nt delete mode 100644 otherlibs/num/README delete mode 100644 otherlibs/num/arith_flags.ml delete mode 100644 otherlibs/num/arith_flags.mli delete mode 100644 otherlibs/num/arith_status.ml delete mode 100644 otherlibs/num/arith_status.mli delete mode 100644 otherlibs/num/big_int.ml delete mode 100644 otherlibs/num/big_int.mli delete mode 100644 otherlibs/num/bignum/.cvsignore delete mode 100644 otherlibs/num/bng.c delete mode 100644 otherlibs/num/bng.h delete mode 100644 otherlibs/num/bng_alpha.c delete mode 100644 otherlibs/num/bng_amd64.c delete mode 100644 otherlibs/num/bng_digit.c delete mode 100644 otherlibs/num/bng_ia32.c delete mode 100644 otherlibs/num/bng_mips.c delete mode 100644 otherlibs/num/bng_ppc.c delete mode 100644 otherlibs/num/bng_sparc.c delete mode 100644 otherlibs/num/int_misc.ml delete mode 100644 otherlibs/num/int_misc.mli delete mode 100644 otherlibs/num/nat.h delete mode 100644 otherlibs/num/nat.ml delete mode 100644 otherlibs/num/nat.mli delete mode 100644 otherlibs/num/nat_stubs.c delete mode 100644 otherlibs/num/num.ml delete mode 100644 otherlibs/num/num.mli delete mode 100644 otherlibs/num/ratio.ml delete mode 100644 otherlibs/num/ratio.mli delete mode 100644 otherlibs/num/string_misc.ml delete mode 100644 otherlibs/num/string_misc.mli delete mode 100644 otherlibs/num/test/.depend delete mode 100644 otherlibs/num/test/Makefile delete mode 100644 otherlibs/num/test/Makefile.Mac delete mode 100644 otherlibs/num/test/Makefile.Mac.depend delete mode 100644 otherlibs/num/test/Makefile.nt delete mode 100644 otherlibs/num/test/end_test.ml delete mode 100644 otherlibs/num/test/test.ml delete mode 100644 otherlibs/num/test/test_big_ints.ml delete mode 100644 otherlibs/num/test/test_bng.c delete mode 100644 otherlibs/num/test/test_io.ml delete mode 100644 otherlibs/num/test/test_nats.ml delete mode 100644 otherlibs/num/test/test_nums.ml delete mode 100644 otherlibs/num/test/test_ratios.ml delete mode 100644 otherlibs/str/.cvsignore delete mode 100644 otherlibs/str/.depend delete mode 100644 otherlibs/str/Makefile delete mode 100644 otherlibs/str/Makefile.Mac delete mode 100644 otherlibs/str/Makefile.Mac.depend delete mode 100644 otherlibs/str/Makefile.nt delete mode 100644 otherlibs/str/str.ml delete mode 100644 otherlibs/str/str.mli delete mode 100644 otherlibs/str/strstubs.c delete mode 100644 otherlibs/systhreads/.cvsignore delete mode 100644 otherlibs/systhreads/.depend delete mode 100644 otherlibs/systhreads/Makefile delete mode 100644 otherlibs/systhreads/Makefile.Mac delete mode 100644 otherlibs/systhreads/Makefile.Mac.depend delete mode 100644 otherlibs/systhreads/Makefile.nt delete mode 100644 otherlibs/systhreads/Tests/Makefile delete mode 100644 otherlibs/systhreads/Tests/Makefile.nt delete mode 100644 otherlibs/systhreads/condition.ml delete mode 100644 otherlibs/systhreads/condition.mli delete mode 100644 otherlibs/systhreads/event.ml delete mode 100644 otherlibs/systhreads/event.mli delete mode 100644 otherlibs/systhreads/mutex.ml delete mode 100644 otherlibs/systhreads/mutex.mli delete mode 100644 otherlibs/systhreads/posix.c delete mode 100644 otherlibs/systhreads/thread.mli delete mode 100644 otherlibs/systhreads/threadUnix.ml delete mode 100644 otherlibs/systhreads/threadUnix.mli delete mode 100644 otherlibs/systhreads/thread_posix.ml delete mode 100644 otherlibs/systhreads/thread_win32.ml delete mode 100644 otherlibs/systhreads/win32.c delete mode 100644 otherlibs/threads/.cvsignore delete mode 100644 otherlibs/threads/.depend delete mode 100644 otherlibs/threads/Makefile delete mode 100644 otherlibs/threads/Tests/.cvsignore delete mode 100644 otherlibs/threads/Tests/Makefile delete mode 100644 otherlibs/threads/Tests/close.ml delete mode 100644 otherlibs/threads/Tests/sieve.ml delete mode 100644 otherlibs/threads/Tests/sorts.ml delete mode 100644 otherlibs/threads/Tests/test1.ml delete mode 100644 otherlibs/threads/Tests/test2.ml delete mode 100644 otherlibs/threads/Tests/test3.ml delete mode 100644 otherlibs/threads/Tests/test4.ml delete mode 100644 otherlibs/threads/Tests/test5.ml delete mode 100644 otherlibs/threads/Tests/test6.ml delete mode 100644 otherlibs/threads/Tests/test7.ml delete mode 100644 otherlibs/threads/Tests/test8.ml delete mode 100644 otherlibs/threads/Tests/test9.ml delete mode 100644 otherlibs/threads/Tests/testA.ml delete mode 100644 otherlibs/threads/Tests/testexit.ml delete mode 100644 otherlibs/threads/Tests/testio.ml delete mode 100644 otherlibs/threads/Tests/testsieve.ml delete mode 100644 otherlibs/threads/Tests/testsignal.ml delete mode 100644 otherlibs/threads/Tests/testsignal2.ml delete mode 100644 otherlibs/threads/Tests/testsocket.ml delete mode 100644 otherlibs/threads/Tests/token1.ml delete mode 100644 otherlibs/threads/Tests/token2.ml delete mode 100644 otherlibs/threads/Tests/torture.ml delete mode 100644 otherlibs/threads/condition.ml delete mode 100644 otherlibs/threads/condition.mli delete mode 100644 otherlibs/threads/event.ml delete mode 100644 otherlibs/threads/event.mli delete mode 100644 otherlibs/threads/marshal.ml delete mode 100644 otherlibs/threads/mutex.ml delete mode 100644 otherlibs/threads/mutex.mli delete mode 100644 otherlibs/threads/pervasives.ml delete mode 100644 otherlibs/threads/scheduler.c delete mode 100644 otherlibs/threads/thread.ml delete mode 100644 otherlibs/threads/thread.mli delete mode 100644 otherlibs/threads/threadUnix.ml delete mode 100644 otherlibs/threads/threadUnix.mli delete mode 100644 otherlibs/threads/unix.ml delete mode 100644 otherlibs/unix/.cvsignore delete mode 100644 otherlibs/unix/.depend delete mode 100644 otherlibs/unix/Makefile delete mode 100644 otherlibs/unix/accept.c delete mode 100644 otherlibs/unix/access.c delete mode 100644 otherlibs/unix/addrofstr.c delete mode 100644 otherlibs/unix/alarm.c delete mode 100644 otherlibs/unix/bind.c delete mode 100644 otherlibs/unix/chdir.c delete mode 100644 otherlibs/unix/chmod.c delete mode 100644 otherlibs/unix/chown.c delete mode 100644 otherlibs/unix/chroot.c delete mode 100644 otherlibs/unix/close.c delete mode 100644 otherlibs/unix/closedir.c delete mode 100644 otherlibs/unix/connect.c delete mode 100644 otherlibs/unix/cst2constr.c delete mode 100644 otherlibs/unix/cst2constr.h delete mode 100644 otherlibs/unix/cstringv.c delete mode 100644 otherlibs/unix/dup.c delete mode 100644 otherlibs/unix/dup2.c delete mode 100644 otherlibs/unix/envir.c delete mode 100644 otherlibs/unix/errmsg.c delete mode 100644 otherlibs/unix/execv.c delete mode 100644 otherlibs/unix/execve.c delete mode 100644 otherlibs/unix/execvp.c delete mode 100644 otherlibs/unix/exit.c delete mode 100644 otherlibs/unix/fchmod.c delete mode 100644 otherlibs/unix/fchown.c delete mode 100644 otherlibs/unix/fcntl.c delete mode 100644 otherlibs/unix/fork.c delete mode 100644 otherlibs/unix/ftruncate.c delete mode 100644 otherlibs/unix/getcwd.c delete mode 100644 otherlibs/unix/getegid.c delete mode 100644 otherlibs/unix/geteuid.c delete mode 100644 otherlibs/unix/getgid.c delete mode 100644 otherlibs/unix/getgr.c delete mode 100644 otherlibs/unix/getgroups.c delete mode 100644 otherlibs/unix/gethost.c delete mode 100644 otherlibs/unix/gethostname.c delete mode 100644 otherlibs/unix/getlogin.c delete mode 100644 otherlibs/unix/getpeername.c delete mode 100644 otherlibs/unix/getpid.c delete mode 100644 otherlibs/unix/getppid.c delete mode 100644 otherlibs/unix/getproto.c delete mode 100644 otherlibs/unix/getpw.c delete mode 100644 otherlibs/unix/getserv.c delete mode 100644 otherlibs/unix/getsockname.c delete mode 100644 otherlibs/unix/gettimeofday.c delete mode 100644 otherlibs/unix/getuid.c delete mode 100644 otherlibs/unix/gmtime.c delete mode 100644 otherlibs/unix/itimer.c delete mode 100644 otherlibs/unix/kill.c delete mode 100644 otherlibs/unix/link.c delete mode 100644 otherlibs/unix/listen.c delete mode 100644 otherlibs/unix/lockf.c delete mode 100644 otherlibs/unix/lseek.c delete mode 100644 otherlibs/unix/mkdir.c delete mode 100644 otherlibs/unix/mkfifo.c delete mode 100644 otherlibs/unix/nice.c delete mode 100644 otherlibs/unix/open.c delete mode 100644 otherlibs/unix/opendir.c delete mode 100644 otherlibs/unix/pipe.c delete mode 100644 otherlibs/unix/putenv.c delete mode 100644 otherlibs/unix/read.c delete mode 100644 otherlibs/unix/readdir.c delete mode 100644 otherlibs/unix/readlink.c delete mode 100644 otherlibs/unix/rename.c delete mode 100644 otherlibs/unix/rewinddir.c delete mode 100644 otherlibs/unix/rmdir.c delete mode 100644 otherlibs/unix/select.c delete mode 100644 otherlibs/unix/sendrecv.c delete mode 100644 otherlibs/unix/setgid.c delete mode 100644 otherlibs/unix/setsid.c delete mode 100644 otherlibs/unix/setuid.c delete mode 100644 otherlibs/unix/shutdown.c delete mode 100644 otherlibs/unix/signals.c delete mode 100644 otherlibs/unix/sleep.c delete mode 100644 otherlibs/unix/socket.c delete mode 100644 otherlibs/unix/socketaddr.c delete mode 100644 otherlibs/unix/socketaddr.h delete mode 100644 otherlibs/unix/socketpair.c delete mode 100644 otherlibs/unix/sockopt.c delete mode 100644 otherlibs/unix/stat.c delete mode 100644 otherlibs/unix/strofaddr.c delete mode 100644 otherlibs/unix/symlink.c delete mode 100644 otherlibs/unix/termios.c delete mode 100644 otherlibs/unix/time.c delete mode 100644 otherlibs/unix/times.c delete mode 100644 otherlibs/unix/truncate.c delete mode 100644 otherlibs/unix/umask.c delete mode 100644 otherlibs/unix/unix.ml delete mode 100644 otherlibs/unix/unix.mli delete mode 100644 otherlibs/unix/unixLabels.ml delete mode 100644 otherlibs/unix/unixLabels.mli delete mode 100644 otherlibs/unix/unixsupport.c delete mode 100644 otherlibs/unix/unixsupport.h delete mode 100644 otherlibs/unix/unlink.c delete mode 100644 otherlibs/unix/utimes.c delete mode 100644 otherlibs/unix/wait.c delete mode 100644 otherlibs/unix/write.c delete mode 100644 otherlibs/win32graph/Makefile.nt delete mode 100644 otherlibs/win32graph/dib.c delete mode 100644 otherlibs/win32graph/draw.c delete mode 100644 otherlibs/win32graph/libgraph.h delete mode 100644 otherlibs/win32graph/open.c delete mode 100644 otherlibs/win32unix/.cvsignore delete mode 100644 otherlibs/win32unix/.depend delete mode 100644 otherlibs/win32unix/Makefile.nt delete mode 100644 otherlibs/win32unix/accept.c delete mode 100644 otherlibs/win32unix/bind.c delete mode 100644 otherlibs/win32unix/channels.c delete mode 100644 otherlibs/win32unix/close.c delete mode 100644 otherlibs/win32unix/close_on.c delete mode 100644 otherlibs/win32unix/connect.c delete mode 100644 otherlibs/win32unix/createprocess.c delete mode 100644 otherlibs/win32unix/dup.c delete mode 100644 otherlibs/win32unix/dup2.c delete mode 100644 otherlibs/win32unix/errmsg.c delete mode 100644 otherlibs/win32unix/getpeername.c delete mode 100644 otherlibs/win32unix/getpid.c delete mode 100644 otherlibs/win32unix/getsockname.c delete mode 100644 otherlibs/win32unix/gettimeofday.c delete mode 100644 otherlibs/win32unix/link.c delete mode 100644 otherlibs/win32unix/listen.c delete mode 100644 otherlibs/win32unix/lockf.c delete mode 100644 otherlibs/win32unix/lseek.c delete mode 100644 otherlibs/win32unix/mkdir.c delete mode 100755 otherlibs/win32unix/nonblock.c delete mode 100644 otherlibs/win32unix/open.c delete mode 100644 otherlibs/win32unix/pipe.c delete mode 100644 otherlibs/win32unix/read.c delete mode 100644 otherlibs/win32unix/rename.c delete mode 100644 otherlibs/win32unix/select.c delete mode 100644 otherlibs/win32unix/sendrecv.c delete mode 100644 otherlibs/win32unix/shutdown.c delete mode 100644 otherlibs/win32unix/sleep.c delete mode 100644 otherlibs/win32unix/socket.c delete mode 100644 otherlibs/win32unix/socketaddr.h delete mode 100644 otherlibs/win32unix/sockopt.c delete mode 100644 otherlibs/win32unix/startup.c delete mode 100644 otherlibs/win32unix/stat.c delete mode 100644 otherlibs/win32unix/system.c delete mode 100644 otherlibs/win32unix/unix.ml delete mode 100644 otherlibs/win32unix/unixsupport.c delete mode 100644 otherlibs/win32unix/unixsupport.h delete mode 100644 otherlibs/win32unix/windir.c delete mode 100644 otherlibs/win32unix/winwait.c delete mode 100644 otherlibs/win32unix/write.c delete mode 100644 parsing/.cvsignore delete mode 100644 parsing/asttypes.mli delete mode 100644 parsing/lexer.mli delete mode 100644 parsing/lexer.mll delete mode 100644 parsing/linenum.mli delete mode 100644 parsing/linenum.mll delete mode 100644 parsing/location.ml delete mode 100644 parsing/location.mli delete mode 100644 parsing/longident.ml delete mode 100644 parsing/longident.mli delete mode 100644 parsing/parse.ml delete mode 100644 parsing/parse.mli delete mode 100644 parsing/parser.mly delete mode 100644 parsing/parsetree.mli delete mode 100644 parsing/printast.ml delete mode 100644 parsing/printast.mli delete mode 100644 parsing/syntaxerr.ml delete mode 100644 parsing/syntaxerr.mli delete mode 100644 test/.cvsignore delete mode 100644 test/.depend delete mode 100644 test/KB/equations.ml delete mode 100644 test/KB/equations.mli delete mode 100644 test/KB/kb.ml delete mode 100644 test/KB/kb.mli delete mode 100644 test/KB/kbmain.ml delete mode 100644 test/KB/orderings.ml delete mode 100644 test/KB/orderings.mli delete mode 100644 test/KB/terms.ml delete mode 100644 test/KB/terms.mli delete mode 100644 test/Lex/.cvsignore delete mode 100644 test/Lex/gram_aux.ml delete mode 100644 test/Lex/grammar.mly delete mode 100644 test/Lex/lexgen.ml delete mode 100644 test/Lex/main.ml delete mode 100644 test/Lex/output.ml delete mode 100644 test/Lex/scan_aux.ml delete mode 100644 test/Lex/scanner.mll delete mode 100644 test/Lex/syntax.ml delete mode 100644 test/Lex/testmain.ml delete mode 100644 test/Lex/testscanner.mll delete mode 100644 test/Makefile delete mode 100644 test/Makefile.Mac delete mode 100644 test/Makefile.Mac.depend delete mode 100644 test/Moretest/.cvsignore delete mode 100644 test/Moretest/.depend delete mode 100644 test/Moretest/Makefile delete mode 100644 test/Moretest/Makefile.Mac delete mode 100644 test/Moretest/Makefile.Mac.depend delete mode 100644 test/Moretest/arrays.ml delete mode 100644 test/Moretest/bigarrays.ml delete mode 100644 test/Moretest/bigarrf.f delete mode 100644 test/Moretest/bigarrfml.ml delete mode 100644 test/Moretest/bigarrfstub.c delete mode 100644 test/Moretest/bigints.ml delete mode 100644 test/Moretest/bounds.ml delete mode 100644 test/Moretest/boxedints.ml delete mode 100644 test/Moretest/callbackprim.c delete mode 100644 test/Moretest/cmcaml.ml delete mode 100644 test/Moretest/cmmain.c delete mode 100644 test/Moretest/cmstub.c delete mode 100644 test/Moretest/equality.ml delete mode 100644 test/Moretest/fftba.ml delete mode 100644 test/Moretest/float.ml delete mode 100644 test/Moretest/globroots.ml delete mode 100644 test/Moretest/globrootsprim.c delete mode 100644 test/Moretest/graph_example.ml delete mode 100644 test/Moretest/graph_test.ml delete mode 100644 test/Moretest/includestruct.ml delete mode 100644 test/Moretest/intext.ml delete mode 100644 test/Moretest/intextaux.c delete mode 100644 test/Moretest/io.ml delete mode 100644 test/Moretest/manyargs.ml delete mode 100644 test/Moretest/manyargsprim.c delete mode 100644 test/Moretest/md5.ml delete mode 100644 test/Moretest/morematch.ml delete mode 100644 test/Moretest/multdef.ml delete mode 100644 test/Moretest/multdef.mli delete mode 100644 test/Moretest/patmatch.ml delete mode 100644 test/Moretest/recvalues.ml delete mode 100644 test/Moretest/regexp.ml delete mode 100644 test/Moretest/sets.ml delete mode 100644 test/Moretest/signals.ml delete mode 100644 test/Moretest/stackoverflow.ml delete mode 100644 test/Moretest/syserror.ml delete mode 100644 test/Moretest/tailcalls.ml delete mode 100644 test/Moretest/tcallback.ml delete mode 100644 test/Moretest/testrandom.ml delete mode 100644 test/Moretest/tscanf.ml delete mode 100644 test/Moretest/usemultdef.ml delete mode 100644 test/Moretest/warnings.ml delete mode 100644 test/Moretest/wc.ml delete mode 100644 test/Results/almabench.fast.out delete mode 100644 test/Results/almabench.out delete mode 100644 test/Results/bdd.out delete mode 100644 test/Results/boyer.out delete mode 100644 test/Results/fft.fast.runtest delete mode 100644 test/Results/fft.fast.runtest.Mac delete mode 100644 test/Results/fft.runtest delete mode 100644 test/Results/fft.runtest.Mac delete mode 100644 test/Results/fib.out delete mode 100644 test/Results/genlex.runtest delete mode 100644 test/Results/genlex.runtest.Mac delete mode 100644 test/Results/hamming.out delete mode 100644 test/Results/kb.out delete mode 100644 test/Results/nucleic.out delete mode 100644 test/Results/quicksort.fast.out delete mode 100644 test/Results/quicksort.out delete mode 100644 test/Results/runtest delete mode 100644 test/Results/sieve.out delete mode 100644 test/Results/soli.fast.out delete mode 100644 test/Results/soli.out delete mode 100644 test/Results/sorts.out delete mode 100644 test/Results/takc.out delete mode 100644 test/Results/taku.out delete mode 100644 test/alloc.ml delete mode 100644 test/almabench.ml delete mode 100644 test/bdd.ml delete mode 100644 test/boyer.ml delete mode 100644 test/fft.ml delete mode 100644 test/fib.ml delete mode 100644 test/hamming.ml delete mode 100644 test/nucleic.ml delete mode 100644 test/quicksort.ml delete mode 100644 test/sieve.ml delete mode 100644 test/soli.ml delete mode 100644 test/sorts.ml delete mode 100644 test/takc.ml delete mode 100644 test/taku.ml delete mode 100644 test/testinterp/.cvsignore delete mode 100644 test/testinterp/Makefile.Mac delete mode 100644 test/testinterp/addbytecode.mpw delete mode 100644 test/testinterp/coverage delete mode 100644 test/testinterp/lib.ml delete mode 100644 test/testinterp/no68k.rez delete mode 100644 test/testinterp/noppc.rez delete mode 100644 test/testinterp/runtest.mpw delete mode 100644 test/testinterp/t000.ml delete mode 100644 test/testinterp/t010-const0.ml delete mode 100644 test/testinterp/t010-const1.ml delete mode 100644 test/testinterp/t010-const2.ml delete mode 100644 test/testinterp/t010-const3.ml delete mode 100644 test/testinterp/t011-constint.ml delete mode 100644 test/testinterp/t020.ml delete mode 100644 test/testinterp/t021-pushconst1.ml delete mode 100644 test/testinterp/t021-pushconst2.ml delete mode 100644 test/testinterp/t021-pushconst3.ml delete mode 100644 test/testinterp/t022-pushconstint.ml delete mode 100644 test/testinterp/t040-makeblock1.ml delete mode 100644 test/testinterp/t040-makeblock2.ml delete mode 100644 test/testinterp/t040-makeblock3.ml delete mode 100644 test/testinterp/t041-makeblock.ml delete mode 100644 test/testinterp/t050-getglobal.ml delete mode 100644 test/testinterp/t050-pushgetglobal.ml delete mode 100644 test/testinterp/t051-getglobalfield.ml delete mode 100644 test/testinterp/t051-pushgetglobalfield.ml delete mode 100644 test/testinterp/t060-raise.ml delete mode 100644 test/testinterp/t070-branch.ml delete mode 100644 test/testinterp/t070-branchif.ml delete mode 100644 test/testinterp/t070-branchifnot.ml delete mode 100644 test/testinterp/t071-boolnot.ml delete mode 100644 test/testinterp/t080-eq.ml delete mode 100644 test/testinterp/t080-geint.ml delete mode 100644 test/testinterp/t080-gtint.ml delete mode 100644 test/testinterp/t080-leint.ml delete mode 100644 test/testinterp/t080-ltint.ml delete mode 100644 test/testinterp/t080-neq.ml delete mode 100644 test/testinterp/t090-acc0.ml delete mode 100644 test/testinterp/t090-acc1.ml delete mode 100644 test/testinterp/t090-acc2.ml delete mode 100644 test/testinterp/t090-acc3.ml delete mode 100644 test/testinterp/t090-acc4.ml delete mode 100644 test/testinterp/t090-acc5.ml delete mode 100644 test/testinterp/t090-acc6.ml delete mode 100644 test/testinterp/t090-acc7.ml delete mode 100644 test/testinterp/t091-acc.ml delete mode 100644 test/testinterp/t092-pushacc.ml delete mode 100644 test/testinterp/t092-pushacc0.ml delete mode 100644 test/testinterp/t092-pushacc1.ml delete mode 100644 test/testinterp/t092-pushacc2.ml delete mode 100644 test/testinterp/t092-pushacc3.ml delete mode 100644 test/testinterp/t092-pushacc4.ml delete mode 100644 test/testinterp/t092-pushacc5.ml delete mode 100644 test/testinterp/t092-pushacc6.ml delete mode 100644 test/testinterp/t092-pushacc7.ml delete mode 100644 test/testinterp/t093-pushacc.ml delete mode 100644 test/testinterp/t100-pushtrap.ml delete mode 100644 test/testinterp/t101-poptrap.ml delete mode 100644 test/testinterp/t110-addint.ml delete mode 100644 test/testinterp/t110-andint.ml delete mode 100644 test/testinterp/t110-asrint-1.ml delete mode 100644 test/testinterp/t110-asrint-2.ml delete mode 100644 test/testinterp/t110-divint-1.ml delete mode 100644 test/testinterp/t110-divint-2.ml delete mode 100644 test/testinterp/t110-divint-3.ml delete mode 100644 test/testinterp/t110-lslint.ml delete mode 100644 test/testinterp/t110-lsrint.ml delete mode 100644 test/testinterp/t110-modint-1.ml delete mode 100644 test/testinterp/t110-modint-2.ml delete mode 100644 test/testinterp/t110-mulint.ml delete mode 100644 test/testinterp/t110-negint.ml delete mode 100644 test/testinterp/t110-offsetint.ml delete mode 100644 test/testinterp/t110-orint.ml delete mode 100644 test/testinterp/t110-subint.ml delete mode 100644 test/testinterp/t110-xorint.ml delete mode 100644 test/testinterp/t120-getstringchar.ml delete mode 100644 test/testinterp/t121-setstringchar.ml delete mode 100644 test/testinterp/t130-getvectitem.ml delete mode 100644 test/testinterp/t130-vectlength.ml delete mode 100644 test/testinterp/t131-setvectitem.ml delete mode 100644 test/testinterp/t140-switch-1.ml delete mode 100644 test/testinterp/t140-switch-2.ml delete mode 100644 test/testinterp/t140-switch-3.ml delete mode 100644 test/testinterp/t140-switch-4.ml delete mode 100644 test/testinterp/t141-switch-5.ml delete mode 100644 test/testinterp/t141-switch-6.ml delete mode 100644 test/testinterp/t141-switch-7.ml delete mode 100644 test/testinterp/t142-switch-8.ml delete mode 100644 test/testinterp/t142-switch-9.ml delete mode 100644 test/testinterp/t142-switch-A.ml delete mode 100644 test/testinterp/t150-push-1.ml delete mode 100644 test/testinterp/t150-push-2.ml delete mode 100644 test/testinterp/t160-closure.ml delete mode 100644 test/testinterp/t161-apply1.ml delete mode 100644 test/testinterp/t162-return.ml delete mode 100644 test/testinterp/t163.ml delete mode 100644 test/testinterp/t164-apply2.ml delete mode 100644 test/testinterp/t164-apply3.ml delete mode 100644 test/testinterp/t165-apply.ml delete mode 100644 test/testinterp/t170-envacc2.ml delete mode 100644 test/testinterp/t170-envacc3.ml delete mode 100644 test/testinterp/t170-envacc4.ml delete mode 100644 test/testinterp/t171-envacc.ml delete mode 100644 test/testinterp/t172-pushenvacc1.ml delete mode 100644 test/testinterp/t172-pushenvacc2.ml delete mode 100644 test/testinterp/t172-pushenvacc3.ml delete mode 100644 test/testinterp/t172-pushenvacc4.ml delete mode 100644 test/testinterp/t173-pushenvacc.ml delete mode 100644 test/testinterp/t180-appterm1.ml delete mode 100644 test/testinterp/t180-appterm2.ml delete mode 100644 test/testinterp/t180-appterm3.ml delete mode 100644 test/testinterp/t181-appterm.ml delete mode 100644 test/testinterp/t190-makefloatblock-1.ml delete mode 100644 test/testinterp/t190-makefloatblock-2.ml delete mode 100644 test/testinterp/t190-makefloatblock-3.ml delete mode 100644 test/testinterp/t191-vectlength.ml delete mode 100644 test/testinterp/t192-getfloatfield-1.ml delete mode 100644 test/testinterp/t192-getfloatfield-2.ml delete mode 100644 test/testinterp/t193-setfloatfield-1.ml delete mode 100644 test/testinterp/t193-setfloatfield-2.ml delete mode 100644 test/testinterp/t200-getfield0.ml delete mode 100644 test/testinterp/t200-getfield1.ml delete mode 100644 test/testinterp/t200-getfield2.ml delete mode 100644 test/testinterp/t200-getfield3.ml delete mode 100644 test/testinterp/t201-getfield.ml delete mode 100644 test/testinterp/t210-setfield0.ml delete mode 100644 test/testinterp/t210-setfield1.ml delete mode 100644 test/testinterp/t210-setfield2.ml delete mode 100644 test/testinterp/t210-setfield3.ml delete mode 100644 test/testinterp/t211-setfield.ml delete mode 100644 test/testinterp/t220-assign.ml delete mode 100644 test/testinterp/t230-check_signals.ml delete mode 100644 test/testinterp/t240-c_call1.ml delete mode 100644 test/testinterp/t240-c_call2.ml delete mode 100644 test/testinterp/t240-c_call3.ml delete mode 100644 test/testinterp/t240-c_call4.ml delete mode 100644 test/testinterp/t240-c_call5.ml delete mode 100644 test/testinterp/t250-closurerec-1.ml delete mode 100644 test/testinterp/t250-closurerec-2.ml delete mode 100644 test/testinterp/t251-pushoffsetclosure0.ml delete mode 100644 test/testinterp/t251-pushoffsetclosure2.ml delete mode 100644 test/testinterp/t251-pushoffsetclosurem2.ml delete mode 100644 test/testinterp/t252-pushoffsetclosure.ml delete mode 100644 test/testinterp/t253-offsetclosure0.ml delete mode 100644 test/testinterp/t253-offsetclosure2.ml delete mode 100644 test/testinterp/t253-offsetclosurem2.ml delete mode 100644 test/testinterp/t254-offsetclosure.ml delete mode 100644 test/testinterp/t260-offsetref.ml delete mode 100644 test/testinterp/t270-push_retaddr.ml delete mode 100644 test/testinterp/t300-getmethod.ml delete mode 100644 test/testinterp/t310-alloc-1.ml delete mode 100644 test/testinterp/t310-alloc-2.ml delete mode 100644 test/testinterp/t320-gc-1.ml delete mode 100644 test/testinterp/t320-gc-2.ml delete mode 100644 test/testinterp/t320-gc-3.ml delete mode 100644 test/testinterp/t330-compact-1.ml delete mode 100644 test/testinterp/t330-compact-2.ml delete mode 100644 test/testinterp/t330-compact-3.ml delete mode 100644 test/testinterp/t330-compact-4.ml delete mode 100644 test/testinterp/t340-weak.ml delete mode 100644 test/testinterp/t350-heapcheck.ml delete mode 100644 test/testinterp/t360-stacks-1.ml delete mode 100644 test/testinterp/t360-stacks-2.ml delete mode 100644 testasmcomp/.cvsignore delete mode 100644 testasmcomp/.depend delete mode 100644 testasmcomp/Makefile delete mode 100644 testasmcomp/alpha.S delete mode 100644 testasmcomp/amd64.S delete mode 100644 testasmcomp/arith.cmm delete mode 100644 testasmcomp/arm.S delete mode 100644 testasmcomp/checkbound.cmm delete mode 100644 testasmcomp/fib.cmm delete mode 100644 testasmcomp/hppa.S delete mode 100644 testasmcomp/i386.S delete mode 100644 testasmcomp/i386nt.asm delete mode 100644 testasmcomp/ia64.S delete mode 100644 testasmcomp/integr.cmm delete mode 100644 testasmcomp/lexcmm.mli delete mode 100644 testasmcomp/lexcmm.mll delete mode 100644 testasmcomp/m68k.S delete mode 100644 testasmcomp/main.c delete mode 100644 testasmcomp/main.ml delete mode 100644 testasmcomp/mainarith.c delete mode 100644 testasmcomp/mips.s delete mode 100644 testasmcomp/parsecmm.mly delete mode 100644 testasmcomp/parsecmmaux.ml delete mode 100644 testasmcomp/parsecmmaux.mli delete mode 100644 testasmcomp/power-aix.S delete mode 100644 testasmcomp/power-elf.S delete mode 100644 testasmcomp/power-rhapsody.S delete mode 100644 testasmcomp/quicksort.cmm delete mode 100644 testasmcomp/quicksort2.cmm delete mode 100644 testasmcomp/soli.cmm delete mode 100644 testasmcomp/sparc.S delete mode 100644 testasmcomp/tagged-fib.cmm delete mode 100644 testasmcomp/tagged-integr.cmm delete mode 100644 testasmcomp/tagged-quicksort.cmm delete mode 100644 testasmcomp/tagged-tak.cmm delete mode 100644 testasmcomp/tak.cmm delete mode 100644 testlabl/.cvsignore delete mode 100644 testlabl/Makefile delete mode 100644 testlabl/bugs/yamagata021012.ml delete mode 100644 testlabl/dirs_multimatch delete mode 100644 testlabl/dirs_poly delete mode 100644 testlabl/mixin.ml delete mode 100644 testlabl/mixin2.ml delete mode 100644 testlabl/mixin3.ml delete mode 100644 testlabl/multimatch.ml delete mode 100644 testlabl/newlabels.ps delete mode 100644 testlabl/poly.exp delete mode 100644 testlabl/poly.exp2 delete mode 100644 testlabl/poly.ml delete mode 100644 testlabl/printers.ml delete mode 100644 testlabl/tests.ml delete mode 100644 testobjects/Exemples.exp delete mode 100644 testobjects/Exemples.ml delete mode 100644 testobjects/Makefile delete mode 100644 testobjects/Tests.exp delete mode 100644 testobjects/Tests.ml delete mode 100644 tools/.cvsignore delete mode 100644 tools/.depend delete mode 100644 tools/Characters delete mode 100644 tools/DoMake delete mode 100644 tools/MakeDepend delete mode 100644 tools/Makefile delete mode 100644 tools/Makefile.Mac delete mode 100644 tools/Makefile.Mac.depend delete mode 100644 tools/Makefile.nt delete mode 100644 tools/OCamlc-custom delete mode 100644 tools/Time delete mode 100644 tools/addlabels.ml delete mode 100644 tools/checkstack.c delete mode 100644 tools/cleanup-header delete mode 100644 tools/cvt_emit.mll delete mode 100644 tools/depend.ml delete mode 100644 tools/depend.mli delete mode 100644 tools/dumpapprox.ml delete mode 100644 tools/dumpobj.ml delete mode 100644 tools/keywords.r delete mode 100644 tools/lexer299.mll delete mode 100644 tools/lexer301.mll delete mode 100644 tools/magic delete mode 100644 tools/make-opcodes delete mode 100644 tools/make-opcodes.Mac delete mode 100755 tools/make-package-macosx delete mode 100644 tools/objinfo.ml delete mode 100644 tools/ocaml299to3.ml delete mode 100644 tools/ocamlcp.ml delete mode 100644 tools/ocamldep.ml delete mode 100644 tools/ocamlmklib.mlp delete mode 100644 tools/ocamlmktop.ml delete mode 100644 tools/ocamlmktop.tpl delete mode 100644 tools/ocamlprof.ml delete mode 100755 tools/ocamlsize delete mode 100644 tools/primreq.ml delete mode 100644 tools/profiling.ml delete mode 100644 tools/profiling.mli delete mode 100644 tools/scrapelabels.ml delete mode 100644 toplevel/expunge.ml delete mode 100644 toplevel/genprintval.ml delete mode 100644 toplevel/genprintval.mli delete mode 100644 toplevel/topdirs.ml delete mode 100644 toplevel/topdirs.mli delete mode 100644 toplevel/toploop.ml delete mode 100644 toplevel/toploop.mli delete mode 100644 toplevel/topmain.ml delete mode 100644 toplevel/topmain.mli delete mode 100644 toplevel/topstart.ml delete mode 100644 toplevel/trace.ml delete mode 100644 toplevel/trace.mli delete mode 100644 typing/btype.ml delete mode 100644 typing/btype.mli delete mode 100644 typing/ctype.ml delete mode 100644 typing/ctype.mli delete mode 100644 typing/datarepr.ml delete mode 100644 typing/datarepr.mli delete mode 100644 typing/env.ml delete mode 100644 typing/env.mli delete mode 100644 typing/ident.ml delete mode 100644 typing/ident.mli delete mode 100644 typing/includeclass.ml delete mode 100644 typing/includeclass.mli delete mode 100644 typing/includecore.ml delete mode 100644 typing/includecore.mli delete mode 100644 typing/includemod.ml delete mode 100644 typing/includemod.mli delete mode 100644 typing/mtype.ml delete mode 100644 typing/mtype.mli delete mode 100644 typing/oprint.ml delete mode 100644 typing/oprint.mli delete mode 100644 typing/outcometree.mli delete mode 100644 typing/parmatch.ml delete mode 100644 typing/parmatch.mli delete mode 100644 typing/path.ml delete mode 100644 typing/path.mli delete mode 100644 typing/predef.ml delete mode 100644 typing/predef.mli delete mode 100644 typing/primitive.ml delete mode 100644 typing/primitive.mli delete mode 100644 typing/printtyp.ml delete mode 100644 typing/printtyp.mli delete mode 100644 typing/stypes.ml delete mode 100644 typing/stypes.mli delete mode 100644 typing/subst.ml delete mode 100644 typing/subst.mli delete mode 100644 typing/typeclass.ml delete mode 100644 typing/typeclass.mli delete mode 100644 typing/typecore.ml delete mode 100644 typing/typecore.mli delete mode 100644 typing/typedecl.ml delete mode 100644 typing/typedecl.mli delete mode 100644 typing/typedtree.ml delete mode 100644 typing/typedtree.mli delete mode 100644 typing/typemod.ml delete mode 100644 typing/typemod.mli delete mode 100644 typing/types.ml delete mode 100644 typing/types.mli delete mode 100644 typing/typetexp.ml delete mode 100644 typing/typetexp.mli delete mode 100644 utils/.cvsignore delete mode 100644 utils/ccomp.ml delete mode 100644 utils/ccomp.mli delete mode 100644 utils/clflags.ml delete mode 100644 utils/config.mli delete mode 100644 utils/config.mlp delete mode 100644 utils/consistbl.ml delete mode 100644 utils/consistbl.mli delete mode 100644 utils/misc.ml delete mode 100644 utils/misc.mli delete mode 100644 utils/tbl.ml delete mode 100644 utils/tbl.mli delete mode 100644 utils/terminfo.ml delete mode 100644 utils/terminfo.mli delete mode 100644 utils/warnings.ml delete mode 100644 utils/warnings.mli delete mode 100644 win32caml/Makefile delete mode 100644 win32caml/inria.h delete mode 100644 win32caml/inriares.h delete mode 100644 win32caml/libgraph.h delete mode 100644 win32caml/menu.c delete mode 100644 win32caml/ocaml.c delete mode 100644 win32caml/ocaml.ico delete mode 100644 win32caml/ocaml.rc delete mode 100644 win32caml/startocaml.c delete mode 100644 yacc/.cvsignore delete mode 100644 yacc/Makefile delete mode 100644 yacc/Makefile.Mac delete mode 100644 yacc/Makefile.nt delete mode 100644 yacc/closure.c delete mode 100644 yacc/defs.h delete mode 100644 yacc/error.c delete mode 100644 yacc/lalr.c delete mode 100644 yacc/lr0.c delete mode 100644 yacc/main.c delete mode 100644 yacc/mkpar.c delete mode 100644 yacc/output.c delete mode 100644 yacc/reader.c delete mode 100644 yacc/skeleton.c delete mode 100644 yacc/symtab.c delete mode 100644 yacc/verbose.c delete mode 100644 yacc/warshall.c diff --git a/.cvsignore b/.cvsignore deleted file mode 100644 index 25b3103837..0000000000 --- a/.cvsignore +++ /dev/null @@ -1,13 +0,0 @@ -.cvsignore -.depend -configure -ocamlc -ocamlc.opt -expunge -ocaml -ocamlopt -ocamlopt.opt -ocamlcomp.sh -ocamlcompopt.sh -package-macosx -.DS_Store diff --git a/.depend b/.depend deleted file mode 100644 index bf99d6fa8f..0000000000 --- a/.depend +++ /dev/null @@ -1,772 +0,0 @@ -utils/ccomp.cmo: utils/clflags.cmo utils/config.cmi utils/misc.cmi \ - utils/ccomp.cmi -utils/ccomp.cmx: utils/clflags.cmx utils/config.cmx utils/misc.cmx \ - utils/ccomp.cmi -utils/clflags.cmo: utils/config.cmi -utils/clflags.cmx: utils/config.cmx -utils/config.cmo: utils/config.cmi -utils/config.cmx: utils/config.cmi -utils/consistbl.cmo: utils/consistbl.cmi -utils/consistbl.cmx: utils/consistbl.cmi -utils/misc.cmo: utils/misc.cmi -utils/misc.cmx: utils/misc.cmi -utils/tbl.cmo: utils/tbl.cmi -utils/tbl.cmx: utils/tbl.cmi -utils/terminfo.cmo: utils/terminfo.cmi -utils/terminfo.cmx: utils/terminfo.cmi -utils/warnings.cmo: utils/warnings.cmi -utils/warnings.cmx: utils/warnings.cmi -parsing/lexer.cmi: parsing/location.cmi parsing/parser.cmi -parsing/location.cmi: utils/warnings.cmi -parsing/parse.cmi: parsing/parsetree.cmi -parsing/parser.cmi: parsing/parsetree.cmi -parsing/parsetree.cmi: parsing/asttypes.cmi parsing/location.cmi \ - parsing/longident.cmi -parsing/printast.cmi: parsing/parsetree.cmi -parsing/syntaxerr.cmi: parsing/location.cmi -parsing/lexer.cmo: parsing/location.cmi utils/misc.cmi parsing/parser.cmi \ - utils/warnings.cmi parsing/lexer.cmi -parsing/lexer.cmx: parsing/location.cmx utils/misc.cmx parsing/parser.cmx \ - utils/warnings.cmx parsing/lexer.cmi -parsing/linenum.cmo: utils/misc.cmi parsing/linenum.cmi -parsing/linenum.cmx: utils/misc.cmx parsing/linenum.cmi -parsing/location.cmo: parsing/linenum.cmi utils/terminfo.cmi \ - utils/warnings.cmi parsing/location.cmi -parsing/location.cmx: parsing/linenum.cmx utils/terminfo.cmx \ - utils/warnings.cmx parsing/location.cmi -parsing/longident.cmo: utils/misc.cmi parsing/longident.cmi -parsing/longident.cmx: utils/misc.cmx parsing/longident.cmi -parsing/parse.cmo: parsing/lexer.cmi parsing/location.cmi parsing/parser.cmi \ - parsing/syntaxerr.cmi parsing/parse.cmi -parsing/parse.cmx: parsing/lexer.cmx parsing/location.cmx parsing/parser.cmx \ - parsing/syntaxerr.cmx parsing/parse.cmi -parsing/parser.cmo: parsing/asttypes.cmi utils/clflags.cmo \ - parsing/location.cmi parsing/longident.cmi parsing/parsetree.cmi \ - parsing/syntaxerr.cmi parsing/parser.cmi -parsing/parser.cmx: parsing/asttypes.cmi utils/clflags.cmx \ - parsing/location.cmx parsing/longident.cmx parsing/parsetree.cmi \ - parsing/syntaxerr.cmx parsing/parser.cmi -parsing/printast.cmo: parsing/asttypes.cmi parsing/location.cmi \ - parsing/longident.cmi parsing/parsetree.cmi parsing/printast.cmi -parsing/printast.cmx: parsing/asttypes.cmi parsing/location.cmx \ - parsing/longident.cmx parsing/parsetree.cmi parsing/printast.cmi -parsing/syntaxerr.cmo: parsing/location.cmi parsing/syntaxerr.cmi -parsing/syntaxerr.cmx: parsing/location.cmx parsing/syntaxerr.cmi -typing/btype.cmi: parsing/asttypes.cmi typing/path.cmi typing/types.cmi -typing/ctype.cmi: parsing/asttypes.cmi typing/env.cmi typing/ident.cmi \ - typing/path.cmi typing/types.cmi -typing/datarepr.cmi: parsing/asttypes.cmi typing/path.cmi typing/types.cmi -typing/env.cmi: utils/consistbl.cmi typing/ident.cmi parsing/longident.cmi \ - typing/path.cmi typing/types.cmi -typing/includeclass.cmi: typing/ctype.cmi typing/env.cmi typing/typedtree.cmi \ - typing/types.cmi -typing/includecore.cmi: typing/env.cmi typing/ident.cmi typing/typedtree.cmi \ - typing/types.cmi -typing/includemod.cmi: typing/ctype.cmi typing/env.cmi typing/ident.cmi \ - typing/typedtree.cmi typing/types.cmi -typing/mtype.cmi: typing/env.cmi typing/ident.cmi typing/path.cmi \ - typing/types.cmi -typing/oprint.cmi: typing/outcometree.cmi -typing/outcometree.cmi: parsing/asttypes.cmi -typing/parmatch.cmi: typing/env.cmi parsing/location.cmi typing/typedtree.cmi \ - typing/types.cmi -typing/path.cmi: typing/ident.cmi -typing/predef.cmi: typing/ident.cmi typing/path.cmi typing/types.cmi -typing/printtyp.cmi: typing/ident.cmi parsing/longident.cmi \ - typing/outcometree.cmi typing/path.cmi typing/types.cmi -typing/stypes.cmi: parsing/location.cmi typing/typedtree.cmi -typing/subst.cmi: typing/ident.cmi typing/path.cmi typing/types.cmi -typing/typeclass.cmi: parsing/asttypes.cmi typing/ctype.cmi typing/env.cmi \ - typing/ident.cmi parsing/location.cmi parsing/longident.cmi \ - parsing/parsetree.cmi typing/typedtree.cmi typing/types.cmi -typing/typecore.cmi: parsing/asttypes.cmi typing/env.cmi typing/ident.cmi \ - parsing/location.cmi parsing/longident.cmi parsing/parsetree.cmi \ - typing/path.cmi typing/typedtree.cmi typing/types.cmi -typing/typedecl.cmi: typing/env.cmi typing/ident.cmi parsing/location.cmi \ - parsing/longident.cmi parsing/parsetree.cmi typing/path.cmi \ - typing/types.cmi -typing/typedtree.cmi: parsing/asttypes.cmi typing/env.cmi typing/ident.cmi \ - parsing/location.cmi typing/path.cmi typing/primitive.cmi \ - typing/types.cmi -typing/typemod.cmi: typing/env.cmi typing/ident.cmi typing/includemod.cmi \ - parsing/location.cmi parsing/longident.cmi parsing/parsetree.cmi \ - typing/typedtree.cmi typing/types.cmi -typing/types.cmi: parsing/asttypes.cmi typing/ident.cmi typing/path.cmi \ - typing/primitive.cmi -typing/typetexp.cmi: typing/env.cmi parsing/location.cmi \ - parsing/longident.cmi parsing/parsetree.cmi typing/path.cmi \ - typing/types.cmi -typing/btype.cmo: utils/misc.cmi typing/path.cmi typing/types.cmi \ - typing/btype.cmi -typing/btype.cmx: utils/misc.cmx typing/path.cmx typing/types.cmx \ - typing/btype.cmi -typing/ctype.cmo: parsing/asttypes.cmi typing/btype.cmi utils/clflags.cmo \ - typing/env.cmi typing/ident.cmi parsing/longident.cmi utils/misc.cmi \ - typing/path.cmi typing/subst.cmi typing/types.cmi typing/ctype.cmi -typing/ctype.cmx: parsing/asttypes.cmi typing/btype.cmx utils/clflags.cmx \ - typing/env.cmx typing/ident.cmx parsing/longident.cmx utils/misc.cmx \ - typing/path.cmx typing/subst.cmx typing/types.cmx typing/ctype.cmi -typing/datarepr.cmo: parsing/asttypes.cmi utils/misc.cmi typing/predef.cmi \ - typing/types.cmi typing/datarepr.cmi -typing/datarepr.cmx: parsing/asttypes.cmi utils/misc.cmx typing/predef.cmx \ - typing/types.cmx typing/datarepr.cmi -typing/env.cmo: parsing/asttypes.cmi typing/btype.cmi utils/config.cmi \ - utils/consistbl.cmi typing/datarepr.cmi typing/ident.cmi \ - parsing/longident.cmi utils/misc.cmi typing/path.cmi typing/predef.cmi \ - typing/subst.cmi utils/tbl.cmi typing/types.cmi typing/env.cmi -typing/env.cmx: parsing/asttypes.cmi typing/btype.cmx utils/config.cmx \ - utils/consistbl.cmx typing/datarepr.cmx typing/ident.cmx \ - parsing/longident.cmx utils/misc.cmx typing/path.cmx typing/predef.cmx \ - typing/subst.cmx utils/tbl.cmx typing/types.cmx typing/env.cmi -typing/ident.cmo: typing/ident.cmi -typing/ident.cmx: typing/ident.cmi -typing/includeclass.cmo: typing/ctype.cmi typing/printtyp.cmi \ - typing/types.cmi typing/includeclass.cmi -typing/includeclass.cmx: typing/ctype.cmx typing/printtyp.cmx \ - typing/types.cmx typing/includeclass.cmi -typing/includecore.cmo: parsing/asttypes.cmi typing/btype.cmi \ - typing/ctype.cmi utils/misc.cmi typing/path.cmi typing/predef.cmi \ - typing/typedtree.cmi typing/types.cmi typing/includecore.cmi -typing/includecore.cmx: parsing/asttypes.cmi typing/btype.cmx \ - typing/ctype.cmx utils/misc.cmx typing/path.cmx typing/predef.cmx \ - typing/typedtree.cmx typing/types.cmx typing/includecore.cmi -typing/includemod.cmo: typing/ctype.cmi typing/env.cmi typing/ident.cmi \ - typing/includeclass.cmi typing/includecore.cmi utils/misc.cmi \ - typing/mtype.cmi typing/path.cmi typing/printtyp.cmi typing/subst.cmi \ - utils/tbl.cmi typing/typedtree.cmi typing/types.cmi typing/includemod.cmi -typing/includemod.cmx: typing/ctype.cmx typing/env.cmx typing/ident.cmx \ - typing/includeclass.cmx typing/includecore.cmx utils/misc.cmx \ - typing/mtype.cmx typing/path.cmx typing/printtyp.cmx typing/subst.cmx \ - utils/tbl.cmx typing/typedtree.cmx typing/types.cmx typing/includemod.cmi -typing/mtype.cmo: typing/btype.cmi typing/ctype.cmi typing/env.cmi \ - typing/ident.cmi typing/path.cmi typing/types.cmi typing/mtype.cmi -typing/mtype.cmx: typing/btype.cmx typing/ctype.cmx typing/env.cmx \ - typing/ident.cmx typing/path.cmx typing/types.cmx typing/mtype.cmi -typing/oprint.cmo: parsing/asttypes.cmi typing/outcometree.cmi \ - typing/oprint.cmi -typing/oprint.cmx: parsing/asttypes.cmi typing/outcometree.cmi \ - typing/oprint.cmi -typing/parmatch.cmo: parsing/asttypes.cmi typing/btype.cmi typing/ctype.cmi \ - typing/datarepr.cmi typing/env.cmi typing/ident.cmi parsing/location.cmi \ - utils/misc.cmi typing/path.cmi typing/predef.cmi typing/typedtree.cmi \ - typing/types.cmi utils/warnings.cmi typing/parmatch.cmi -typing/parmatch.cmx: parsing/asttypes.cmi typing/btype.cmx typing/ctype.cmx \ - typing/datarepr.cmx typing/env.cmx typing/ident.cmx parsing/location.cmx \ - utils/misc.cmx typing/path.cmx typing/predef.cmx typing/typedtree.cmx \ - typing/types.cmx utils/warnings.cmx typing/parmatch.cmi -typing/path.cmo: typing/ident.cmi typing/path.cmi -typing/path.cmx: typing/ident.cmx typing/path.cmi -typing/predef.cmo: parsing/asttypes.cmi typing/btype.cmi typing/ident.cmi \ - typing/path.cmi typing/types.cmi typing/predef.cmi -typing/predef.cmx: parsing/asttypes.cmi typing/btype.cmx typing/ident.cmx \ - typing/path.cmx typing/types.cmx typing/predef.cmi -typing/primitive.cmo: utils/misc.cmi typing/primitive.cmi -typing/primitive.cmx: utils/misc.cmx typing/primitive.cmi -typing/printtyp.cmo: parsing/asttypes.cmi typing/btype.cmi utils/clflags.cmo \ - typing/ctype.cmi typing/env.cmi typing/ident.cmi parsing/longident.cmi \ - utils/misc.cmi typing/oprint.cmi typing/outcometree.cmi typing/path.cmi \ - typing/predef.cmi typing/primitive.cmi typing/types.cmi \ - typing/printtyp.cmi -typing/printtyp.cmx: parsing/asttypes.cmi typing/btype.cmx utils/clflags.cmx \ - typing/ctype.cmx typing/env.cmx typing/ident.cmx parsing/longident.cmx \ - utils/misc.cmx typing/oprint.cmx typing/outcometree.cmi typing/path.cmx \ - typing/predef.cmx typing/primitive.cmx typing/types.cmx \ - typing/printtyp.cmi -typing/stypes.cmo: utils/clflags.cmo parsing/location.cmi typing/printtyp.cmi \ - typing/typedtree.cmi typing/stypes.cmi -typing/stypes.cmx: utils/clflags.cmx parsing/location.cmx typing/printtyp.cmx \ - typing/typedtree.cmx typing/stypes.cmi -typing/subst.cmo: typing/btype.cmi typing/ident.cmi utils/misc.cmi \ - typing/path.cmi utils/tbl.cmi typing/types.cmi typing/subst.cmi -typing/subst.cmx: typing/btype.cmx typing/ident.cmx utils/misc.cmx \ - typing/path.cmx utils/tbl.cmx typing/types.cmx typing/subst.cmi -typing/typeclass.cmo: parsing/asttypes.cmi typing/btype.cmi utils/clflags.cmo \ - typing/ctype.cmi typing/env.cmi typing/ident.cmi typing/includeclass.cmi \ - parsing/location.cmi parsing/longident.cmi utils/misc.cmi \ - typing/parmatch.cmi parsing/parsetree.cmi typing/path.cmi \ - typing/predef.cmi typing/printtyp.cmi typing/stypes.cmi \ - typing/typecore.cmi typing/typedecl.cmi typing/typedtree.cmi \ - typing/types.cmi typing/typetexp.cmi utils/warnings.cmi \ - typing/typeclass.cmi -typing/typeclass.cmx: parsing/asttypes.cmi typing/btype.cmx utils/clflags.cmx \ - typing/ctype.cmx typing/env.cmx typing/ident.cmx typing/includeclass.cmx \ - parsing/location.cmx parsing/longident.cmx utils/misc.cmx \ - typing/parmatch.cmx parsing/parsetree.cmi typing/path.cmx \ - typing/predef.cmx typing/printtyp.cmx typing/stypes.cmx \ - typing/typecore.cmx typing/typedecl.cmx typing/typedtree.cmx \ - typing/types.cmx typing/typetexp.cmx utils/warnings.cmx \ - typing/typeclass.cmi -typing/typecore.cmo: parsing/asttypes.cmi typing/btype.cmi utils/clflags.cmo \ - typing/ctype.cmi typing/env.cmi typing/ident.cmi parsing/location.cmi \ - parsing/longident.cmi utils/misc.cmi typing/parmatch.cmi \ - parsing/parsetree.cmi typing/path.cmi typing/predef.cmi \ - typing/primitive.cmi typing/printtyp.cmi typing/stypes.cmi \ - typing/typedtree.cmi typing/types.cmi typing/typetexp.cmi \ - utils/warnings.cmi typing/typecore.cmi -typing/typecore.cmx: parsing/asttypes.cmi typing/btype.cmx utils/clflags.cmx \ - typing/ctype.cmx typing/env.cmx typing/ident.cmx parsing/location.cmx \ - parsing/longident.cmx utils/misc.cmx typing/parmatch.cmx \ - parsing/parsetree.cmi typing/path.cmx typing/predef.cmx \ - typing/primitive.cmx typing/printtyp.cmx typing/stypes.cmx \ - typing/typedtree.cmx typing/types.cmx typing/typetexp.cmx \ - utils/warnings.cmx typing/typecore.cmi -typing/typedecl.cmo: parsing/asttypes.cmi typing/btype.cmi utils/clflags.cmo \ - utils/config.cmi typing/ctype.cmi typing/env.cmi typing/ident.cmi \ - typing/includecore.cmi parsing/location.cmi parsing/longident.cmi \ - utils/misc.cmi parsing/parsetree.cmi typing/path.cmi typing/predef.cmi \ - typing/primitive.cmi typing/printtyp.cmi typing/subst.cmi \ - typing/typedtree.cmi typing/types.cmi typing/typetexp.cmi \ - typing/typedecl.cmi -typing/typedecl.cmx: parsing/asttypes.cmi typing/btype.cmx utils/clflags.cmx \ - utils/config.cmx typing/ctype.cmx typing/env.cmx typing/ident.cmx \ - typing/includecore.cmx parsing/location.cmx parsing/longident.cmx \ - utils/misc.cmx parsing/parsetree.cmi typing/path.cmx typing/predef.cmx \ - typing/primitive.cmx typing/printtyp.cmx typing/subst.cmx \ - typing/typedtree.cmx typing/types.cmx typing/typetexp.cmx \ - typing/typedecl.cmi -typing/typedtree.cmo: parsing/asttypes.cmi typing/env.cmi typing/ident.cmi \ - parsing/location.cmi utils/misc.cmi typing/path.cmi typing/primitive.cmi \ - typing/types.cmi typing/typedtree.cmi -typing/typedtree.cmx: parsing/asttypes.cmi typing/env.cmx typing/ident.cmx \ - parsing/location.cmx utils/misc.cmx typing/path.cmx typing/primitive.cmx \ - typing/types.cmx typing/typedtree.cmi -typing/typemod.cmo: utils/clflags.cmo utils/config.cmi typing/ctype.cmi \ - typing/env.cmi typing/ident.cmi typing/includemod.cmi \ - parsing/location.cmi parsing/longident.cmi utils/misc.cmi \ - typing/mtype.cmi parsing/parsetree.cmi typing/path.cmi \ - typing/printtyp.cmi typing/stypes.cmi typing/subst.cmi \ - typing/typeclass.cmi typing/typecore.cmi typing/typedecl.cmi \ - typing/typedtree.cmi typing/types.cmi typing/typemod.cmi -typing/typemod.cmx: utils/clflags.cmx utils/config.cmx typing/ctype.cmx \ - typing/env.cmx typing/ident.cmx typing/includemod.cmx \ - parsing/location.cmx parsing/longident.cmx utils/misc.cmx \ - typing/mtype.cmx parsing/parsetree.cmi typing/path.cmx \ - typing/printtyp.cmx typing/stypes.cmx typing/subst.cmx \ - typing/typeclass.cmx typing/typecore.cmx typing/typedecl.cmx \ - typing/typedtree.cmx typing/types.cmx typing/typemod.cmi -typing/types.cmo: parsing/asttypes.cmi typing/ident.cmi utils/misc.cmi \ - typing/path.cmi typing/primitive.cmi typing/types.cmi -typing/types.cmx: parsing/asttypes.cmi typing/ident.cmx utils/misc.cmx \ - typing/path.cmx typing/primitive.cmx typing/types.cmi -typing/typetexp.cmo: typing/btype.cmi typing/ctype.cmi typing/env.cmi \ - parsing/location.cmi parsing/longident.cmi utils/misc.cmi \ - parsing/parsetree.cmi typing/path.cmi typing/printtyp.cmi utils/tbl.cmi \ - typing/types.cmi utils/warnings.cmi typing/typetexp.cmi -typing/typetexp.cmx: typing/btype.cmx typing/ctype.cmx typing/env.cmx \ - parsing/location.cmx parsing/longident.cmx utils/misc.cmx \ - parsing/parsetree.cmi typing/path.cmx typing/printtyp.cmx utils/tbl.cmx \ - typing/types.cmx utils/warnings.cmx typing/typetexp.cmi -bytecomp/bytegen.cmi: bytecomp/instruct.cmi bytecomp/lambda.cmi -bytecomp/bytelink.cmi: bytecomp/emitcode.cmi bytecomp/symtable.cmi -bytecomp/bytepackager.cmi: typing/ident.cmi -bytecomp/emitcode.cmi: typing/ident.cmi bytecomp/instruct.cmi \ - bytecomp/lambda.cmi -bytecomp/instruct.cmi: typing/env.cmi typing/ident.cmi bytecomp/lambda.cmi \ - typing/types.cmi -bytecomp/lambda.cmi: parsing/asttypes.cmi typing/env.cmi typing/ident.cmi \ - typing/path.cmi typing/primitive.cmi typing/types.cmi -bytecomp/matching.cmi: typing/ident.cmi bytecomp/lambda.cmi \ - parsing/location.cmi typing/typedtree.cmi -bytecomp/printinstr.cmi: bytecomp/instruct.cmi -bytecomp/printlambda.cmi: bytecomp/lambda.cmi -bytecomp/simplif.cmi: bytecomp/lambda.cmi -bytecomp/symtable.cmi: bytecomp/emitcode.cmi typing/ident.cmi -bytecomp/translclass.cmi: typing/ident.cmi bytecomp/lambda.cmi \ - parsing/location.cmi typing/typedtree.cmi -bytecomp/translcore.cmi: parsing/asttypes.cmi typing/ident.cmi \ - bytecomp/lambda.cmi parsing/location.cmi typing/path.cmi \ - typing/primitive.cmi typing/typedtree.cmi typing/types.cmi -bytecomp/translmod.cmi: typing/ident.cmi bytecomp/lambda.cmi \ - parsing/location.cmi typing/typedtree.cmi -bytecomp/translobj.cmi: typing/ident.cmi bytecomp/lambda.cmi -bytecomp/typeopt.cmi: bytecomp/lambda.cmi typing/path.cmi \ - typing/typedtree.cmi -bytecomp/bytegen.cmo: parsing/asttypes.cmi utils/config.cmi typing/ident.cmi \ - bytecomp/instruct.cmi bytecomp/lambda.cmi utils/misc.cmi \ - typing/primitive.cmi bytecomp/switch.cmi typing/types.cmi \ - bytecomp/bytegen.cmi -bytecomp/bytegen.cmx: parsing/asttypes.cmi utils/config.cmx typing/ident.cmx \ - bytecomp/instruct.cmx bytecomp/lambda.cmx utils/misc.cmx \ - typing/primitive.cmx bytecomp/switch.cmx typing/types.cmx \ - bytecomp/bytegen.cmi -bytecomp/bytelibrarian.cmo: bytecomp/bytelink.cmi utils/clflags.cmo \ - utils/config.cmi bytecomp/emitcode.cmi utils/misc.cmi \ - bytecomp/bytelibrarian.cmi -bytecomp/bytelibrarian.cmx: bytecomp/bytelink.cmx utils/clflags.cmx \ - utils/config.cmx bytecomp/emitcode.cmx utils/misc.cmx \ - bytecomp/bytelibrarian.cmi -bytecomp/bytelink.cmo: bytecomp/bytesections.cmi utils/ccomp.cmi \ - utils/clflags.cmo utils/config.cmi utils/consistbl.cmi bytecomp/dll.cmi \ - bytecomp/emitcode.cmi typing/ident.cmi bytecomp/instruct.cmi \ - utils/misc.cmi bytecomp/opcodes.cmo bytecomp/symtable.cmi \ - bytecomp/bytelink.cmi -bytecomp/bytelink.cmx: bytecomp/bytesections.cmx utils/ccomp.cmx \ - utils/clflags.cmx utils/config.cmx utils/consistbl.cmx bytecomp/dll.cmx \ - bytecomp/emitcode.cmx typing/ident.cmx bytecomp/instruct.cmx \ - utils/misc.cmx bytecomp/opcodes.cmx bytecomp/symtable.cmx \ - bytecomp/bytelink.cmi -bytecomp/bytepackager.cmo: bytecomp/bytegen.cmi bytecomp/bytelink.cmi \ - utils/clflags.cmo utils/config.cmi bytecomp/emitcode.cmi typing/env.cmi \ - typing/ident.cmi bytecomp/instruct.cmi utils/misc.cmi \ - bytecomp/translmod.cmi typing/typemod.cmi bytecomp/bytepackager.cmi -bytecomp/bytepackager.cmx: bytecomp/bytegen.cmx bytecomp/bytelink.cmx \ - utils/clflags.cmx utils/config.cmx bytecomp/emitcode.cmx typing/env.cmx \ - typing/ident.cmx bytecomp/instruct.cmx utils/misc.cmx \ - bytecomp/translmod.cmx typing/typemod.cmx bytecomp/bytepackager.cmi -bytecomp/bytesections.cmo: utils/config.cmi bytecomp/bytesections.cmi -bytecomp/bytesections.cmx: utils/config.cmx bytecomp/bytesections.cmi -bytecomp/dll.cmo: utils/config.cmi utils/misc.cmi bytecomp/dll.cmi -bytecomp/dll.cmx: utils/config.cmx utils/misc.cmx bytecomp/dll.cmi -bytecomp/emitcode.cmo: parsing/asttypes.cmi typing/btype.cmi \ - utils/clflags.cmo utils/config.cmi typing/env.cmi typing/ident.cmi \ - bytecomp/instruct.cmi bytecomp/lambda.cmi bytecomp/meta.cmi \ - utils/misc.cmi bytecomp/opcodes.cmo bytecomp/translmod.cmi \ - bytecomp/emitcode.cmi -bytecomp/emitcode.cmx: parsing/asttypes.cmi typing/btype.cmx \ - utils/clflags.cmx utils/config.cmx typing/env.cmx typing/ident.cmx \ - bytecomp/instruct.cmx bytecomp/lambda.cmx bytecomp/meta.cmx \ - utils/misc.cmx bytecomp/opcodes.cmx bytecomp/translmod.cmx \ - bytecomp/emitcode.cmi -bytecomp/instruct.cmo: typing/env.cmi typing/ident.cmi bytecomp/lambda.cmi \ - typing/types.cmi bytecomp/instruct.cmi -bytecomp/instruct.cmx: typing/env.cmx typing/ident.cmx bytecomp/lambda.cmx \ - typing/types.cmx bytecomp/instruct.cmi -bytecomp/lambda.cmo: parsing/asttypes.cmi typing/env.cmi typing/ident.cmi \ - utils/misc.cmi typing/path.cmi typing/primitive.cmi typing/types.cmi \ - bytecomp/lambda.cmi -bytecomp/lambda.cmx: parsing/asttypes.cmi typing/env.cmx typing/ident.cmx \ - utils/misc.cmx typing/path.cmx typing/primitive.cmx typing/types.cmx \ - bytecomp/lambda.cmi -bytecomp/matching.cmo: parsing/asttypes.cmi typing/btype.cmi typing/ident.cmi \ - bytecomp/lambda.cmi parsing/location.cmi utils/misc.cmi \ - typing/parmatch.cmi typing/predef.cmi typing/primitive.cmi \ - bytecomp/printlambda.cmi bytecomp/switch.cmi typing/typedtree.cmi \ - bytecomp/typeopt.cmi typing/types.cmi bytecomp/matching.cmi -bytecomp/matching.cmx: parsing/asttypes.cmi typing/btype.cmx typing/ident.cmx \ - bytecomp/lambda.cmx parsing/location.cmx utils/misc.cmx \ - typing/parmatch.cmx typing/predef.cmx typing/primitive.cmx \ - bytecomp/printlambda.cmx bytecomp/switch.cmx typing/typedtree.cmx \ - bytecomp/typeopt.cmx typing/types.cmx bytecomp/matching.cmi -bytecomp/meta.cmo: bytecomp/meta.cmi -bytecomp/meta.cmx: bytecomp/meta.cmi -bytecomp/printinstr.cmo: typing/ident.cmi bytecomp/instruct.cmi \ - bytecomp/lambda.cmi bytecomp/printlambda.cmi bytecomp/printinstr.cmi -bytecomp/printinstr.cmx: typing/ident.cmx bytecomp/instruct.cmx \ - bytecomp/lambda.cmx bytecomp/printlambda.cmx bytecomp/printinstr.cmi -bytecomp/printlambda.cmo: parsing/asttypes.cmi typing/ident.cmi \ - bytecomp/lambda.cmi typing/primitive.cmi typing/types.cmi \ - bytecomp/printlambda.cmi -bytecomp/printlambda.cmx: parsing/asttypes.cmi typing/ident.cmx \ - bytecomp/lambda.cmx typing/primitive.cmx typing/types.cmx \ - bytecomp/printlambda.cmi -bytecomp/runtimedef.cmo: bytecomp/runtimedef.cmi -bytecomp/runtimedef.cmx: bytecomp/runtimedef.cmi -bytecomp/simplif.cmo: parsing/asttypes.cmi utils/clflags.cmo typing/ident.cmi \ - bytecomp/lambda.cmi bytecomp/simplif.cmi -bytecomp/simplif.cmx: parsing/asttypes.cmi utils/clflags.cmx typing/ident.cmx \ - bytecomp/lambda.cmx bytecomp/simplif.cmi -bytecomp/switch.cmo: bytecomp/switch.cmi -bytecomp/switch.cmx: bytecomp/switch.cmi -bytecomp/symtable.cmo: parsing/asttypes.cmi bytecomp/bytesections.cmi \ - utils/clflags.cmo bytecomp/dll.cmi bytecomp/emitcode.cmi typing/ident.cmi \ - bytecomp/lambda.cmi bytecomp/meta.cmi utils/misc.cmi typing/predef.cmi \ - bytecomp/runtimedef.cmi utils/tbl.cmi bytecomp/symtable.cmi -bytecomp/symtable.cmx: parsing/asttypes.cmi bytecomp/bytesections.cmx \ - utils/clflags.cmx bytecomp/dll.cmx bytecomp/emitcode.cmx typing/ident.cmx \ - bytecomp/lambda.cmx bytecomp/meta.cmx utils/misc.cmx typing/predef.cmx \ - bytecomp/runtimedef.cmx utils/tbl.cmx bytecomp/symtable.cmi -bytecomp/translclass.cmo: parsing/asttypes.cmi utils/clflags.cmo \ - typing/ident.cmi bytecomp/lambda.cmi parsing/location.cmi \ - bytecomp/matching.cmi utils/misc.cmi bytecomp/translcore.cmi \ - bytecomp/translobj.cmi typing/typedtree.cmi bytecomp/typeopt.cmi \ - typing/types.cmi bytecomp/translclass.cmi -bytecomp/translclass.cmx: parsing/asttypes.cmi utils/clflags.cmx \ - typing/ident.cmx bytecomp/lambda.cmx parsing/location.cmx \ - bytecomp/matching.cmx utils/misc.cmx bytecomp/translcore.cmx \ - bytecomp/translobj.cmx typing/typedtree.cmx bytecomp/typeopt.cmx \ - typing/types.cmx bytecomp/translclass.cmi -bytecomp/translcore.cmo: parsing/asttypes.cmi typing/btype.cmi \ - utils/clflags.cmo utils/config.cmi typing/env.cmi typing/ident.cmi \ - bytecomp/lambda.cmi parsing/location.cmi bytecomp/matching.cmi \ - utils/misc.cmi typing/path.cmi typing/predef.cmi typing/primitive.cmi \ - bytecomp/translobj.cmi typing/typedtree.cmi bytecomp/typeopt.cmi \ - typing/types.cmi bytecomp/translcore.cmi -bytecomp/translcore.cmx: parsing/asttypes.cmi typing/btype.cmx \ - utils/clflags.cmx utils/config.cmx typing/env.cmx typing/ident.cmx \ - bytecomp/lambda.cmx parsing/location.cmx bytecomp/matching.cmx \ - utils/misc.cmx typing/path.cmx typing/predef.cmx typing/primitive.cmx \ - bytecomp/translobj.cmx typing/typedtree.cmx bytecomp/typeopt.cmx \ - typing/types.cmx bytecomp/translcore.cmi -bytecomp/translmod.cmo: parsing/asttypes.cmi utils/config.cmi \ - typing/ctype.cmi typing/env.cmi typing/ident.cmi bytecomp/lambda.cmi \ - parsing/location.cmi utils/misc.cmi typing/mtype.cmi typing/path.cmi \ - typing/predef.cmi typing/primitive.cmi typing/printtyp.cmi \ - bytecomp/translclass.cmi bytecomp/translcore.cmi bytecomp/translobj.cmi \ - typing/typedtree.cmi typing/types.cmi bytecomp/translmod.cmi -bytecomp/translmod.cmx: parsing/asttypes.cmi utils/config.cmx \ - typing/ctype.cmx typing/env.cmx typing/ident.cmx bytecomp/lambda.cmx \ - parsing/location.cmx utils/misc.cmx typing/mtype.cmx typing/path.cmx \ - typing/predef.cmx typing/primitive.cmx typing/printtyp.cmx \ - bytecomp/translclass.cmx bytecomp/translcore.cmx bytecomp/translobj.cmx \ - typing/typedtree.cmx typing/types.cmx bytecomp/translmod.cmi -bytecomp/translobj.cmo: parsing/asttypes.cmi typing/env.cmi typing/ident.cmi \ - bytecomp/lambda.cmi parsing/longident.cmi utils/misc.cmi \ - bytecomp/translobj.cmi -bytecomp/translobj.cmx: parsing/asttypes.cmi typing/env.cmx typing/ident.cmx \ - bytecomp/lambda.cmx parsing/longident.cmx utils/misc.cmx \ - bytecomp/translobj.cmi -bytecomp/typeopt.cmo: parsing/asttypes.cmi typing/ctype.cmi typing/env.cmi \ - typing/ident.cmi bytecomp/lambda.cmi utils/misc.cmi typing/path.cmi \ - typing/predef.cmi typing/primitive.cmi typing/typedtree.cmi \ - typing/types.cmi bytecomp/typeopt.cmi -bytecomp/typeopt.cmx: parsing/asttypes.cmi typing/ctype.cmx typing/env.cmx \ - typing/ident.cmx bytecomp/lambda.cmx utils/misc.cmx typing/path.cmx \ - typing/predef.cmx typing/primitive.cmx typing/typedtree.cmx \ - typing/types.cmx bytecomp/typeopt.cmi -asmcomp/asmgen.cmi: asmcomp/cmm.cmi bytecomp/lambda.cmi -asmcomp/asmlink.cmi: asmcomp/compilenv.cmi -asmcomp/clambda.cmi: parsing/asttypes.cmi typing/ident.cmi \ - bytecomp/lambda.cmi -asmcomp/closure.cmi: asmcomp/clambda.cmi bytecomp/lambda.cmi -asmcomp/cmm.cmi: typing/ident.cmi -asmcomp/cmmgen.cmi: asmcomp/clambda.cmi asmcomp/cmm.cmi -asmcomp/codegen.cmi: asmcomp/cmm.cmi -asmcomp/comballoc.cmi: asmcomp/mach.cmi -asmcomp/compilenv.cmi: asmcomp/clambda.cmi typing/ident.cmi -asmcomp/emit.cmi: asmcomp/cmm.cmi asmcomp/linearize.cmi -asmcomp/interf.cmi: asmcomp/mach.cmi -asmcomp/linearize.cmi: asmcomp/mach.cmi asmcomp/reg.cmi -asmcomp/liveness.cmi: asmcomp/mach.cmi -asmcomp/mach.cmi: asmcomp/arch.cmo asmcomp/cmm.cmi asmcomp/reg.cmi -asmcomp/printcmm.cmi: asmcomp/cmm.cmi -asmcomp/printlinear.cmi: asmcomp/linearize.cmi -asmcomp/printmach.cmi: asmcomp/mach.cmi asmcomp/reg.cmi -asmcomp/proc.cmi: asmcomp/mach.cmi asmcomp/reg.cmi -asmcomp/reg.cmi: asmcomp/cmm.cmi -asmcomp/reload.cmi: asmcomp/mach.cmi -asmcomp/reloadgen.cmi: asmcomp/mach.cmi asmcomp/reg.cmi -asmcomp/schedgen.cmi: asmcomp/linearize.cmi asmcomp/mach.cmi -asmcomp/scheduling.cmi: asmcomp/linearize.cmi -asmcomp/selectgen.cmi: asmcomp/arch.cmo asmcomp/cmm.cmi typing/ident.cmi \ - asmcomp/mach.cmi asmcomp/reg.cmi utils/tbl.cmi -asmcomp/selection.cmi: asmcomp/cmm.cmi asmcomp/mach.cmi -asmcomp/spill.cmi: asmcomp/mach.cmi -asmcomp/split.cmi: asmcomp/mach.cmi -asmcomp/arch.cmo: utils/config.cmi utils/misc.cmi -asmcomp/arch.cmx: utils/config.cmx utils/misc.cmx -asmcomp/asmgen.cmo: utils/clflags.cmo asmcomp/closure.cmi asmcomp/cmm.cmi \ - asmcomp/cmmgen.cmi asmcomp/coloring.cmi asmcomp/comballoc.cmi \ - utils/config.cmi asmcomp/emit.cmi asmcomp/emitaux.cmi asmcomp/interf.cmi \ - asmcomp/linearize.cmi asmcomp/liveness.cmi asmcomp/mach.cmi \ - utils/misc.cmi asmcomp/printcmm.cmi asmcomp/printlinear.cmi \ - asmcomp/printmach.cmi asmcomp/proc.cmi asmcomp/reg.cmi asmcomp/reload.cmi \ - asmcomp/scheduling.cmi asmcomp/selection.cmi asmcomp/spill.cmi \ - asmcomp/split.cmi asmcomp/asmgen.cmi -asmcomp/asmgen.cmx: utils/clflags.cmx asmcomp/closure.cmx asmcomp/cmm.cmx \ - asmcomp/cmmgen.cmx asmcomp/coloring.cmx asmcomp/comballoc.cmx \ - utils/config.cmx asmcomp/emit.cmx asmcomp/emitaux.cmx asmcomp/interf.cmx \ - asmcomp/linearize.cmx asmcomp/liveness.cmx asmcomp/mach.cmx \ - utils/misc.cmx asmcomp/printcmm.cmx asmcomp/printlinear.cmx \ - asmcomp/printmach.cmx asmcomp/proc.cmx asmcomp/reg.cmx asmcomp/reload.cmx \ - asmcomp/scheduling.cmx asmcomp/selection.cmx asmcomp/spill.cmx \ - asmcomp/split.cmx asmcomp/asmgen.cmi -asmcomp/asmlibrarian.cmo: asmcomp/asmlink.cmi utils/ccomp.cmi \ - asmcomp/clambda.cmi utils/clflags.cmo asmcomp/compilenv.cmi \ - utils/config.cmi utils/misc.cmi asmcomp/asmlibrarian.cmi -asmcomp/asmlibrarian.cmx: asmcomp/asmlink.cmx utils/ccomp.cmx \ - asmcomp/clambda.cmx utils/clflags.cmx asmcomp/compilenv.cmx \ - utils/config.cmx utils/misc.cmx asmcomp/asmlibrarian.cmi -asmcomp/asmlink.cmo: asmcomp/asmgen.cmi utils/ccomp.cmi utils/clflags.cmo \ - asmcomp/cmmgen.cmi asmcomp/compilenv.cmi utils/config.cmi \ - utils/consistbl.cmi asmcomp/emit.cmi asmcomp/emitaux.cmi \ - parsing/location.cmi utils/misc.cmi asmcomp/proc.cmi \ - bytecomp/runtimedef.cmi asmcomp/asmlink.cmi -asmcomp/asmlink.cmx: asmcomp/asmgen.cmx utils/ccomp.cmx utils/clflags.cmx \ - asmcomp/cmmgen.cmx asmcomp/compilenv.cmx utils/config.cmx \ - utils/consistbl.cmx asmcomp/emit.cmx asmcomp/emitaux.cmx \ - parsing/location.cmx utils/misc.cmx asmcomp/proc.cmx \ - bytecomp/runtimedef.cmx asmcomp/asmlink.cmi -asmcomp/asmpackager.cmo: asmcomp/asmgen.cmi asmcomp/asmlink.cmi \ - utils/ccomp.cmi asmcomp/clambda.cmi asmcomp/compilenv.cmi \ - utils/config.cmi typing/env.cmi typing/ident.cmi bytecomp/lambda.cmi \ - parsing/location.cmi utils/misc.cmi utils/tbl.cmi bytecomp/translmod.cmi \ - typing/typemod.cmi asmcomp/asmpackager.cmi -asmcomp/asmpackager.cmx: asmcomp/asmgen.cmx asmcomp/asmlink.cmx \ - utils/ccomp.cmx asmcomp/clambda.cmx asmcomp/compilenv.cmx \ - utils/config.cmx typing/env.cmx typing/ident.cmx bytecomp/lambda.cmx \ - parsing/location.cmx utils/misc.cmx utils/tbl.cmx bytecomp/translmod.cmx \ - typing/typemod.cmx asmcomp/asmpackager.cmi -asmcomp/clambda.cmo: parsing/asttypes.cmi typing/ident.cmi \ - bytecomp/lambda.cmi asmcomp/clambda.cmi -asmcomp/clambda.cmx: parsing/asttypes.cmi typing/ident.cmx \ - bytecomp/lambda.cmx asmcomp/clambda.cmi -asmcomp/closure.cmo: parsing/asttypes.cmi asmcomp/clambda.cmi \ - utils/clflags.cmo asmcomp/compilenv.cmi typing/ident.cmi \ - bytecomp/lambda.cmi utils/misc.cmi typing/primitive.cmi \ - bytecomp/switch.cmi utils/tbl.cmi asmcomp/closure.cmi -asmcomp/closure.cmx: parsing/asttypes.cmi asmcomp/clambda.cmx \ - utils/clflags.cmx asmcomp/compilenv.cmx typing/ident.cmx \ - bytecomp/lambda.cmx utils/misc.cmx typing/primitive.cmx \ - bytecomp/switch.cmx utils/tbl.cmx asmcomp/closure.cmi -asmcomp/cmm.cmo: asmcomp/arch.cmo typing/ident.cmi asmcomp/cmm.cmi -asmcomp/cmm.cmx: asmcomp/arch.cmx typing/ident.cmx asmcomp/cmm.cmi -asmcomp/cmmgen.cmo: asmcomp/arch.cmo parsing/asttypes.cmi asmcomp/clambda.cmi \ - utils/clflags.cmo asmcomp/cmm.cmi asmcomp/compilenv.cmi utils/config.cmi \ - typing/ident.cmi bytecomp/lambda.cmi utils/misc.cmi typing/primitive.cmi \ - asmcomp/proc.cmi bytecomp/switch.cmi typing/types.cmi asmcomp/cmmgen.cmi -asmcomp/cmmgen.cmx: asmcomp/arch.cmx parsing/asttypes.cmi asmcomp/clambda.cmx \ - utils/clflags.cmx asmcomp/cmm.cmx asmcomp/compilenv.cmx utils/config.cmx \ - typing/ident.cmx bytecomp/lambda.cmx utils/misc.cmx typing/primitive.cmx \ - asmcomp/proc.cmx bytecomp/switch.cmx typing/types.cmx asmcomp/cmmgen.cmi -asmcomp/codegen.cmo: asmcomp/cmm.cmi asmcomp/coloring.cmi asmcomp/emit.cmi \ - asmcomp/interf.cmi asmcomp/linearize.cmi asmcomp/liveness.cmi \ - asmcomp/printcmm.cmi asmcomp/printlinear.cmi asmcomp/printmach.cmi \ - asmcomp/reg.cmi asmcomp/reload.cmi asmcomp/spill.cmi asmcomp/split.cmi \ - asmcomp/codegen.cmi -asmcomp/codegen.cmx: asmcomp/cmm.cmx asmcomp/coloring.cmx asmcomp/emit.cmx \ - asmcomp/interf.cmx asmcomp/linearize.cmx asmcomp/liveness.cmx \ - asmcomp/printcmm.cmx asmcomp/printlinear.cmx asmcomp/printmach.cmx \ - asmcomp/reg.cmx asmcomp/reload.cmx asmcomp/spill.cmx asmcomp/split.cmx \ - asmcomp/codegen.cmi -asmcomp/coloring.cmo: asmcomp/proc.cmi asmcomp/reg.cmi asmcomp/coloring.cmi -asmcomp/coloring.cmx: asmcomp/proc.cmx asmcomp/reg.cmx asmcomp/coloring.cmi -asmcomp/comballoc.cmo: utils/config.cmi asmcomp/mach.cmi asmcomp/reg.cmi \ - asmcomp/comballoc.cmi -asmcomp/comballoc.cmx: utils/config.cmx asmcomp/mach.cmx asmcomp/reg.cmx \ - asmcomp/comballoc.cmi -asmcomp/compilenv.cmo: asmcomp/clambda.cmi utils/config.cmi typing/env.cmi \ - typing/ident.cmi utils/misc.cmi asmcomp/compilenv.cmi -asmcomp/compilenv.cmx: asmcomp/clambda.cmx utils/config.cmx typing/env.cmx \ - typing/ident.cmx utils/misc.cmx asmcomp/compilenv.cmi -asmcomp/emit.cmo: asmcomp/arch.cmo asmcomp/cmm.cmi asmcomp/compilenv.cmi \ - utils/config.cmi asmcomp/emitaux.cmi asmcomp/linearize.cmi \ - parsing/location.cmi asmcomp/mach.cmi utils/misc.cmi asmcomp/proc.cmi \ - asmcomp/reg.cmi asmcomp/emit.cmi -asmcomp/emit.cmx: asmcomp/arch.cmx asmcomp/cmm.cmx asmcomp/compilenv.cmx \ - utils/config.cmx asmcomp/emitaux.cmx asmcomp/linearize.cmx \ - parsing/location.cmx asmcomp/mach.cmx utils/misc.cmx asmcomp/proc.cmx \ - asmcomp/reg.cmx asmcomp/emit.cmi -asmcomp/emitaux.cmo: asmcomp/emitaux.cmi -asmcomp/emitaux.cmx: asmcomp/emitaux.cmi -asmcomp/interf.cmo: asmcomp/mach.cmi utils/misc.cmi asmcomp/proc.cmi \ - asmcomp/reg.cmi asmcomp/interf.cmi -asmcomp/interf.cmx: asmcomp/mach.cmx utils/misc.cmx asmcomp/proc.cmx \ - asmcomp/reg.cmx asmcomp/interf.cmi -asmcomp/linearize.cmo: asmcomp/cmm.cmi asmcomp/mach.cmi utils/misc.cmi \ - asmcomp/proc.cmi asmcomp/reg.cmi asmcomp/linearize.cmi -asmcomp/linearize.cmx: asmcomp/cmm.cmx asmcomp/mach.cmx utils/misc.cmx \ - asmcomp/proc.cmx asmcomp/reg.cmx asmcomp/linearize.cmi -asmcomp/liveness.cmo: asmcomp/mach.cmi utils/misc.cmi asmcomp/printmach.cmi \ - asmcomp/proc.cmi asmcomp/reg.cmi asmcomp/liveness.cmi -asmcomp/liveness.cmx: asmcomp/mach.cmx utils/misc.cmx asmcomp/printmach.cmx \ - asmcomp/proc.cmx asmcomp/reg.cmx asmcomp/liveness.cmi -asmcomp/mach.cmo: asmcomp/arch.cmo asmcomp/cmm.cmi asmcomp/reg.cmi \ - asmcomp/mach.cmi -asmcomp/mach.cmx: asmcomp/arch.cmx asmcomp/cmm.cmx asmcomp/reg.cmx \ - asmcomp/mach.cmi -asmcomp/printcmm.cmo: asmcomp/cmm.cmi typing/ident.cmi asmcomp/printcmm.cmi -asmcomp/printcmm.cmx: asmcomp/cmm.cmx typing/ident.cmx asmcomp/printcmm.cmi -asmcomp/printlinear.cmo: asmcomp/linearize.cmi asmcomp/mach.cmi \ - asmcomp/printmach.cmi asmcomp/printlinear.cmi -asmcomp/printlinear.cmx: asmcomp/linearize.cmx asmcomp/mach.cmx \ - asmcomp/printmach.cmx asmcomp/printlinear.cmi -asmcomp/printmach.cmo: asmcomp/arch.cmo asmcomp/cmm.cmi asmcomp/mach.cmi \ - asmcomp/printcmm.cmi asmcomp/proc.cmi asmcomp/reg.cmi \ - asmcomp/printmach.cmi -asmcomp/printmach.cmx: asmcomp/arch.cmx asmcomp/cmm.cmx asmcomp/mach.cmx \ - asmcomp/printcmm.cmx asmcomp/proc.cmx asmcomp/reg.cmx \ - asmcomp/printmach.cmi -asmcomp/proc.cmo: asmcomp/arch.cmo utils/ccomp.cmi utils/clflags.cmo \ - asmcomp/cmm.cmi utils/config.cmi asmcomp/mach.cmi utils/misc.cmi \ - asmcomp/reg.cmi asmcomp/proc.cmi -asmcomp/proc.cmx: asmcomp/arch.cmx utils/ccomp.cmx utils/clflags.cmx \ - asmcomp/cmm.cmx utils/config.cmx asmcomp/mach.cmx utils/misc.cmx \ - asmcomp/reg.cmx asmcomp/proc.cmi -asmcomp/reg.cmo: asmcomp/cmm.cmi asmcomp/reg.cmi -asmcomp/reg.cmx: asmcomp/cmm.cmx asmcomp/reg.cmi -asmcomp/reload.cmo: asmcomp/reloadgen.cmi asmcomp/reload.cmi -asmcomp/reload.cmx: asmcomp/reloadgen.cmx asmcomp/reload.cmi -asmcomp/reloadgen.cmo: asmcomp/mach.cmi utils/misc.cmi asmcomp/reg.cmi \ - asmcomp/reloadgen.cmi -asmcomp/reloadgen.cmx: asmcomp/mach.cmx utils/misc.cmx asmcomp/reg.cmx \ - asmcomp/reloadgen.cmi -asmcomp/schedgen.cmo: asmcomp/arch.cmo asmcomp/cmm.cmi asmcomp/linearize.cmi \ - asmcomp/mach.cmi utils/misc.cmi asmcomp/reg.cmi asmcomp/schedgen.cmi -asmcomp/schedgen.cmx: asmcomp/arch.cmx asmcomp/cmm.cmx asmcomp/linearize.cmx \ - asmcomp/mach.cmx utils/misc.cmx asmcomp/reg.cmx asmcomp/schedgen.cmi -asmcomp/scheduling.cmo: asmcomp/arch.cmo asmcomp/mach.cmi \ - asmcomp/schedgen.cmi asmcomp/scheduling.cmi -asmcomp/scheduling.cmx: asmcomp/arch.cmx asmcomp/mach.cmx \ - asmcomp/schedgen.cmx asmcomp/scheduling.cmi -asmcomp/selectgen.cmo: asmcomp/arch.cmo asmcomp/cmm.cmi typing/ident.cmi \ - asmcomp/mach.cmi utils/misc.cmi asmcomp/proc.cmi asmcomp/reg.cmi \ - utils/tbl.cmi asmcomp/selectgen.cmi -asmcomp/selectgen.cmx: asmcomp/arch.cmx asmcomp/cmm.cmx typing/ident.cmx \ - asmcomp/mach.cmx utils/misc.cmx asmcomp/proc.cmx asmcomp/reg.cmx \ - utils/tbl.cmx asmcomp/selectgen.cmi -asmcomp/selection.cmo: asmcomp/arch.cmo asmcomp/cmm.cmi asmcomp/mach.cmi \ - utils/misc.cmi asmcomp/reg.cmi asmcomp/selectgen.cmi \ - asmcomp/selection.cmi -asmcomp/selection.cmx: asmcomp/arch.cmx asmcomp/cmm.cmx asmcomp/mach.cmx \ - utils/misc.cmx asmcomp/reg.cmx asmcomp/selectgen.cmx \ - asmcomp/selection.cmi -asmcomp/spill.cmo: asmcomp/mach.cmi utils/misc.cmi asmcomp/proc.cmi \ - asmcomp/reg.cmi asmcomp/spill.cmi -asmcomp/spill.cmx: asmcomp/mach.cmx utils/misc.cmx asmcomp/proc.cmx \ - asmcomp/reg.cmx asmcomp/spill.cmi -asmcomp/split.cmo: asmcomp/mach.cmi utils/misc.cmi asmcomp/reg.cmi \ - asmcomp/split.cmi -asmcomp/split.cmx: asmcomp/mach.cmx utils/misc.cmx asmcomp/reg.cmx \ - asmcomp/split.cmi -driver/compile.cmi: typing/env.cmi -driver/optcompile.cmi: typing/env.cmi -driver/compile.cmo: bytecomp/bytegen.cmi utils/ccomp.cmi utils/clflags.cmo \ - utils/config.cmi bytecomp/emitcode.cmi typing/env.cmi typing/ident.cmi \ - utils/misc.cmi parsing/parse.cmi driver/pparse.cmi parsing/printast.cmi \ - bytecomp/printinstr.cmi bytecomp/printlambda.cmi typing/printtyp.cmi \ - bytecomp/simplif.cmi bytecomp/translmod.cmi typing/typedtree.cmi \ - typing/typemod.cmi utils/warnings.cmi driver/compile.cmi -driver/compile.cmx: bytecomp/bytegen.cmx utils/ccomp.cmx utils/clflags.cmx \ - utils/config.cmx bytecomp/emitcode.cmx typing/env.cmx typing/ident.cmx \ - utils/misc.cmx parsing/parse.cmx driver/pparse.cmx parsing/printast.cmx \ - bytecomp/printinstr.cmx bytecomp/printlambda.cmx typing/printtyp.cmx \ - bytecomp/simplif.cmx bytecomp/translmod.cmx typing/typedtree.cmx \ - typing/typemod.cmx utils/warnings.cmx driver/compile.cmi -driver/errors.cmo: bytecomp/bytelibrarian.cmi bytecomp/bytelink.cmi \ - bytecomp/bytepackager.cmi typing/ctype.cmi typing/env.cmi \ - typing/includemod.cmi parsing/lexer.cmi parsing/location.cmi \ - driver/pparse.cmi bytecomp/symtable.cmi parsing/syntaxerr.cmi \ - bytecomp/translclass.cmi bytecomp/translcore.cmi bytecomp/translmod.cmi \ - typing/typeclass.cmi typing/typecore.cmi typing/typedecl.cmi \ - typing/typemod.cmi typing/typetexp.cmi utils/warnings.cmi \ - driver/errors.cmi -driver/errors.cmx: bytecomp/bytelibrarian.cmx bytecomp/bytelink.cmx \ - bytecomp/bytepackager.cmx typing/ctype.cmx typing/env.cmx \ - typing/includemod.cmx parsing/lexer.cmx parsing/location.cmx \ - driver/pparse.cmx bytecomp/symtable.cmx parsing/syntaxerr.cmx \ - bytecomp/translclass.cmx bytecomp/translcore.cmx bytecomp/translmod.cmx \ - typing/typeclass.cmx typing/typecore.cmx typing/typedecl.cmx \ - typing/typemod.cmx typing/typetexp.cmx utils/warnings.cmx \ - driver/errors.cmi -driver/main.cmo: bytecomp/bytelibrarian.cmi bytecomp/bytelink.cmi \ - bytecomp/bytepackager.cmi utils/clflags.cmo driver/compile.cmi \ - utils/config.cmi driver/errors.cmi driver/main_args.cmi utils/misc.cmi \ - utils/warnings.cmi driver/main.cmi -driver/main.cmx: bytecomp/bytelibrarian.cmx bytecomp/bytelink.cmx \ - bytecomp/bytepackager.cmx utils/clflags.cmx driver/compile.cmx \ - utils/config.cmx driver/errors.cmx driver/main_args.cmx utils/misc.cmx \ - utils/warnings.cmx driver/main.cmi -driver/main_args.cmo: driver/main_args.cmi -driver/main_args.cmx: driver/main_args.cmi -driver/optcompile.cmo: asmcomp/asmgen.cmi utils/ccomp.cmi utils/clflags.cmo \ - asmcomp/compilenv.cmi utils/config.cmi typing/env.cmi typing/ident.cmi \ - utils/misc.cmi parsing/parse.cmi driver/pparse.cmi parsing/printast.cmi \ - bytecomp/printlambda.cmi typing/printtyp.cmi bytecomp/simplif.cmi \ - bytecomp/translmod.cmi typing/typedtree.cmi typing/typemod.cmi \ - utils/warnings.cmi driver/optcompile.cmi -driver/optcompile.cmx: asmcomp/asmgen.cmx utils/ccomp.cmx utils/clflags.cmx \ - asmcomp/compilenv.cmx utils/config.cmx typing/env.cmx typing/ident.cmx \ - utils/misc.cmx parsing/parse.cmx driver/pparse.cmx parsing/printast.cmx \ - bytecomp/printlambda.cmx typing/printtyp.cmx bytecomp/simplif.cmx \ - bytecomp/translmod.cmx typing/typedtree.cmx typing/typemod.cmx \ - utils/warnings.cmx driver/optcompile.cmi -driver/opterrors.cmo: asmcomp/asmgen.cmi asmcomp/asmlibrarian.cmi \ - asmcomp/asmlink.cmi asmcomp/asmpackager.cmi asmcomp/compilenv.cmi \ - typing/ctype.cmi typing/env.cmi typing/includemod.cmi parsing/lexer.cmi \ - parsing/location.cmi driver/pparse.cmi parsing/syntaxerr.cmi \ - bytecomp/translclass.cmi bytecomp/translcore.cmi bytecomp/translmod.cmi \ - typing/typeclass.cmi typing/typecore.cmi typing/typedecl.cmi \ - typing/typemod.cmi typing/typetexp.cmi utils/warnings.cmi \ - driver/opterrors.cmi -driver/opterrors.cmx: asmcomp/asmgen.cmx asmcomp/asmlibrarian.cmx \ - asmcomp/asmlink.cmx asmcomp/asmpackager.cmx asmcomp/compilenv.cmx \ - typing/ctype.cmx typing/env.cmx typing/includemod.cmx parsing/lexer.cmx \ - parsing/location.cmx driver/pparse.cmx parsing/syntaxerr.cmx \ - bytecomp/translclass.cmx bytecomp/translcore.cmx bytecomp/translmod.cmx \ - typing/typeclass.cmx typing/typecore.cmx typing/typedecl.cmx \ - typing/typemod.cmx typing/typetexp.cmx utils/warnings.cmx \ - driver/opterrors.cmi -driver/optmain.cmo: asmcomp/arch.cmo asmcomp/asmlibrarian.cmi \ - asmcomp/asmlink.cmi asmcomp/asmpackager.cmi utils/clflags.cmo \ - utils/config.cmi utils/misc.cmi driver/optcompile.cmi \ - driver/opterrors.cmi asmcomp/printmach.cmi utils/warnings.cmi \ - driver/optmain.cmi -driver/optmain.cmx: asmcomp/arch.cmx asmcomp/asmlibrarian.cmx \ - asmcomp/asmlink.cmx asmcomp/asmpackager.cmx utils/clflags.cmx \ - utils/config.cmx utils/misc.cmx driver/optcompile.cmx \ - driver/opterrors.cmx asmcomp/printmach.cmx utils/warnings.cmx \ - driver/optmain.cmi -driver/pparse.cmo: utils/ccomp.cmi utils/clflags.cmo parsing/location.cmi \ - utils/misc.cmi driver/pparse.cmi -driver/pparse.cmx: utils/ccomp.cmx utils/clflags.cmx parsing/location.cmx \ - utils/misc.cmx driver/pparse.cmi -toplevel/genprintval.cmi: typing/env.cmi typing/outcometree.cmi \ - typing/path.cmi typing/types.cmi -toplevel/topdirs.cmi: parsing/longident.cmi -toplevel/toploop.cmi: typing/env.cmi parsing/location.cmi \ - parsing/longident.cmi typing/outcometree.cmi parsing/parsetree.cmi \ - typing/path.cmi typing/types.cmi utils/warnings.cmi -toplevel/trace.cmi: typing/env.cmi parsing/longident.cmi typing/path.cmi \ - typing/types.cmi -toplevel/expunge.cmo: bytecomp/bytesections.cmi typing/ident.cmi \ - utils/misc.cmi bytecomp/runtimedef.cmi bytecomp/symtable.cmi -toplevel/expunge.cmx: bytecomp/bytesections.cmx typing/ident.cmx \ - utils/misc.cmx bytecomp/runtimedef.cmx bytecomp/symtable.cmx -toplevel/genprintval.cmo: typing/btype.cmi typing/ctype.cmi \ - typing/datarepr.cmi typing/env.cmi typing/ident.cmi parsing/longident.cmi \ - utils/misc.cmi typing/outcometree.cmi typing/path.cmi typing/predef.cmi \ - typing/printtyp.cmi typing/types.cmi toplevel/genprintval.cmi -toplevel/genprintval.cmx: typing/btype.cmx typing/ctype.cmx \ - typing/datarepr.cmx typing/env.cmx typing/ident.cmx parsing/longident.cmx \ - utils/misc.cmx typing/outcometree.cmi typing/path.cmx typing/predef.cmx \ - typing/printtyp.cmx typing/types.cmx toplevel/genprintval.cmi -toplevel/topdirs.cmo: utils/clflags.cmo utils/config.cmi utils/consistbl.cmi \ - typing/ctype.cmi bytecomp/dll.cmi bytecomp/emitcode.cmi typing/env.cmi \ - typing/ident.cmi parsing/longident.cmi bytecomp/meta.cmi utils/misc.cmi \ - bytecomp/opcodes.cmo typing/path.cmi typing/printtyp.cmi \ - bytecomp/symtable.cmi toplevel/toploop.cmi toplevel/trace.cmi \ - typing/types.cmi utils/warnings.cmi toplevel/topdirs.cmi -toplevel/topdirs.cmx: utils/clflags.cmx utils/config.cmx utils/consistbl.cmx \ - typing/ctype.cmx bytecomp/dll.cmx bytecomp/emitcode.cmx typing/env.cmx \ - typing/ident.cmx parsing/longident.cmx bytecomp/meta.cmx utils/misc.cmx \ - bytecomp/opcodes.cmx typing/path.cmx typing/printtyp.cmx \ - bytecomp/symtable.cmx toplevel/toploop.cmx toplevel/trace.cmx \ - typing/types.cmx utils/warnings.cmx toplevel/topdirs.cmi -toplevel/toploop.cmo: typing/btype.cmi bytecomp/bytegen.cmi utils/clflags.cmo \ - driver/compile.cmi utils/config.cmi utils/consistbl.cmi bytecomp/dll.cmi \ - bytecomp/emitcode.cmi typing/env.cmi driver/errors.cmi \ - toplevel/genprintval.cmi typing/ident.cmi parsing/lexer.cmi \ - parsing/location.cmi parsing/longident.cmi bytecomp/meta.cmi \ - utils/misc.cmi typing/oprint.cmi typing/outcometree.cmi parsing/parse.cmi \ - parsing/parsetree.cmi typing/path.cmi typing/predef.cmi \ - parsing/printast.cmi bytecomp/printinstr.cmi bytecomp/printlambda.cmi \ - typing/printtyp.cmi bytecomp/simplif.cmi bytecomp/symtable.cmi \ - bytecomp/translmod.cmi typing/typecore.cmi typing/typedtree.cmi \ - typing/typemod.cmi typing/types.cmi utils/warnings.cmi \ - toplevel/toploop.cmi -toplevel/toploop.cmx: typing/btype.cmx bytecomp/bytegen.cmx utils/clflags.cmx \ - driver/compile.cmx utils/config.cmx utils/consistbl.cmx bytecomp/dll.cmx \ - bytecomp/emitcode.cmx typing/env.cmx driver/errors.cmx \ - toplevel/genprintval.cmx typing/ident.cmx parsing/lexer.cmx \ - parsing/location.cmx parsing/longident.cmx bytecomp/meta.cmx \ - utils/misc.cmx typing/oprint.cmx typing/outcometree.cmi parsing/parse.cmx \ - parsing/parsetree.cmi typing/path.cmx typing/predef.cmx \ - parsing/printast.cmx bytecomp/printinstr.cmx bytecomp/printlambda.cmx \ - typing/printtyp.cmx bytecomp/simplif.cmx bytecomp/symtable.cmx \ - bytecomp/translmod.cmx typing/typecore.cmx typing/typedtree.cmx \ - typing/typemod.cmx typing/types.cmx utils/warnings.cmx \ - toplevel/toploop.cmi -toplevel/topmain.cmo: utils/clflags.cmo utils/config.cmi driver/errors.cmi \ - utils/misc.cmi toplevel/topdirs.cmi toplevel/toploop.cmi \ - utils/warnings.cmi toplevel/topmain.cmi -toplevel/topmain.cmx: utils/clflags.cmx utils/config.cmx driver/errors.cmx \ - utils/misc.cmx toplevel/topdirs.cmx toplevel/toploop.cmx \ - utils/warnings.cmx toplevel/topmain.cmi -toplevel/topstart.cmo: toplevel/topmain.cmi -toplevel/topstart.cmx: toplevel/topmain.cmx -toplevel/trace.cmo: typing/ctype.cmi parsing/longident.cmi bytecomp/meta.cmi \ - utils/misc.cmi typing/path.cmi typing/predef.cmi typing/printtyp.cmi \ - toplevel/toploop.cmi typing/types.cmi toplevel/trace.cmi -toplevel/trace.cmx: typing/ctype.cmx parsing/longident.cmx bytecomp/meta.cmx \ - utils/misc.cmx typing/path.cmx typing/predef.cmx typing/printtyp.cmx \ - toplevel/toploop.cmx typing/types.cmx toplevel/trace.cmi diff --git a/Changes b/Changes deleted file mode 100644 index b0cb25c666..0000000000 --- a/Changes +++ /dev/null @@ -1,1657 +0,0 @@ -Objective Caml 3.07: --------------------- - -Language features: -- Experimental support for recursive module definitions - module rec A : SIGA = StructA and B : SIGB = StructB and ... -- Support for "private types", or more exactly concrete data types - with private constructors or labels. These data types can be - de-structured normally in pattern matchings, but values of these - types cannot be constructed directly outside of their defining module. -- Added integer literals of types int32, nativeint, int64 - (written with an 'l', 'n' or 'L' suffix respectively). - -Type-checking: -- Allow polymorphic generalization of covariant parts of expansive - expressions. For instance, if f: unit -> 'a list, "let x = f ()" - gives "x" the generalized type forall 'a. 'a list, instead of '_a list - as before. -- The typing of polymorphic variants in pattern matching has changed. - It is intended to be more regular, sticking to the principle of "closing - only the variants which would be otherwise incomplete". Two potential - consequences: (1) some types may be left open which were closed before, - and the resulting type might not match the interface anymore (expected to - be rare); (2) in some cases an incomplete match may be generated. -- Lots of bug fixes in the handling of polymorphism and recursion inside - types. -- Added a new "-dtypes" option to ocamlc/ocamlopt, and an emacs extension - "emacs/caml-types.el". The compiler option saves inferred type information - to file *.annot, and the emacs extension allows the user to look at the - type of any subexpression in the source file. Works even in the case - of a type error (all the types computed up to the error are available). - This new feature is also supported by ocamlbrowser. -- Disable "method is overriden" warning when the method was explicitely - redefined as virtual beforehand (i.e. not through inheritance). Typing - and semantics are unchanged. - -Both compilers: -- Added option "-dtypes" to dump detailed type information to a file. -- The "-i" option no longer generates compiled files, it only prints - the inferred types. -- The sources for the module named "Mod" can be placed either in Mod.ml or - in mod.ml. -- Compilation of "let rec" on non-functional values: tightened some checks, - relaxed some other checks. -- Fixed wrong code that was generated for "for i = a to max_int" - or "for i = a downto min_int". -- An explicit interface Mod.mli can now be provided for the module obtained - by ocamlc -pack -o Mod.cmo ... or ocamlopt -pack -o Mod.cmx ... -- Revised internal handling of source code locations, now handles - preprocessed code better. -- Pattern-matching bug on float literals fixed. -- Minor improvements on pattern-matching over variants. -- More efficient compilation of string comparisons and the "compare" function. -- More compact code generated for arrays of constants. -- Fixed GC bug with mutable record fields of type "exn". -- Added warning "E" for "fragile patterns": pattern matchings that would - not be flagged as partial if new constructors were added to the data type. - -Bytecode compiler: -- Added option -vmthread to select the threads library with VM-level - scheduling. The -thread option now selects the system threads library. - -Native-code compiler: -- New port: AMD64 (Opteron). -- Fixed instruction selection bug on expressions of the kind (raise Exn)(arg). -- Several bug fixes in ocamlopt -pack (tracking of imported modules, - command line too long). -- Signal handling bug fixed. -- x86 port: - Added -ffast-math option to use inline trigo and log functions. - Small performance tweaks for the Pentium 4. - Fixed illegal "imul" instruction generated by reloading phase. -- Sparc port: - Enhanced code generation for Sparc V8 (option -march=v8) and - Sparc V9 (option -march=v9). - Profiling support added for Solaris. -- PowerPC port: - Keep stack 16-aligned for compatibility with C calling conventions. - -Toplevel interactive system: -- Tightened interface consistency checks between .cmi files, .cm[oa] files - loaded by #load, and the running toplevel. -- #trace on mutually-recursive functions was broken, works again. -- Look for .ocamlinit file in home directory in addition to the current dir. - -Standard library: -- Match_failure and Assert_failure exceptions now report - (file, line, column), instead of (file, starting char, ending char). -- float_of_string, int_of_string: some ill-formed input strings were not - rejected. -- Added format concatenation, string_of_format, format_of_string. -- Module Arg: added new option handlers Set_string, Set_int, Set_float, - Symbol, Tuple. -- Module Format: tag handling is now turned off by default, - use [Format.set_tags true] to activate. -- Modules Lexing and Parsing: added better handling of positions - in source file. Added function Lexing.flush_input. -- Module Scanf: %n and %N formats to count characters / items read so far; - assorted bug fixes, %! to match end of input. New ``_'' special - flag to skip reresulting value. -- Module Format: tags are not activated by default. -- Modules Set and Map: fixed bugs causing trees to become unbalanced. -- Module Printf: less restrictive typing of kprintf. -- Module Random: better seeding; functions to generate random int32, int64, - nativeint; added support for explicit state management. -- Module Sys: added Sys.readdir for reading the contents of a directory. - -Runtime system: -- output_value/input_value: fixed bug with large blocks (>= 4 Mwords) - produced on a 64-bit platform and incorrectly read back on a 32-bit - platform. -- Fixed memory compaction bug involving input_value. -- Added MacOS X support for dynamic linking of C libraries. -- Improved stack backtraces on uncaught exceptions. -- Fixed float alignment problem on Sparc V9 with gcc 3.2. - -Other libraries: -- Dynlink: - By default, dynamically-loaded code now has access to all - modules defined by the program; new functions Dynlink.allow_only - and Dynlink.prohibit implement access control. - Fixed Dynlink problem with files generated with ocamlc -pack. - Protect against references to modules not yet fully initialized. -- LablTK/CamlTK: added support for TCL/TK 8.4. -- Str: reimplemented regexp matching engine, now less buggy, faster, - and LGPL instead of GPL. -- Graphics: fixed draw_rect and fill_rect bug under X11. -- System threads and bytecode threads libraries can be both installed. -- System threads: better implementation of Thread.exit. -- Bytecode threads: fixed two library initialization bugs. -- Unix: make Unix.openfile blocking to account for named pipes; - GC bug in Unix.*stat fixed; fixed problem with Unix.dup2 on Windows. - -Ocamllex: -- Can name parts of the matched input text, e.g. - "0" (['0'-'7']+ as s) { ... s ... } - -Ocamldebug: -- Handle programs that run for more than 2^30 steps. - -Emacs mode: -- Added file caml-types.el to interactively display the type information - saved by option -dtypes. - -Win32 ports: -- Cygwin port: recognize \ as directory separator in addition to / -- MSVC port: ocamlopt -pack works provided GNU binutils are installed. -- Graphics library: fixed bug in Graphics.blit_image; improved event handling. - -OCamldoc: -- new ty_code field for types, to keep code of a type (with option -keep-code) -- new ex_code field for types, to keep code of an exception - (with option -keep-code) -- some fixes in html generation -- don't overwrite existing style.css file when generating HTML -- create the ocamldoc.sty file when generating LaTeX (if nonexistent) -- man pages are now installed in man/man3 rather than man/mano -- fix: empty [] in generated HTML indexes - - -Objective Caml 3.06: --------------------- - -Type-checking: -- Apply value restriction to polymorphic record fields. - -Run-time system: -- Fixed GC bug affecting lazy values. - -Both compilers: -- Added option "-version" to print just the version number. -- Fixed wrong dependencies in .cmi generated with the -pack option. - -Native-code compiler: -- Fixed wrong return value for inline bigarray assignments. - -Libraries: -- Unix.getsockopt: make sure result is a valid boolean. - -Tools: -- ocamlbrowser: improved error reporting; small Win32 fixes. - -Windows ports: -- Fixed two problems with the Mingw port under Cygwin 1.3. - - -Objective Caml 3.05: --------------------- - -Language features: -- Support for polymorphic methods and record fields. -- Allows _ separators in integer and float literals, e.g. 1_000_000. - -Type-checker: -- New flag -principal to enforce principality of type inference. -- Fixed subtle typing bug with higher-order functors. -- Fixed several complexity problems; changed (again) the behaviour of - simple coercions. -- Fixed various bugs with objects and polymorphic variants. -- Improved some error messages. - -Both compilers: -- Added option "-pack" to assemble several compilation units as one unit - having the given units as sub-modules. -- More precise detection of unused sub-patterns in "or" patterns. -- Warnings for ill-formed \ escapes in string and character literals. -- Protect against spaces and other special characters in directory names. -- Added interface consistency check when building a .cma or .cmxa library. -- Minor reduction in code size for class initialization code. -- Added option "-nostdlib" to ignore standard library entirely. - -Bytecode compiler: -- Fixed issue with ocamlc.opt and dynamic linking. - -Native-code compiler: -- Added link-time check for multiply-defined module names. -- Fixed GC bug related to constant constructors of polymorphic variant types. -- Fixed compilation bug for top-level "include" statements. -- PowerPC port: work around limited range for relative branches, - thus removing assembler failures on large functions. -- IA64 port: fixed code generation bug for 3-way constructor matching. - -Toplevel interactive system: -- Can load object files given on command line before starting up. -- ocamlmktop: minimized possibility of name clashes with user-provided modules. - -Run-time system: -- Minor garbage collector no longer recursive. -- Better support for lazy data in the garbage collector. -- Fixed issues with the heap compactor. -- Fixed issues with finalized Caml values. -- The type "int64" is now supported on all platforms: we use software - emulation if the C compiler doesn't support 64-bit integers. -- Support for float formats that are neither big-endian nor little-endian - (one known example: the ARM). -- Fixed bug in callback*_exn functions in the exception-catching case. -- Work around gcc 2.96 bug on RedHat 7.2 and Mandrake 8.0, 8.1 among others. -- Stub DLLs now installed in subdir stublibs/ of standard library dir. - -Standard library: -- Protect against integer overflow in sub-string and sub-array bound checks. -- New module Complex implementing arithmetic over complex numbers. -- New module Scanf implementing format-based scanning a la scanf() in C. -- Module Arg: added alternate entry point Arg.parse_argv. -- Modules Char, Int32, Int64, Nativeint, String: added type "t" and function - "compare" so that these modules can be used directly with e.g. Set.Make. -- Module Digest: fixed issue with Digest.file on large files (>= 1Gb); - added Digest.to_hex. -- Module Filename: added Filename.open_temp_file to atomically create and - open the temp file; improved security of Filename.temp_file. -- Module Genlex: allow _ as first character of an identifier. -- Module Lazy: more efficient implementation. -- Module Lexing: improved performances for very large tokens. -- Module List: faster implementation of sorting functions. -- Module Printf: - added %S and %C formats (quoted, escaped strings and characters); - added kprintf (calls user-specified continuation on formatted string). -- Module Queue: faster implementation (courtesy of François Pottier). -- Module Random: added Random.bool. -- Module Stack: added Stack.is_empty. -- Module Pervasives: - added sub-module LargeFile to support files larger than 1Gb - (file offsets are int64 rather than int); - opening in "append" mode automatically sets "write" mode; - files are now opened in close-on-exec mode; - string_of_float distinguishes its output from a plain integer; - faster implementation of input_line for long lines. -- Module Sys: - added Sys.ocaml_version containing the OCaml version number; - added Sys.executable_name containing the (exact) path of the - file being executable; - Sys.argv.(0) is now unchanged w.r.t. what was provided as 0-th argument - by the shell. -- Module Weak: added weak hash tables. - -Other libraries: -- Bigarray: - support for bigarrays of complex numbers; - added functions Genarray.dims, - {Genarray,Array1,Array2,Array3}.{kind,layout}. -- Dynlink: fixed bug with loading of mixed-mode Caml/C libraries. -- LablTK: - now supports also the CamlTK API (no labels); - support for Activate and Deactivate events; - support for virtual events; - added UTF conversion; - export the tcl interpreter as caml value, to avoid DLL dependencies. -- Unix: - added sub-module LargeFile to support files larger than 1Gb - (file offsets are int64 rather than int); - added POSIX opening flags (O_NOCTTY, O_*SYNC); - use reentrant functions for gethostbyname and gethostbyaddr when available; - fixed bug in Unix.close_process and Unix.close_process_full; - removed some overhead in Unix.select. - -Tools: -- ocamldoc (the documentation generator) is now part of the distribution. -- Debugger: now supports the option -I +dir. -- ocamllex: supports the same identifiers as ocamlc; warns for - bad \ escapes in strings and characters. -- ocamlbrowser: - recenter the module boxes when showing a cross-reference; - include the current directory in the ocaml path. - -Windows port: -- Can now compile with Mingw (the GNU compilers without the Cygwin - runtime library) in addition to MSVC. -- Toplevel GUI: wrong filenames were given to #use and #load commands; - read_line() was buggy for short lines (2 characters or less). -- OCamlBrowser: now fully functional. -- Graphics library: fixed several bugs in event handling. -- Threads library: fixed preemption bug. -- Unix library: better handling of the underlying differences between - sockets and regular file descriptors; - added Unix.lockf and a better Unix.rename (thanks to Tracy Camp). -- LablTk library: fixed a bug in Fileinput - - -Objective Caml 3.04: --------------------- - -Type-checker: -- Allowed coercing self to the type of the current class, avoiding - an obscure error message about "Self type cannot be unified..." - -Both compilers: -- Use OCAMLLIB environment variable to find standard library, falls - back on CAMLLIB if not defined. -- Report out-of-range ASCII escapes in character or string literals - such as "\256". - -Byte-code compiler: -- The -use-runtime and -make-runtime flags are back by popular demand - (same behavior as in 3.02). -- Dynamic loading (of the C part of mixed Caml/C libraries): arrange that - linking in -custom mode uses the static libraries for the C parts, - not the shared libraries, for maximal robustness and compatibility with - 3.02. - -Native-code compiler: -- Fixed bug in link-time consistency checking. - -Tools: -- ocamlyacc: added parser debugging support (set OCAMLRUNPARAM=p to get - a trace of the pushdown automaton actions). -- ocamlcp: was broken in 3.03 (Sys_error), fixed. - -Run-time system: -- More work on dynamic loading of the C part of mixed Caml/C libraries. -- On uncaught exception, flush output channels before printing exception - message and backtrace. -- Corrected several errors in exception backtraces. - -Standard library: -- Pervasives: integer division and modulus are now fully specified - on negative arguments (with round-towards-zero semantics). -- Pervasives.float_of_string: now raises Failure on ill-formed input. -- Pervasives: added useful float constants max_float, min_float, epsilon_float. -- printf functions in Printf and Format: added % formats for int32, nativeint, - int64; "*" in width and precision specifications now supported - (contributed by Thorsten Ohl). -- Added Hashtbl.copy, Stack.copy. -- Hashtbl: revised resizing strategy to avoid quadratic behavior - on Hashtbl.add. -- New module MoreLabels providing labelized versions of modules - Hashtbl, Map and Set. -- Pervasives.output_value and Marshal.to_* : improved hashing strategy - for internal data structures, avoid excessive slowness on - quasi-linearly-allocated inputs. - -Other libraries: -- Num: fixed bug in big integer exponentiation (Big_int.power_*). - -Windows port: -- New GUI for interactive toplevel (Jacob Navia). -- The Graphics library is now available for stand-alone executables - (Jacob Navia). -- Unix library: improved reporting of system error codes. -- Fixed error in "globbing" of * and ? patterns on command line. - -Emacs mode: small fixes; special color highlighting for ocamldoc comments. - -License: added special exception to the LGPL'ed code (libraries and - runtime system) allowing unrestricted linking, whether static or dynamic. - - -Objective Caml 3.03 ALPHA: --------------------------- - -Language: -- Removed built-in syntactic sugar for streams and stream patterns - [< ... >], now supported via CamlP4, which is now included in the - distribution. -- Switched the default behaviour to labels mode (labels are compulsory), - but allows omitting labels when a function application is complete. - -nolabels mode is available but deprecated for programming. - (See also scrapelabels and addlabels tools below.) -- Removed all labels in the standard libraries, except labltk. - Labelized versions are kept for ArrayLabels, ListLabels, StringLabels - and UnixLabels. "open StdLabels" gives access to the first three. -- Extended polymorphic variant type syntax, allowing union types and - row abbreviations for both sub- and super-types. #t deprecated in types. -- See the Upgrading file for how to adapt to all the changes above. - -Type-checker: -- Fixed obscure bug in module typing causing the type-checker to loop - on signatures of the form - module type M - module A: sig module type T = sig module T: M end end - module B: A.T -- Improved efficiency of module type-checking via lazy computation of - certain signature summary information. -- An empty polymorphic variant type is now an error. - -Both compilers: -- Fixed wrong code generated for "struct include M ... end" when M - contains one or several "external" declarations. - -Byte-code compiler: -- Protect against VM stack overflow caused by module initialization code - with many local variables. -- Support for dynamic loading of the C part of mixed Caml/C libraries. -- Removed the -use-runtime and -make-runtime flags, obsoleted by dynamic - loading of C libraries. - -Native-code compiler: -- Attempt to recover gracefully from system stack overflow. Currently - works on x86 under Linux and BSD. -- Alpha: work around "as" bug in Tru64 5.1. - -Toplevel environment: -- Revised printing of inferred types and evaluation results - so that an external printer (e.g. Camlp4's) can be hooked in. - -Tools: -- The CamlP4 pre-processor-pretty-printer is now included in the standard - distribution. -- New tool ocamlmklib to help build mixed Caml/C libraries. -- New tool scrapelabels and addlabels, to either remove (non-optional) - labels in interfaces, or automatically add them in the definitions. - They provide easy transition from classic mode ocaml 3.02 sources, - depending on whether you want to keep labels or not. -- ocamldep: added -pp option to handle preprocessed source files. - -Run-time system: -- Support for dynamic loading of the C part of mixed Caml/C libraries. - Currently works under Linux, FreeBSD, Windows, Tru64, Solaris and Irix. -- Implemented registration of global C roots with a skip list, - runs much faster when there are many global C roots. -- Autoconfiguration script: fixed wrong detection of Mac OS X; problem - with the Sparc, gcc 3.0, and float alignment fixed. - -Standard library: -- Added Pervasives.flush_all to flush all opened output channels. - -Other libraries: -- All libraries revised to allow dynamic loading of the C part. -- Graphics under X Windows: revised event handling, should no longer lose - mouse events between two calls to wait_next_event(); wait_next_event() - now interruptible by signals. -- Bigarrays: fixed bug in marshaling of big arrays. - -Windows port: -- Fixed broken Unix.{get,set}sockopt* - - - -Objective Caml 3.02: --------------------- - -Both compilers: -- Fixed embarrassing bug in pattern-matching compilation - (affected or-patterns containing variable bindings). -- More optimizations in pattern-matching compilation. - -Byte-code compiler: -- Protect against VM stack overflow caused by functions with many local - variables. - -Native-code compiler: -- Removed re-sharing of string literals, causes too many surprises with - in-place string modifications. -- Corrected wrong compilation of toplevel "include" statements. -- Fixed bug in runtime function "callbackN_exn". -- Signal handlers receive the conventional signal number as argument - instead of the system signal number (same behavior as with the - bytecode compiler). -- ARM port: fixed issue with immediate operand overflow in large functions. - -Toplevel environment: -- User-definer printers (for #install_printer) now receive as first argument - the pretty-printer formatter where to print their second argument. - Old printers (with only one argument) still supported for backward - compatibility. - -Standard library: -- Module Hashtbl: added Hashtbl.fold. - -Other libraries: -- Dynlink: better error reporting in add_interfaces for missing .cmi files. -- Graphics: added more drawing functions (multiple points, polygons, - multiple lines, splines). -- Bytecode threads: the module Unix is now thread-safe, ThreadUnix is - deprecated. Unix.exec* now resets standard descriptors to blocking mode. -- Native threads: fixed a context-switch-during-GC problem causing - certain C runtime functions to fail, most notably input_value. -- Unix.inet_addr_of_string: call inet_aton() when available so as to - handle correctly the address 255.255.255.255. -- Unix: added more getsockopt and setsockopt functions to get/set - options that have values other than booleans. -- Num: added documentation for the Big_int module. - -Tools: -- ocamldep: fixed wrong dependency issue with nested modules. - -Run-time system: -- Removed floating-point error at start-up on some non-IEEE platforms - (e.g. FreeBSD prior to 4.0R). -- Stack backtrace mechanism now works for threads that terminate on - an uncaught exception. - -Auto-configuration: -- Updated config.guess and config.sub scripts, should recognize a greater - number of recent platform. - -Windows port: -- Fixed broken Unix.waitpid. Unix.file_descr can now be compared or hashed. -- Toplevel application: issue with spaces in name of stdlib directory fixed. - -MacOS 9 port: -- Removed the last traces of support for 68k - - -Objective Caml 3.01: --------------------- - -New language features: -- Variables are allowed in "or" patterns, e.g. - match l with [t] | [_;t] -> ... t ... -- "include " to re-export all components of a - structure inside another structure. -- Variance annotation on parameters of type declarations, e.g. - type (+'a,-'b,'c) t (covariant in 'a, contravariant in 'b, invariant in 'c) - -New ports: -- Intel IA64/Itanium under Linux (including the native-code compiler). -- Cygwin under MS Windows. This port is an alternative to the earlier - Windows port of OCaml, which relied on MS compilers; the Cygwin - Windows port does not need MS Visual C++ nor MASM, runs faster - in bytecode, and has a better implementation of the Unix library, - but currently lacks threads and COM component support. - -Type-checking: -- Relaxed "monomorphic restriction" on type constructors in a - mutually-recursive type definition, e.g. the following is again allowed - type u = C of int t | D of string t and 'a t = ... -- Fixed name-capture bug in "include SIG" and "SIG with ..." constructs. -- Improved implicit subtypes built by (... :> ty), closer to intuition. -- Several bug fixes in type-checking of variants. -- Typing of polymorphic variants is more restrictive: - do not allow conjunctive types inside the same pattern matching. - a type has either an upper bound, or all its tags are in the lower bound. - This may break some programs (this breaks lablgl-0.94). - -Both compilers: -- Revised compilation of pattern matching. -- Option -I + to search a subdirectory of the standard - library directory (i.e. write "ocamlc -I +labltk" instead of - "ocamlc -I /usr/local/lib/ocaml/labltk"). -- Option -warn-error to turn warnings into errors. -- Option -where to print the location of the standard library directory. -- Assertions are now type-checked even if the -noassert option is given, - thus -noassert can no longe change the types of modules. - -Bytecode compiler and bytecode interpreter: -- Print stack backtrace when a program aborts due to an uncaught exception - (requires compilation with -g and running with ocamlrun -b or - OCAMLRUNPARAM="b=1"). - -Native-code compiler: -- Better unboxing optimizations on the int32, int64, and nativeint types. -- Tail recursion preserved for functions having more parameters than - available registers (but tail calls to other functions are still - turned off if parameters do not fit entirely in registers). -- Fixed name-capture bug in function inlining. -- Improved spilling/reloading strategy for conditionals. -- IA32, Alpha: better alignment of branch targets. -- Removed spurious dependency on the -lcurses library. - -Toplevel environment: -- Revised handling of top-level value definitions, allows reclaimation - of definitions that are shadowed by later definitions with the same names. - (E.g. "let x = ;; let x = 1;;" allows to be reclaimed.) -- Revised the tracing facility so that for standard library functions, - only calls from user code are traced, not calls from the system. -- Added a "*" prompt when within a comment. - -Runtime system: -- Fixed portability issue on bcopy() vs memmove(), affecting Linux RedHat 7.0 - in particular. -- Structural comparisons (=, <>, <, <=, >, >=, compare) reimplemented - so as to avoid overflowing the C stack. -- Input/output functions: arrange so that reads and writes on closed - in_channel or out_channel raise Sys_error immediately. - -Standard library: -- Module Gc: changed some counters to float in order to avoid overflow; - added alarms -- Module Hashtbl: added Hashtbl.replace. -- Module Int64: added bits_of_float, float_of_bits (access to IEEE 754 - representation of floats). -- Module List: List.partition now tail-rec; - improved memory behavior of List.stable_sort. -- Module Nativeint: added Nativeint.size (number of bits in a nativeint). -- Module Obj: fixed incorrect resizing of float arrays in Obj.resize. -- Module Pervasives: added float constants "infinity", "neg_infinity", "nan"; - added a "classify_float" function to test a float for NaN, infinity, etc. -- Pervasives.input_value: fixed bug affecting shared custom objects. -- Pervasives.output_value: fixed size bug affecting "int64" values. -- Pervasives.int_of_string, {Int32,Int64,Nativeint}.of_string: - fixed bug causing bad digits to be accepted without error. -- Module Random: added get_state and set_state to checkpoint the generator. -- Module Sys: signal handling functions are passed the system-independent - signal number rather than the raw system signal number whenever possible. -- Module Weak: added Weak.get_copy. - -Other libraries: -- Bigarray: added Bigarray.reshape to take a view of the elements of a - bigarray with different dimensions or number of dimensions; - fixed bug causing "get" operations to be unavailable in custom - toplevels including Bigarray. -- Dynlink: raise an error instead of crashing when the loaded module - refers to the not-yet-initialized module performing a dynlink operation. -- Bytecode threads: added a thread-safe version of the Marshal module; - fixed a rare GC bug in the thread scheduler. -- POSIX threads: fixed compilation problem with threads.cmxa. -- Both thread libraries: better tail-recursion in Event.sync. -- Num library: fixed bug in square roots (Nat.sqrt_nat, Big_int.sqrt_big_int). - -Tools: -- ocamldep: fixed missing dependencies on labels of record patterns and - record construction operations - -Win32 port: -- Unix.waitpid now implements the WNOHANG option. - -Mac OS ports: -- Mac OS X public beta is supported. -- Int64.format works on Mac OS 8/9. - - -Objective Caml 3.00: --------------------- - -Language: -- OCaml/OLabl merger: - * Support for labeled and optional arguments for functions and classes. - * Support for variant types (sum types compared by structure). - See tutorial (chapter 2 of the OCaml manual) for more information. -- Syntactic change: "?" in stream error handlers changed to "??". -- Added exception renaming in structures (exception E = F). -- (OCaml 2.99/OLabl users only) Label syntax changed to preserve - backward compatibility with 2.0x (labeled function application - is f ~lbl:arg instead of f lbl:arg). A tool is provided to help - convert labelized programs to OCaml 3.00. - -Both compilers: -- Option -labels to select commuting label mode (labels are mandatory, - but labeled arguments can be passed in a different order than in - the definition of the function; in default mode, labels may be omitted, - but argument reordering is only allowed for optional arguments). -- Libraries (.cma and .cmxa files) now "remember" C libraries given - at library construction time, and add them back at link time. - Allows linking with e.g. just unix.cma instead of - unix.cma -custom -cclib -lunix -- Revised printing of error messages, now use Format.fprintf; no visible - difference for users, but could facilitate internationalization later. -- Fixed bug in unboxing of records containing only floats. -- Fixed typing bug involving applicative functors as components of modules. -- Better error message for inconsistencies between compiled interfaces. - -Bytecode compiler: -- New "modular" format for bytecode executables; no visible differences - for users, but will facilitate further extensions later. -- Fixed problems in signal handling. - -Native-code compiler: -- Profiling support on x86 under FreeBSD -- Open-coding and unboxing optimizations for the new integer types - int32, int64, nativeint, and for bigarrays. -- Fixed instruction selection bug with "raise" appearing in arguments - of strict operators, e.g. "1 + raise E". -- Better error message when linking incomplete/incorrectly ordered set - of .cmx files. -- Optimized scanning of global roots during GC, can reduce total running - time by up to 8% on GC-intensive programs. - -Interactive toplevel: -- Better printing of exceptions, including arguments, when possible. -- Fixed rare GC bug occurring during interpretation of scripts. -- Added consistency checks between interfaces and implementations - during #load. - -Run-time system: -- Added support for "custom" heap blocks (heap blocks carrying - C functions for finalization, comparison, hashing, serialization - and deserialization). -- Support for finalisation functions written in Caml. - -Standard library: -- New modules Int32, Int64, Nativeint for 32-bit, 64-bit and - platform-native integers -- Module Array: added Array.sort, Array.stable_sort. -- Module Gc: added Gc.finalise to attach Caml finalisation functions to - arbitrary heap-allocated data. -- Module Hashtbl: do not bomb when resizing very large table. -- Module Lazy: raise Lazy.Undefined when a lazy evaluation needs itself. -- Module List: added List.sort, List.stable_sort; fixed bug in List.rev_map2. -- Module Map: added mapi (iteration with key and data). -- Module Set: added iterators for_all, exists, filter, partition. -- Module Sort: still here but deprecated in favor of new sorting functions - in Array and List. -- Module Stack: added Stack.top -- Module String: fixed boundary condition on String.rindex_from -- Added labels on function arguments where appropriate. - -New libraries and tools: -- ocamlbrowser: graphical browser for OCaml sources and compiled interfaces, - supports cross-referencing, editing, running the toplevel. -- LablTK: GUI toolkit based on TK, using labeled and optional arguments, - easier to use than CamlTK. -- Bigarray: large, multi-dimensional numerical arrays, facilitate - interfacing with C/Fortran numerical code, efficient support for - advanced array operations such as slicing and memory-mapping of files. - -Other libraries: -- Bytecode threads: timer-based preemption was broken, works back again; - fixed bug in Pervasives.input_line; exported Thread.yield. -- System threads: several GC / reentrancy bugs fixed in buffered I/O - and Unix I/O; revised Thread.join implementation for strict POSIX - conformance; exported Thread.yield. -- Graphics: added support for double buffering; added, current_x, current_y, - rmoveto, rlineto, and draw_rect. -- Num: fixed bug in Num.float_of_num. -- Str: worked around potential symbol conflicts with C standard library. -- Dbm: fixed bug with Dbm.iter on empty database. - -New or updated ports: -- Alpha/Digital Unix: lifted 256M limitation on total memory space - induced by -taso -- Port to AIX 4.3 on PowerPC -- Port to HPUX 10 on HPPA -- Deprecated 680x0 / SunOS port - -Macintosh port: -- Implemented the Unix and Thread libraries. -- The toplevel application does not work on 68k Macintoshes; maybe - later if there's a demand. -- Added a new tool, ocamlmkappli, to build an application from a - program written in O'Caml. - - -Objective Caml 2.04: --------------------- - -- C interface: corrected inconsistent change in the CAMLparam* macros. -- Fixed internal error in ocamlc -g. -- Fixed type-checking of "S with ...", where S is a module type name - abbreviating another module type name. -- ocamldep: fixed stdout/stderr mismatch after failing on one file. -- Random.self_init more random. -- Windows port: - - Toplevel application: fixed spurious crash on exit. - - Native-code compiler: fixed bug in assembling certain - floating-point constants (masm doesn't grok 2e5, wants 2.0e5). - -Objective Caml 2.03: --------------------- - -New ports: -- Ported to BeOS / Intel x86 (bytecode and native-code). -- BSD / Intel x86 port now supports both a.out and ELF binary formats. -- Added support for {Net,Open}BSD / Alpha. -- Revamped Rhapsody port, now works on MacOS X server. - -Syntax: -- Warning for "(*)" and "*)" outside comment. -- Removed "#line LINENO", too ambiguous with a method invocation; - the equivalent "# LINENO" is still supported. - -Typing: -- When an incomplete pattern-matching is detected, report also a - value or value template that is not covered by the cases of - the pattern-matching. -- Several bugs in class type matching and in type error reporting fixed. -- Added an option -rectypes to support general recursive types, - not just those involving object types. - -Bytecode compiler: -- Minor cleanups in the bytecode emitter. -- Do not remove "let x = y" bindings in -g mode; makes it easier to - debug the code. - -Native-code compiler: -- Fixed bug in grouping of allocations performed in the same basic block. -- Fixed bug in constant propagation involving expressions containing - side-effects. -- Fixed incorrect code generation for "for" loops whose upper bound is - a reference assigned inside the loop. -- MIPS code generator: work around a bug in the IRIX 6 assembler. - -Toplevel: -- Fixed incorrect redirection of standard formatter to stderr - while executing toplevel scripts. - -Standard library: -- Added List.rev_map, List.rev_map2. -- Documentation of List functions now says which functions are - tail-rec, and how much stack space is needed for non-tailrec functions. -- Wrong type for Printf.bprintf fixed. -- Fixed weird behavior of Printf.sprintf and Printf.bprintf in case of - partial applications. -- Added Random.self_init, which initializes the PRNG from the system date. -- Sort.array: serious bugs fixed. -- Stream.count: fixed incorrect behavior with ocamlopt. - -Run-time system and external interface: -- Fixed weird behavior of signal handlers w.r.t. signal masks and exceptions - raised from the signal handler. -- Fixed bug in the callback*_exn() functions. - -Debugger: -- Fixed wrong printing of float record fields and elements of float arrays. -- Supports identifiers starting with '_'. - -Profiler: -- Handles .mli files, so ocamlcp can be used to replace ocamlc (e.g. in a - makefile). -- Now works on programs that use stream expressions and stream parsers. - -Other libraries: -- Graphics: under X11, treat all mouse buttons equally; fixed problem - with current font reverting to the default font when the graphics - window is resized. -- Str: fixed reentrancy bugs in Str.replace and Str.full_split. -- Bytecode threads: set standard I/O descriptors to non-blocking mode. -- OS threads: revised implementation of Thread.wait_signal. -- All threads: added Event.wrap_abort, Event.choose []. -- Unix.localtime, Unix.gmtime: check for errors. -- Unix.create_process: now supports arbitrary redirections of std descriptors. -- Added Unix.open_process_full. -- Implemented Unix.chmod under Windows. -- Big_int.square_big_int now gives the proper sign to its result. - -Others: -- ocamldep: don't stop at first error, skip to next file. -- Emacs mode: updated with Garrigue and Zimmerman's snapshot of 1999/10/18. -- configure script: added -prefix option. -- Windows toplevel application: fixed problem with graphics library - not loading properly. - - -Objective Caml 2.02: --------------------- - -* Type system: - - Check that all components of a signature have unique names. - - Fixed bug in signature matching involving a type component and - a module component, both sharing an abstract type. - - Bug involving recursive classes constrained by a class type fixed. - - Fixed bugs in printing class types and in printing unification errors. - -* Compilation: - - Changed compilation scheme for "{r with lbl = e}" when r has many fields - so as to avoid code size explosion. - -* Native-code compiler: - - Better constant propagation in boolean expressions and in conditionals. - - Removal of unused arguments during function inlining. - - Eliminated redundant tagging/untagging in bit shifts. - - Static allocation of closures for functions without free variables, - reduces the size of initialization code. - - Revised compilation scheme for definitions at top level of compilation - units, so that top level functions have no free variables. - - Coalesced multiple allocations of heap blocks inside one expression - (e.g. x :: y :: z allocates the two conses in one step). - - Ix86: better handling of large integer constants in instruction selection. - - MIPS: fixed wrong asm generated for String.length "literal". - -* Standard library: - - Added the "ignore" primitive function, which just throws away its - argument and returns "()". It allows to write - "ignore(f x); y" if "f x" doesn't have type unit and you don't - want the warning caused by "f x; y". - - Added the "Buffer" module (extensible string buffers). - - Module Format: added formatting to buffers and to strings. - - Added "mem" functions (membership test) to Hashtbl and Map. - - Module List: added find, filter, partition. - Renamed remove and removeq to remove_assoc and remove_assq. - - Module Marshal: fixed bug in marshaling functions when passed functional - values defined by mutual recursion with other functions. - - Module Printf: added Printf.bprintf (print to extensible buffer); - added %i format as synonymous for %d (as per the docs). - - Module Sort: added Sort.array (Quicksort). - -* Runtime system: - - New callback functions for callbacks with arbitrary many arguments - and for catching Caml exceptions escaping from a callback. - -* The ocamldep dependency generator: now performs full parsing of the - sources, taking into account the scope of module bindings. - -* The ocamlyacc parser generator: fixed sentinel error causing wrong - tables to be generated in some cases. - -* The str library: - - Added split_delim, full_split as variants of split that control - more precisely what happens to delimiters. - - Added replace_matched for separate matching and replacement operations. - -* The graphics library: - - Bypass color lookup for 16 bpp and 32 bpp direct-color displays. - - Larger color cache. - -* The thread library: - - Bytecode threads: more clever use of non-blocking I/O, makes I/O - operations faster. - - POSIX threads: gcc-ism removed, should now compile on any ANSI C compiler. - - Both: avoid memory leak in the Event module when a communication - offer is never selected. - -* The Unix library: - - Fixed inversion of ctime and mtime in Unix.stat, Unix.fstat, Unix.lstat. - - Unix.establish_connection: properly reclaim socket if connect fails. - -* The DBM library: no longer crashes when calling Dbm.close twice. - -* Emacs mode: - - Updated with Garrigue and Zimmerman's latest version. - - Now include an "ocamltags" script for using etags on OCaml sources. - -* Win32 port: - - Fixed end-of-line bug in ocamlcp causing problems with generated sources. - - -Objective Caml 2.01: --------------------- - -* Typing: - - Added warning for expressions of the form "a; b" where a does not have - type "unit"; catches silly mistake such as - "record.lbl = newval; ..." instead of "record.lbl <- newval; ...". - - Typing bug in "let module" fixed. - -* Compilation: - - Fixed bug in compilation of recursive and mutually recursive classes. - - Option -w to turn specific warnings on/off. - - Option -cc to choose the C compiler used with ocamlc -custom and ocamlopt. - -* Bytecode compiler and bytecode interpreter: - - Intel x86: removed asm declaration causing "fixed or forbidden register - spilled" error with egcs and gcc 2.8 (but not with gcc 2.7, go figure). - - Revised handling of debugging information, allows faster linking with -g. - -* Native-code compiler: - - Fixed bugs in integer constant propagation. - - Out-of-bound accesses in array and strings now raise an Invalid_argument - exception (like the bytecode system) instead of stopping the program. - - Corrected scheduling of bound checks. - - Port to the StrongARM under Linux (e.g. Corel Netwinder). - - I386: fixed bug in profiled code (ocamlopt -p). - - Mips: switched to -n32 model under IRIX; dropped the Ultrix port. - - Sparc: simplified the addressing modes, allows for better scheduling. - - Fixed calling convention bug for Pervasives.modf. - -* Toplevel: - - #trace works again. - - ocamlmktop: use matching ocamlc, not any ocamlc from the search path. - -* Memory management: - - Fixed bug in heap expansion that could cause the GC to loop. - -* C interface: - - New macros CAMLparam... and CAMLlocal... to simplify the handling - of local roots in C code. - - Simplified procedure for allocating and filling Caml blocks from C. - - Declaration of string_length in . - -* Standard library: - - Module Format: added {get,set}_all_formatter_output_functions, - formatter_of_out_channel, and the control sequence @ in printf. - - Module List: added mem_assoc, mem_assq, remove, removeq. - - Module Pervasives: added float_of_int (synonymous for float), - int_of_float (truncate), int_of_char (Char.code), char_of_int (Char.chr), - bool_of_string. - - Module String: added contains, contains_from, rcontains_from. - -* Unix library: - - Unix.lockf: added F_RLOCK, F_TRLOCK; use POSIX locks whenever available. - - Unix.tc{get,set}attr: added non-standard speeds 57600, 115200, 230400. - - Unix.chroot: added. - -* Threads: - - Bytecode threads: improved speed of I/O scheduling. - - Native threads: fixed a bug involving signals and exceptions - generated from C. - -* The "str" library: - - Added Str.string_partial_match. - - Bumped size of internal stack. - -* ocamlyacc: emit correct '# lineno' directive for prelude part of .mly file. - -* Emacs editing mode: updated with Jacques Garrigue's newest code. - -* Windows port: - - Added support for the "-cclib -lfoo" option (instead of - -cclib /full/path/libfoo.lib as before). - - Threads: fixed a bug at initialization time. - -* Macintosh port: source code for Macintosh application merged in. - - -Objective Caml 2.00: --------------------- - -* Language: - - New class language. See http://caml.inria.fr/ocaml/refman/ - for a tutorial (chapter 2) and for the reference manual (section 4.9). - - Local module definitions "let module X = in ". - - Record copying with update "{r with lbl1 = expr1; ...}". - - Array patterns "[|pat1; ...;patN|]" in pattern-matchings. - - New reserved keywords: "object", "initializer". - - No longer reserved: "closed", "protected". - -* Bytecode compiler: - - Use the same compact memory representations for float arrays, float - records and recursive closures as the native-code compiler. - - More type-dependent optimizations. - - Added the -use_runtime and -make_runtime flags to build separately - and reuse afterwards custom runtime systems - (inspired by Fabrice Le Fessant's patch). - -* Native-code compiler: - - Cross-module constant propagation of integer constants. - - More type-dependent optimizations. - - More compact code generated for "let rec" over data structures. - - Better code generated for "for" loops (test at bottom of code). - - More aggressive scheduling of stores. - - Added -p option for time profiling with gprof - (fully supported on Intel x86/Linux and Alpha/Digital Unix only) - (inspired by Aleksey Nogin's patch). - - A case of bad spilling with high register pressure fixed. - - Fixed GC bug when GC called from C without active Caml code. - - Alpha: $gp handling revised to follow Alpha's standard conventions, - allow running "atom" and "pixie" on ocamlopt-generated binaries. - - Intel x86: use movzbl and movsbl systematically to load 8-bit and 16-bit - quantities, no more hacks with partial registers (better for the - Pentium Pro, worse for the Pentium). - - PowerPC: more aggressive scheduling of return address reloading. - - Sparc: scheduling bug related to register pairs fixed. - -* Runtime system: - - Better printing of uncaught exceptions (print a fully qualified - name whenever possible). - -* New ports: - - Cray T3E (bytecode only) (in collaboration with CEA). - - PowerMac under Rhapsody. - - SparcStations under Linux. - -* Standard library: - - Added set_binary_mode_in and set_binary_mode_out in Pervasives - to toggle open channels between text and binary modes. - - output_value and input_value check that the given channel is in - binary mode. - - input_value no longer fails on very large marshalled data (> 16 Mbytes). - - Module Arg: added option Rest. - - Module Filename: temp_file no longer loops if temp dir doesn't exist. - - Module List: added rev_append (tail-rec alternative to @). - - Module Set: tell the truth about "elements" returning a sorted list; - added min_elt, max_elt, singleton. - - Module Sys: added Sys.time for simple measuring of CPU time. - -* ocamllex: - - Check for overflow when generating the tables for the automaton. - - Error messages in generated .ml file now point to .mll source. - - Added "let = " to name regular expressions - (inspired by Christian Lindig's patch). - -* ocamlyacc: - - Better error recovery in presence of EOF tokens. - - Error messages in generated .ml file now point to .mly source. - - Generated .ml file now type-safe even without the generated .mli file. - -* The Unix library: - - Use float instead of int to represent Unix times (number of seconds - from the epoch). This fixes a year 2005 problem on 32-bit platforms. - Functions affected: stat, lstat, fstat, time, gmtime, localtime, - mktime, utimes. - - Added putenv. - - Better handling of "unknown" error codes (EUNKNOWNERR). - - Fixed endianness bug in getservbyport. - - win32unix (the Win32 implementation of the Unix library) now has - the same interface as the unix implementation, this allows exchange - of compiled .cmo and .cmi files between Unix and Win32. - -* The thread libraries: - - Bytecode threads: bug with escaping exceptions fixed. - - System threads (POSIX, Win32): malloc/free bug fixed; signal bug fixed. - - Both: added Thread.wait_signal to wait synchronously for signals. - -* The graph library: bigger color cache. - -* The str library: added Str.quote, Str.regexp_string, - Str.regexp_string_case_fold. - -* Emacs mode: - - Fixed bug with paragraph fill. - - Fixed bug with next-error under Emacs 20. - - -Objective Caml 1.07: --------------------- - -* Native-code compiler: - - Revised interface between generated code and GC, fixes serious GC - problems with signals and native threads. - - Added "-thread" option for compatibility with ocamlc. - -* Debugger: correctly print instance variables of objects. - -* Run-time system: ported to OpenBSD. - -* Standard library: fixed wrong interface for Marshal.to_buffer and - Obj.unmarshal. - -* Num library: added Intel x86 optimized asm code (courtesy of - Bernard Serpette). - -* Thread libraries: - - Native threads: fixed GC bugs and installation procedure. - - Bytecode threads: fixed problem with "Marshal" module. - - Both: added Event.always. - -* MS Windows port: better handling of long command lines in Sys.command - -Objective Caml 1.06: --------------------- - -* Language: - - Added two new keywords: "assert" (check assertion) and "lazy" - (delay evaluation). - - Allow identifiers to start with "_" (such identifiers are treated - as lowercase idents). - -* Objects: - - Added "protected" methods (visible only from subclasses, can be hidden - in class type declared in module signature). - - Objects can be compared using generic comparison functions. - - Fixed compilation of partial application of object constructors. - -* Type system: - - Occur-check now more strict (all recursions must traverse an object). - - A few bugs fixed. - -* Run-time system: - - A heap compactor was implemented, so long-running programs can now - fight fragmentation. - - The meaning of the "space_overhead" parameter has changed. - - The macros Push_roots and Pop_roots are superseded by Begin_roots* and - End_roots. - - Bytecode executable includes list of primitives used, avoids crashes - on version mismatch. - - Reduced startup overhead for marshalling, much faster marshalling of - small objects. - - New exception Stack_overflow distinct from Out_of_memory. - - Maximum stack size configurable. - - I/O revised for compatibility with compactor and with native threads. - - All C code ANSIfied (new-style function declarations, etc). - - Threaded code work on all 64-bit processors, not just Alpha/Digital Unix. - - Better printing of uncaught exceptions. - -* Both compilers: - - Parsing: more detailed reporting of syntax errors (e.g. shows - unmatched opening parenthesis on missing closing parenthesis). - - Check consistency between interfaces (.cmi). - - Revised rules for determining dependencies between modules. - - Options "-verbose" for printing calls to C compiler, "-noassert" - for turning assertion checks off. - -* Native-code compiler: - - Machine-dependent parts rewritten using inheritance instead of - parameterized modules. - - GC bug in value let rec fixed. - - Port to Linux/Alpha. - - Sparc: cleaned up use of %g registers, now compatible with Solaris threads. - -* Top-level interactive system: - - Can execute Caml script files given on command line. - - Reads commands from ./.ocamlinit on startup. - - Now thread-compatible. - -* Standard library: - - New library module: Lazy (delayed computations). - - New library module: Marshal. Allows marshalling to strings and - transmission of closures between identical programs (SPMD parallelism). - - Filename: "is_absolute" is superseded by "is_implicit" and "is_relative". - To adapt old programs, change "is_absolute x" to "not (is_implicit x)" - (but the new "is_relative" is NOT the opposite of the old "is_absolute"). - - Array, Hashtbl, List, Map, Queue, Set, Stack, Stream: - the "iter" functions now take as argument a unit-returning function. - - Format: added "printf" interface to the formatter (see the documentation). - Revised behaviour of simple boxes: no more than one new line is output - when consecutive break hints should lead to multiple line breaks. - - Stream: revised implementation, renamed Parse_failure to Failure and - Parse_error to Error (don't you love gratuitous changes?). - - String: added index, rindex, index_from, rindex_from. - - Array: added mapi, iteri, fold_left, fold_right, init. - - Added Map.map, Set.subset, Printexc.to_string. - -* ocamllex: lexers generated by ocamllex can now handle all characters, - including '\000'. - -* ocamlyacc: fixed bug with function closures returned by parser rules. - -* Debugger: - - Revised generation of events. - - Break on function entrance. - - New commands start/previous. - - The command loadprinter now try to recursively load required - modules. - - Numerous small fixes. - -* External libraries: - - systhreads: can now use POSIX threads; POSIX and Win32 threads are - now supported by the native-code compiler. - - dbm and graph: work in native code. - - num: fixed bug in Nat.nat_of_string. - - str: fixed deallocation bug with case folding. - - win32unix: use Win32 handles instead of (buggy) VC++ emulation of Unix - file handles; added gettimeofday. - -* Emacs editing mode and debugger interface updated to July '97 version. - -Objective Caml 1.05: --------------------- - -* Typing: fixed several bugs causing spurious type errors. - -* Native-code compiler: fixed instruction selection bug causing GC to -see ill-formed pointers; fixed callbacks to support invocation from a -main program in C. - -* Standard library: fixed String.lowercase; Weak now resists integers. - -* Toplevel: multiple phrases without intermediate ";;" now really supported; -fixed value printing problems where the wrong printer was selected. - -* Debugger: fixed printing problem with local references; revised -handling of checkpoints; various other small fixes. - -* Macintosh port: fixed signed division problem in bytecomp/emitcode.ml - -Objective Caml 1.04: --------------------- - -* Replay debugger ported from Caml Light; added debugger support in - compiler (option -g) and runtime system. Debugger is alpha-quality - and needs testing. - -* Parsing: - - Support for "# linenum" directives. - - At toplevel, allow several phrases without intermediate ";;". - -* Typing: - - Allow constraints on datatype parameters, e.g. - type 'a foo = ... constraint 'a = 'b * 'c. - - Fixed bug in signature matching in presence of free type variables '_a. - - Extensive cleanup of internals of type inference. - -* Native-code compilation: - - Inlining of small functions at point of call (fairly conservative). - - MIPS code generator ported to SGI IRIX 6. - - Better code generated for large integer constants. - - Check for urgent GC when allocating large objects in major heap. - - PowerPC port: better scheduling, reduced TOC consumption. - - HPPA port: handle long conditional branches gracefully, - several span-dependent bugs fixed. - -* Standard library: - - More floating-point functions (all ANSI C float functions now available). - - Hashtbl: added functorial interface (allow providing own equality - and hash functions); rehash when resizing, avoid memory leak on - Hashtbl.remove. - - Added Char.uppercase, Char.lowercase, String.uppercase, String.lowercase, - String.capitalize, String.uncapitalize. - - New module Weak for manipulating weak pointers. - - New module Callback for registering closures and exceptions to be - used from C. - -* Foreign interface: - - Better support for callbacks (C calling Caml), exception raising - from C, and main() in C. Added function to remove a global root. - - Option -output-obj to package Caml code as a C library. - -* Thread library: fixed bug in timed_read and timed_write operations; - Lexing.from_function and Lexing.from_channel now reentrant. - -* Unix interface: renamed EACCESS to EACCES (the POSIX name); added setsid; - fixed bug in inet_addr_of_string for 64-bit platforms. - -* Ocamlyacc: default error function no longer prevents error recovery. - -* Ocamllex: fixed reentrancy problem w.r.t. exceptions during refill; - fixed output problem (\r\r\n) under Win32. - -* Macintosh port: - - The makefiles are provided for compiling and installing O'Caml on - a Macintosh with MPW 3.4.1. - - An application with the toplevel in a window is forthcoming. - -* Windows NT/95 port: updated toplevel GUI to that of Caml Light 0.73. - -* Emacs editing mode and debugger interface included in distribution. - - -Objective Caml 1.03: --------------------- - -* Typing: - - bug with type names escaping their scope via unification with - non-generalized type variables '_a completely fixed; - - fixed bug in occur check : it was too restrictive; - - fixed bug of coercion operators; - - check that no two types of the same name are generated in a module - (there was no check for classes); - - "#install_printer" works again; - - fixed bug in printing of subtyping errors; - - in class interfaces, construct "method m" (without type) change - the status of method m from abstract to concrete; - - in a recursive definition of class interfaces, a class can now - inherit from a previous class; - - typing of a method make use of an eventual previously given type - of this method, yielding clearer type errors. - -* Compilation (ocamlc and ocamlopt): - - fixed bug in compilation of classes. - -* Native-code compilation: - - optimization of functions taking tuples of arguments; - - code emitter for the Motorola 680x0 processors (retrocomputing week); - - Alpha/OSF1: generate frame descriptors, avoids crashes when e.g. - exp() or log() cause a domain error; fixed bug with - String.length "literal"; - - Sparc, Mips, HPPA: removed marking of scanned stack frames - (benefits do not outweight cost). - -* Standard library: - - Arg.parse now prints documentation for command-line options; - - I/O buffers (types in_channel and out_channel) now heap-allocated, - avoids crashing when closing a channel several times; - - Overflow bug in compare() fixed; - - GC bug in raising Sys_error from I/O functions fixed; - - Parsing.symbol_start works even for epsilon productions. - -* Foreign interface: main() in C now working, fixed bug in library - order at link time. - -* Thread library: guard against calling thread functions before Thread.create. - -* Unix library: fixed getsockopt, setsockopt, open_process_{in,out}. - -* Perl-free, cpp-free, cholesterol-free installation procedure. - - -Objective Caml 1.02: --------------------- -* Typing: - - fixed bug with type names escaping their scope via unification - with non-generalized type variables '_a; - - keep #class abbreviations longer; - - faster checking of well-formed abbreviation definitions; - - stricter checking of "with" constraints over signatures (arity - mismatch, overriding of an already manifest type). - -* Compilation (ocamlc and ocamlopt): - - fixed bug in compilation of recursive classes; - - [|...|] and let...rec... allowed inside definitions of recursive - data structures; - -* Bytecode compilation: fixed overflow in linker for programs with - more than 65535 globals and constants. - -* Native-code compilation: - - ocamlopt ported to HPPA under HP/UX, Intel x86 under Solaris 2, - PowerMacintosh under MkLinux; - - fixed two bugs related to floating-point arrays (one with "t array" - where t is an abstract type implemented as float, one with - comparison between two float arrays on 32 bit platforms); - - fixed reloading/spilling problem causing non-termination of - register allocation; - - fixed bugs in handling of () causing loss of tail recursion; - - fixed reloading bug in indirect calls. - -* Windows NT/95 port: - - complete port of the threads library (Pascal Cuoq); - - partial port of the Unix library (Pascal Cuoq); - - expansion of *, ? and @ on the command line. - -* Standard library: - - bug in in List.exists2 fixed; - - bug in "Random.int n" for very large n on 64-bit machines fixed; - - module Format: added a "general purpose" type of box (open_box); - can output on several formatters at the same time. - -* The "threads" library: - - implementation on top of native threads available for Win32 and - POSIX 1003.1c; - - added -thread option to select a thread-safe version of the - standard library, the ThreadIO module is no longer needed. - -* The "graph" library: avoid invalid pixmaps when doing - open_graph/close_graph several times. - -* The "dynlink" library: support for "private" (no re-export) dynamic loading. - -* ocamlyacc: skip '...' character literals correctly. - -* C interface: C code linked with O'Caml code can provide its own main() - and call caml_main() later. - - -Objective Caml 1.01: --------------------- -* Typing: better report of type incompatibilities; - non-generalizable type variables in a struct...end no longer flagged - immediately as an error; - name clashes during "open" avoided. - -* Fixed bug in output_value where identical data structures - could have different external representations; this bug caused wrong - "inconsistent assumptions" errors when checking compatibility of - interfaces at link-time. - -* Standard library: fixed bug in Array.blit on overlapping array sections - -* Unmarshaling from strings now working. - -* ocamlc, ocamlopt: new flags -intf and -impl to force compilation as - an implementation/an interface, regardless of file extension; - overflow bug on wide-range integer pattern-matchings fixed. - -* ocamlc: fixed bytecode generation bug causing problems with compilation - units defining more than 256 values - -* ocamlopt, all platforms: - fixed GC bug in "let rec" over data structures; - link startup file first, fixes "undefined symbol" errors with some - libraries. - -* ocamlopt, Intel x86: - more efficient calling sequence for calling C functions; - floating-point wars, chapter 5: don't use float stack for holding - float pseudo-registers, stack-allocating them is just as efficient. - -* ocamlopt, Alpha and Intel x86: more compact calling sequence for garbage - collection. - -* ocamllex: generated automata no longer use callbacks for refilling - the input buffer (works better with threads); character literals - correctly skipped inside actions. - -* ocamldep: "-I" directories now searched in the right order - -* Thread library: incompatibilities with callbacks, signals, and - dynamic linking removed; scheduling bug with Thread.wait fixed. - -* New "dbm" library, interfaces with NDBM. - -* Object-oriented extensions: - instance variables can now be omitted in class types; - some error messages have been made clearer; - several bugs fixes. - -Objective Caml 1.00: --------------------- - -* Merge of Jerome Vouillon and Didier Remy's object-oriented -extensions. - -* All libraries: all "new" functions renamed to "create" because "new" -is now a reserved keyword. - -* Compilation of "or" patterns (pat1 | pat2) completely revised to -avoid code size explosion. - -* Compiler support for preprocessing source files (-pp flag). - -* Library construction: flag -linkall to force linking of all units in -a library. - -* Native-code compiler: port to the Sparc under NetBSD. - -* Toplevel: fixed bug when tracing several times the same function -under different names. - -* New format for marshaling arbitrary data structures, allows -marshaling to/from strings. - -* Standard library: new module Genlex (configurable lexer for streams) - -* Thread library: much better support for I/O and blocking system calls. - -* Graphics library: faster reclaimation of unused pixmaps. - -* Unix library: new functions {set,clear}_nonblock, {set,clear}_close_on_exec, -{set,get}itimer, inet_addr_any, {get,set}sockopt. - -* Dynlink library: added support for linking libraries (.cma files). - -Caml Special Light 1.15: ------------------------- - -* Caml Special Light now runs under Windows NT and 95. Many thanks to -Kevin Gallo (Microsoft Research) who contributed his initial port. - -* csllex now generates tables for a table-driven automaton. -The resulting lexers are smaller and run faster. - -* Completely automatic configuration script. - -* Typing: more stringent checking of module type definitions against -manifest module type specifications. - -* Toplevel: recursive definitions of values now working. - -* Native-code compiler, all platforms: - toplevel "let"s with refutable patterns now working; - fixed bug in assignment to float record fields; - direct support for floating-point negation and absolute value. - -* Native-code compiler, x86: fixed bug with tail calls (with more than -4 arguments) from a function with a one-word stack frame. - -* Native-code compiler, Sparc: problem with -compact fixed. - -* Thread library: support for non-blocking writes; scheduler revised. - -* Unix library: bug in gethostbyaddr fixed; bounds checking for read, -write, etc. - -Caml Special Light 1.14: ------------------------- - -* cslopt ported to the PowerPC/RS6000 architecture. Better support for -AIX in the bytecode system as well. - -* cslopt, all platforms: fixed bug in live range splitting around catch/exit. - -* cslopt for the Intel (floating-point wars, chapter 4): -implemented Ershov's algorithm to minimize floating-point stack usage; -out-of-order pops fixed. - -* Several bug fixes in callbacks and signals. - -Caml Special Light 1.13: ------------------------- - -* Pattern-matching compilation revised to factor out accesses inside -matched structures. - -* Callbacks and signals now supported in cslopt. -Signals are only detected at allocation points, though. -Added callback functions with 2 and 3 arguments. - -* More explicit error messages when a native-code program aborts due -to array or string bound violations. - -* In patterns, "C _" allowed even if the constructor C has several arguments. - -* && and || allowed as alternate syntax for & and or. - -* cslopt for the Intel: code generation for floating-point -operations entirely redone for the third time (a pox on whomever at -Intel decided to organize the floating-point registers as a stack). - -* cslopt for the Sparc: don't use Sparc V8 smul and sdiv instructions, -emulation on V7 processors is abysmal. - -Caml Special Light 1.12: ------------------------- - -* Fixed an embarrassing bug with references to floats. - -Caml Special Light 1.11: ------------------------- - -* Streams and stream parsers a la Caml Light are back (thanks to -Daniel de Rauglaudre). - -* User-level concurrent threads, with low-level shared memory primitives -(locks and conditions) as well as channel-based communication primitives -with first-class synchronous events, in the style of Reppy's CML. - -* The native-code compiler has been ported to the HP PA-RISC processor -running under NextStep (sorry, no HPUX, its linker keeps dumping -core on me). - -* References not captured in a function are optimized into variables. - -* Fixed several bugs related to exceptions. - -* Floats behave a little more as specified in the IEEE standard -(believe it or not, but x < y is not the negation of x >= y). - -* Lower memory consumption for the native-code compiler. - -Caml Special Light 1.10: ------------------------- - -* Many bug fixes (too many to list here). - -* Module language: introduction of a "with module" notation over -signatures for concise sharing of all type components of a signature; -better support for concrete types in signatures. - -* Native-code compiler: the Intel 386 version has been ported to -NextStep and FreeBSD, and generates better code (especially for -floats) - -* Tools and libraries: the Caml Light profiler and library for -arbitrary-precision arithmetic have been ported (thanks to John -Malecki and Victor Manuel Gulias Fernandez); better docs for the Unix -and regexp libraries. - -Caml Special Light 1.07: ------------------------- - -* Syntax: optional ;; allowed in compilation units and structures -(back by popular demand) - -* cslopt: -generic handling of float arrays fixed -direct function application when the function expr is not a path fixed -compilation of "let rec" over values fixed -multiple definitions of a value name in a module correctly handled -no calls to ranlib in Solaris - -* csltop: #trace now working - -* Standard library: added List.memq; documentation of Array fixed. - -Caml Special Light 1.06: ------------------------- - -* First public release. diff --git a/INSTALL b/INSTALL deleted file mode 100644 index 2fc5a30295..0000000000 --- a/INSTALL +++ /dev/null @@ -1,263 +0,0 @@ - Installing Objective Caml on a Unix machine - ------------------------------------------- - -PREREQUISITES - -* The GNU C compiler gcc is recommended, as the bytecode - interpreter takes advantage of gcc-specific features to enhance - performance. - -* Under HP/UX, the GNU C compiler gcc, the GNU assembler gas, and GNU make - are all *required*. The vendor-provided compiler, assembler and make - have major problems. - -* Under MacOS X, before you begin, you must raise the limit on the - stack size with one of the following commands: - - limit stacksize 64M # if your shell is zsh or tcsh - ulimit -s 65536 # if your shell is bash - - -INSTALLATION INSTRUCTIONS - -1- Configure the system. From the top directory, do: - - ./configure - -This generates the three configuration files "Makefile", "m.h" and "s.h" -in the config/ subdirectory. - -The "configure" script accepts the following options: - --bindir (default: /usr/local/bin) - Directory where the binaries will be installed - --libdir (default: /usr/local/lib/ocaml) - Directory where the Caml library will be installed - --mandir (default: /usr/local/man/man1) - Directory where the manual pages will be installed - --prefix (default: /usr/local) - Set bindir, libdir and mandir to - /bin, /lib/ocaml, /man/man1 respectively. - --cc (default: gcc if available, cc otherwise) - C compiler to use for building the system - --libs (default: none) - Extra libraries to link with the system - --no-curses - Do not use the curses library. - --host (default: determined automatically) - The type of the host machine, in GNU's "configuration name" - format (CPU-COMPANY-SYSTEM). This info is generally determined - automatically by the "configure" script, and rarely ever - needs to be provided by hand. The installation instructions - for gcc or emacs contain a complete list of configuration names. - --x11include (default: determined automatically) --x11lib (default: determined automatically) - Location of the X11 include directory (e.g. /usr/X11R6/include) - and the X11 library directory (e.g. /usr/X11R6/lib). - --tkdefs (default: none) --tklibs (default: determined automatically) - These options specify where to find the Tcl/Tk libraries for - LablTk. "-tkdefs" helps to find the headers, and "-tklibs" - the C libraries. "-tklibs" may contain either only -L/path and - -Wl,... flags, in which case the library names are determined - automatically, or the actual libraries, which are used as given. - Example: for a Japanese tcl/tk whose headers are in specific - directories and libraries in /usr/local/lib, you can use - ./configure -tklibs "-L/usr/local/lib -ltk8.0jp -ltcl8.0jp" - -tkdefs "-I/usr/local/include/tcl8.0jp -I/usr/local/include/tk8.0jp" - --tk-no-x11 - Build LablTk without using X11. This option is needed on Cygwin. - --no-tk - Do not attempt to build LablTk. - --no-pthread - Do not attempt to use POSIX threads. - --verbose - Verbose output of the configuration tests. Use it if the outcome - of configure is not what you were expecting. - -Examples: - ./configure -prefix /usr/bin - ./configure -bindir /usr/bin -libdir /usr/lib/ocaml -mandir /usr/man/manl - ./configure -cc "acc -fast" -libs "-lucb" - # For Sun Solaris with the acc compiler - ./configure -cc "xlc_r -D_AIX43 -Wl,-bexpall,-brtl -qmaxmem=8192" - # For AIX 4.3 with the IBM compiler - -If something goes wrong during the automatic configuration, or if the -generated files cause errors later on, then look at the template files - - config/Makefile-templ - config/m-templ.h - config/s-templ.h - -for guidance on how to edit the generated files by hand. - -2- From the top directory, do: - - make world - -This builds the Objective Caml bytecode compiler for the first time. -This phase is fairly verbose; consider redirecting the output to a file: - - make world > log.world 2>&1 # in sh - make world >& log.world # in csh - -3- (Optional) To be sure everything works well, you can try to -bootstrap the system --- that is, to recompile all Objective Caml -sources with the newly created compiler. From the top directory, do: - - make bootstrap - -or, better: - - make bootstrap > log.bootstrap 2>&1 # in sh - make bootstrap >& log.bootstrap # in csh - -The "make bootstrap" checks that the bytecode programs compiled with -the new compiler are identical to the bytecode programs compiled with -the old compiler. If this is the case, you can be pretty sure the -system has been correctly compiled. Otherwise, this does not -necessarily mean something went wrong. The best thing to do is to try -a second bootstrapping phase: just do "make bootstrap" again. It will -either crash almost immediately, or re-re-compile everything correctly -and reach the fixpoint. - -4- If your platform is supported by the native-code compiler (as -reported during the autoconfiguration), you can now build the -native-code compiler. From the top directory, do: - - make opt -or: - make opt > log.opt 2>&1 # in sh - make opt >& log.opt # in csh - -5- (Optional) If you want to give the native-code compiler a serious -test, you can try to compile the Objective Caml compilers with the -native-code compiler (they are compiled to bytecode by default). -Just do: - - make opt.opt - -Later, you can compile your programs to bytecode using ocamlc.opt -instead of ocamlc, and to native-code using ocamlopt.opt instead of -ocamlopt. The ".opt" compilers should run faster than the normal -compilers, especially on large input files, but they may take longer -to start due to increased code size. If compilation times are an issue on -your programs, try the ".opt" compilers to see if they make a -significant difference. - -An alternative, and faster approach to steps 2 to 5 is - - make world.opt # to build using native-code compilers - -The result is equivalent to "make world opt opt.opt", but this may -fail if anything goes wrong in native-code generation. - -6- You can now install the Objective Caml system. This will create the -following commands (in the binary directory selected during -autoconfiguration): - - ocamlc the batch bytecode compiler - ocamlopt the batch native-code compiler (if supported) - ocamlrun the runtime system for the bytecode compiler - ocamlyacc the parser generator - ocamllex the lexer generator - ocaml the interactive, toplevel-based system - ocamlmktop a tool to make toplevel systems that integrate - user-defined C primitives and Caml code - ocamldebug the source-level replay debugger - ocamldep generator of "make" dependencies for Caml sources - ocamldoc documentation generator - ocamlprof execution count profiler - ocamlcp the bytecode compiler in profiling mode - -and also, if you built them during step 5, - - ocamlc.opt the batch bytecode compiler compiled with ocamlopt - ocamlopt.opt the batch native-code compiler compiled with ocamlopt - ocamllex.opt the lexer generator compiled with ocamlopt - -From the top directory, become superuser and do: - - umask 022 # make sure to give read & execute permission to all - make install - -7- Installation is complete. Time to clean up. From the toplevel -directory, do "make clean". - -8- (Optional) The emacs/ subdirectory contains Emacs-Lisp files for an -Objective Caml editing mode and an interface for the debugger. To -install these files, change to the emacs/ subdirectory and do - - make EMACSDIR= install -or - make install - -In the latter case, the destination directory defaults to the -"site-lisp" directory of your Emacs installation. - -9- After installation, do *not* strip the ocamldebug and ocamlbrowser -executables. (These are mixed-mode executables, containing both -compiled C code and Caml bytecode; stripping erases the bytecode!) -Other executables such as ocamlrun can safely be stripped. - -IF SOMETHING GOES WRONG: - -Read the "common problems" and "machine-specific hints" section at the -end of this file. - -Check the files m.h and s.h in config/. Wrong endianness or alignment -constraints in m.h will immediately crash the bytecode interpreter. - -If you get a "segmentation violation" signal, check the limits on the -stack size and data segment size (type "limit" under csh or -"ulimit -a" under bash). Make sure the limit on the stack size is -at least 4M. - -Try recompiling the runtime system with optimizations turned off -(change CFLAGS in byterun/Makefile and asmrun/Makefile). -The runtime system contains some complex, atypical pieces of C code -that can uncover bugs in optimizing compilers. Alternatively, try -another C compiler (e.g. gcc instead of the vendor-supplied cc). - -You can also build a debug version of the runtime system. Go to the -byterun/ directory and do "make ocamlrund". Then, copy ocamlrund to -../boot/ocamlrun, and try again. This version of the runtime system -contains lots of assertions and sanity checks that could help you -pinpoint the problem. - - -COMMON PROBLEMS: - -* The Makefiles use the "include" directive, which is not supported by -all versions of make. Use GNU make if this is a problem. - -* The Makefiles assume that make execute commands by calling /bin/sh. They -won't work if /bin/csh is called instead. You may have to unset the SHELL -environment variable, or set it to /bin/sh. - -* gcc 2.7.2.1 generates incorrect code for the runtime system in -O mode -on some Intel x86 platforms (e.g. Linux RedHat 4.1 and 4.2). -If this causes a problem, the solution is to upgrade to 2.7.2.3 or above. - -* Some versions of gcc 2.96 for the Intel x86 (as found in RedHat 7.2, -Mandrake 8.0 and Mandrake 8.1) generates incorrect code for the runtime -system. The "configure" script tries to work around this problem. - -* On HP 9000/700 machines under HP/UX 9. Some versions of cc are -unable to compile correctly the runtime system (wrong code is -generated for (x - y) where x is a pointer and y an integer). -Fix: use gcc. diff --git a/INSTALL.MPW b/INSTALL.MPW deleted file mode 100644 index ce65b945f5..0000000000 --- a/INSTALL.MPW +++ /dev/null @@ -1,89 +0,0 @@ -# $Id$ - - - ### Installing Objective Caml on a Macintosh with MPW ### - - - -# This file describes how to install and recompile Objective Caml -# in the MPW environment under MacOS 7, 8, 9. For MacOS X, see -# the instructions for Unix machines in the file INSTALL. - - -# PREREQUISITES - -# You need MPW 3.5 (with MrC) and Universal Interfaces version 3.3.2 -# You need WASTE version 1.3 -# -# MPW is available from Apple's FTP site at: -# -# -# WASTE 1.3 is available from: -# - - -# INSTALLATION INSTRUCTIONS -# -# To install Objective Caml in your MPW environment, follow this script. -# Read the comments and execute the commands. If you run the commands -# without changing anything, you'll get a reasonable default configuration. - -# Before you start, you must put the WASTE 1.3 distribution folder -# into the :maccaml:WASTE: folder. - - -# Go to the directory where you found this file. - -Directory "`echo "{active}" | streamedit -e '1 replace /[Â:]*°/ ""'`" - -# Set the O'Caml configuration files. - -Duplicate -y :config:s-MacOS.h :config:s.h -Duplicate -y :config:m-MacOS.h :config:m.h - -# Copy some useful scripts to your Commands directory. -# DoMake is absolutely needed for installation -# Characters is only needed by the executable error messages - -Duplicate :tools:DoMake :tools:Characters "{MPW}User Commands:" - -# NOTE: if you have MakeDepend from a previous version of O'Caml, you -# must remove it from "{MPW}User Commands:". It is not needed any more -# since MPW 3.5 has a MakeDepend command. - - -# Build the WASTE libraries: - -Directory ":maccaml:WASTE:WASTE 1.3 Distribution:" -DoMake -f ::Makefile WASTELib.x ·· "{worksheet}" -Directory :::: - -# Edit ":config:config.Mac" to change the configuration. -# (mostly, the destination folders for installation) - -Open :config:config.Mac - -# Set the configuration variables. - -Execute :config:config.Mac - -# O'Caml needs an environment variable to find its library files. -# (the value is taken from the configuration variables) - -Set -e CAMLLIB "{LIBDIR}" - -# Make it persistent. - -Set CAMLLIB > "{MPW}Startup Items:OCaml" - -# Now you're all set. Build the files and install everything. -# For more explanations on these steps, see the file INSTALL. - -begin - DoMake world - DoMake bootstrap - DoMake install -end ·· "{worksheet}" - -# If you want syntax coloring in MPW Shell, use ResEdit to copy the -# resources from :tools:keywords into the shell. diff --git a/LICENSE b/LICENSE deleted file mode 100644 index bd3dbe83e4..0000000000 --- a/LICENSE +++ /dev/null @@ -1,618 +0,0 @@ -In the following, "the Library" refers to all files marked "Copyright -INRIA" in the following directories and their sub-directories: - - asmrun, byterun, camlp4, config, maccaml, otherlibs, stdlib, win32caml - -and "the Compiler" refers to all files marked "Copyright INRIA" in the -other directories and their sub-directories. - -The Compiler is distributed under the terms of the Q Public License -version 1.0 (included below). - -The Library is distributed under the terms of the GNU Library General -Public License version 2 (included below). - -As a special exception to the GNU Library General Public License, you -may link, statically or dynamically, a "work that uses the Library" -with a publicly distributed version of the Library to produce an -executable file containing portions of the Library, and distribute -that executable file under terms of your choice, without any of the -additional requirements listed in clause 6 of the GNU Library General -Public License. By "a publicly distributed version of the Library", -we mean either the unmodified Library as distributed by INRIA, or a -modified version of the Library that is distributed under the -conditions defined in clause 3 of the GNU Library General Public -License. This exception does not however invalidate any other reasons -why the executable file might be covered by the GNU Library General -Public License. - ----------------------------------------------------------------------- - - THE Q PUBLIC LICENSE version 1.0 - - Copyright (C) 1999 Troll Tech AS, Norway. - Everyone is permitted to copy and - distribute this license document. - -The intent of this license is to establish freedom to share and change -the software regulated by this license under the open source model. - -This license applies to any software containing a notice placed by the -copyright holder saying that it may be distributed under the terms of -the Q Public License version 1.0. Such software is herein referred to -as the Software. This license covers modification and distribution of -the Software, use of third-party application programs based on the -Software, and development of free software which uses the Software. - - Granted Rights - -1. You are granted the non-exclusive rights set forth in this license -provided you agree to and comply with any and all conditions in this -license. Whole or partial distribution of the Software, or software -items that link with the Software, in any form signifies acceptance of -this license. - -2. You may copy and distribute the Software in unmodified form -provided that the entire package, including - but not restricted to - -copyright, trademark notices and disclaimers, as released by the -initial developer of the Software, is distributed. - -3. You may make modifications to the Software and distribute your -modifications, in a form that is separate from the Software, such as -patches. The following restrictions apply to modifications: - - a. Modifications must not alter or remove any copyright notices - in the Software. - - b. When modifications to the Software are released under this - license, a non-exclusive royalty-free right is granted to the - initial developer of the Software to distribute your - modification in future versions of the Software provided such - versions remain available under these terms in addition to any - other license(s) of the initial developer. - -4. You may distribute machine-executable forms of the Software or -machine-executable forms of modified versions of the Software, -provided that you meet these restrictions: - - a. You must include this license document in the distribution. - - b. You must ensure that all recipients of the machine-executable - forms are also able to receive the complete machine-readable - source code to the distributed Software, including all - modifications, without any charge beyond the costs of data - transfer, and place prominent notices in the distribution - explaining this. - - c. You must ensure that all modifications included in the - machine-executable forms are available under the terms of this - license. - -5. You may use the original or modified versions of the Software to -compile, link and run application programs legally developed by you or -by others. - -6. You may develop application programs, reusable components and other -software items that link with the original or modified versions of the -Software. These items, when distributed, are subject to the following -requirements: - - a. You must ensure that all recipients of machine-executable - forms of these items are also able to receive and use the - complete machine-readable source code to the items without any - charge beyond the costs of data transfer. - - b. You must explicitly license all recipients of your items to - use and re-distribute original and modified versions of the - items in both machine-executable and source code forms. The - recipients must be able to do so without any charges whatsoever, - and they must be able to re-distribute to anyone they choose. - - c. If the items are not available to the general public, and the - initial developer of the Software requests a copy of the items, - then you must supply one. - - Limitations of Liability - -In no event shall the initial developers or copyright holders be -liable for any damages whatsoever, including - but not restricted to - -lost revenue or profits or other direct, indirect, special, incidental -or consequential damages, even if they have been advised of the -possibility of such damages, except to the extent invariable law, if -any, provides otherwise. - - No Warranty - -The Software and this license document are provided AS IS with NO -WARRANTY OF ANY KIND, INCLUDING THE WARRANTY OF DESIGN, -MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. - - Choice of Law - -This license is governed by the Laws of France. Disputes shall be -settled by the Court of Versailles. - ----------------------------------------------------------------------- - - GNU LIBRARY GENERAL PUBLIC LICENSE - Version 2, June 1991 - - Copyright (C) 1991 Free Software Foundation, Inc. - 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA - Everyone is permitted to copy and distribute verbatim copies - of this license document, but changing it is not allowed. - -[This is the first released version of the library GPL. It is - numbered 2 because it goes with version 2 of the ordinary GPL.] - - Preamble - - The licenses for most software are designed to take away your -freedom to share and change it. By contrast, the GNU General Public -Licenses are intended to guarantee your freedom to share and change -free software--to make sure the software is free for all its users. - - This license, the Library General Public License, applies to some -specially designated Free Software Foundation software, and to any -other libraries whose authors decide to use it. You can use it for -your libraries, too. - - When we speak of free software, we are referring to freedom, not -price. Our General Public Licenses are designed to make sure that you -have the freedom to distribute copies of free software (and charge for -this service if you wish), that you receive source code or can get it -if you want it, that you can change the software or use pieces of it -in new free programs; and that you know you can do these things. - - To protect your rights, we need to make restrictions that forbid -anyone to deny you these rights or to ask you to surrender the rights. -These restrictions translate to certain responsibilities for you if -you distribute copies of the library, or if you modify it. - - For example, if you distribute copies of the library, whether gratis -or for a fee, you must give the recipients all the rights that we gave -you. You must make sure that they, too, receive or can get the source -code. If you link a program with the library, you must provide -complete object files to the recipients so that they can relink them -with the library, after making changes to the library and recompiling -it. And you must show them these terms so they know their rights. - - Our method of protecting your rights has two steps: (1) copyright -the library, and (2) offer you this license which gives you legal -permission to copy, distribute and/or modify the library. - - Also, for each distributor's protection, we want to make certain -that everyone understands that there is no warranty for this free -library. If the library is modified by someone else and passed on, we -want its recipients to know that what they have is not the original -version, so that any problems introduced by others will not reflect on -the original authors' reputations. - - Finally, any free program is threatened constantly by software -patents. We wish to avoid the danger that companies distributing free -software will individually obtain patent licenses, thus in effect -transforming the program into proprietary software. To prevent this, -we have made it clear that any patent must be licensed for everyone's -free use or not licensed at all. - - Most GNU software, including some libraries, is covered by the ordinary -GNU General Public License, which was designed for utility programs. This -license, the GNU Library General Public License, applies to certain -designated libraries. This license is quite different from the ordinary -one; be sure to read it in full, and don't assume that anything in it is -the same as in the ordinary license. - - The reason we have a separate public license for some libraries is that -they blur the distinction we usually make between modifying or adding to a -program and simply using it. Linking a program with a library, without -changing the library, is in some sense simply using the library, and is -analogous to running a utility program or application program. However, in -a textual and legal sense, the linked executable is a combined work, a -derivative of the original library, and the ordinary General Public License -treats it as such. - - Because of this blurred distinction, using the ordinary General -Public License for libraries did not effectively promote software -sharing, because most developers did not use the libraries. We -concluded that weaker conditions might promote sharing better. - - However, unrestricted linking of non-free programs would deprive the -users of those programs of all benefit from the free status of the -libraries themselves. This Library General Public License is intended to -permit developers of non-free programs to use free libraries, while -preserving your freedom as a user of such programs to change the free -libraries that are incorporated in them. (We have not seen how to achieve -this as regards changes in header files, but we have achieved it as regards -changes in the actual functions of the Library.) The hope is that this -will lead to faster development of free libraries. - - The precise terms and conditions for copying, distribution and -modification follow. Pay close attention to the difference between a -"work based on the library" and a "work that uses the library". The -former contains code derived from the library, while the latter only -works together with the library. - - Note that it is possible for a library to be covered by the ordinary -General Public License rather than by this special one. - - GNU LIBRARY GENERAL PUBLIC LICENSE - TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION - - 0. This License Agreement applies to any software library which -contains a notice placed by the copyright holder or other authorized -party saying it may be distributed under the terms of this Library -General Public License (also called "this License"). Each licensee is -addressed as "you". - - A "library" means a collection of software functions and/or data -prepared so as to be conveniently linked with application programs -(which use some of those functions and data) to form executables. - - The "Library", below, refers to any such software library or work -which has been distributed under these terms. A "work based on the -Library" means either the Library or any derivative work under -copyright law: that is to say, a work containing the Library or a -portion of it, either verbatim or with modifications and/or translated -straightforwardly into another language. (Hereinafter, translation is -included without limitation in the term "modification".) - - "Source code" for a work means the preferred form of the work for -making modifications to it. For a library, complete source code means -all the source code for all modules it contains, plus any associated -interface definition files, plus the scripts used to control compilation -and installation of the library. - - Activities other than copying, distribution and modification are not -covered by this License; they are outside its scope. The act of -running a program using the Library is not restricted, and output from -such a program is covered only if its contents constitute a work based -on the Library (independent of the use of the Library in a tool for -writing it). Whether that is true depends on what the Library does -and what the program that uses the Library does. - - 1. You may copy and distribute verbatim copies of the Library's -complete source code as you receive it, in any medium, provided that -you conspicuously and appropriately publish on each copy an -appropriate copyright notice and disclaimer of warranty; keep intact -all the notices that refer to this License and to the absence of any -warranty; and distribute a copy of this License along with the -Library. - - You may charge a fee for the physical act of transferring a copy, -and you may at your option offer warranty protection in exchange for a -fee. - - 2. You may modify your copy or copies of the Library or any portion -of it, thus forming a work based on the Library, and copy and -distribute such modifications or work under the terms of Section 1 -above, provided that you also meet all of these conditions: - - a) The modified work must itself be a software library. - - b) You must cause the files modified to carry prominent notices - stating that you changed the files and the date of any change. - - c) You must cause the whole of the work to be licensed at no - charge to all third parties under the terms of this License. - - d) If a facility in the modified Library refers to a function or a - table of data to be supplied by an application program that uses - the facility, other than as an argument passed when the facility - is invoked, then you must make a good faith effort to ensure that, - in the event an application does not supply such function or - table, the facility still operates, and performs whatever part of - its purpose remains meaningful. - - (For example, a function in a library to compute square roots has - a purpose that is entirely well-defined independent of the - application. Therefore, Subsection 2d requires that any - application-supplied function or table used by this function must - be optional: if the application does not supply it, the square - root function must still compute square roots.) - -These requirements apply to the modified work as a whole. If -identifiable sections of that work are not derived from the Library, -and can be reasonably considered independent and separate works in -themselves, then this License, and its terms, do not apply to those -sections when you distribute them as separate works. But when you -distribute the same sections as part of a whole which is a work based -on the Library, the distribution of the whole must be on the terms of -this License, whose permissions for other licensees extend to the -entire whole, and thus to each and every part regardless of who wrote -it. - -Thus, it is not the intent of this section to claim rights or contest -your rights to work written entirely by you; rather, the intent is to -exercise the right to control the distribution of derivative or -collective works based on the Library. - -In addition, mere aggregation of another work not based on the Library -with the Library (or with a work based on the Library) on a volume of -a storage or distribution medium does not bring the other work under -the scope of this License. - - 3. You may opt to apply the terms of the ordinary GNU General Public -License instead of this License to a given copy of the Library. To do -this, you must alter all the notices that refer to this License, so -that they refer to the ordinary GNU General Public License, version 2, -instead of to this License. (If a newer version than version 2 of the -ordinary GNU General Public License has appeared, then you can specify -that version instead if you wish.) Do not make any other change in -these notices. - - Once this change is made in a given copy, it is irreversible for -that copy, so the ordinary GNU General Public License applies to all -subsequent copies and derivative works made from that copy. - - This option is useful when you wish to copy part of the code of -the Library into a program that is not a library. - - 4. You may copy and distribute the Library (or a portion or -derivative of it, under Section 2) in object code or executable form -under the terms of Sections 1 and 2 above provided that you accompany -it with the complete corresponding machine-readable source code, which -must be distributed under the terms of Sections 1 and 2 above on a -medium customarily used for software interchange. - - If distribution of object code is made by offering access to copy -from a designated place, then offering equivalent access to copy the -source code from the same place satisfies the requirement to -distribute the source code, even though third parties are not -compelled to copy the source along with the object code. - - 5. A program that contains no derivative of any portion of the -Library, but is designed to work with the Library by being compiled or -linked with it, is called a "work that uses the Library". Such a -work, in isolation, is not a derivative work of the Library, and -therefore falls outside the scope of this License. - - However, linking a "work that uses the Library" with the Library -creates an executable that is a derivative of the Library (because it -contains portions of the Library), rather than a "work that uses the -library". The executable is therefore covered by this License. -Section 6 states terms for distribution of such executables. - - When a "work that uses the Library" uses material from a header file -that is part of the Library, the object code for the work may be a -derivative work of the Library even though the source code is not. -Whether this is true is especially significant if the work can be -linked without the Library, or if the work is itself a library. The -threshold for this to be true is not precisely defined by law. - - If such an object file uses only numerical parameters, data -structure layouts and accessors, and small macros and small inline -functions (ten lines or less in length), then the use of the object -file is unrestricted, regardless of whether it is legally a derivative -work. (Executables containing this object code plus portions of the -Library will still fall under Section 6.) - - Otherwise, if the work is a derivative of the Library, you may -distribute the object code for the work under the terms of Section 6. -Any executables containing that work also fall under Section 6, -whether or not they are linked directly with the Library itself. - - 6. As an exception to the Sections above, you may also compile or -link a "work that uses the Library" with the Library to produce a -work containing portions of the Library, and distribute that work -under terms of your choice, provided that the terms permit -modification of the work for the customer's own use and reverse -engineering for debugging such modifications. - - You must give prominent notice with each copy of the work that the -Library is used in it and that the Library and its use are covered by -this License. You must supply a copy of this License. If the work -during execution displays copyright notices, you must include the -copyright notice for the Library among them, as well as a reference -directing the user to the copy of this License. Also, you must do one -of these things: - - a) Accompany the work with the complete corresponding - machine-readable source code for the Library including whatever - changes were used in the work (which must be distributed under - Sections 1 and 2 above); and, if the work is an executable linked - with the Library, with the complete machine-readable "work that - uses the Library", as object code and/or source code, so that the - user can modify the Library and then relink to produce a modified - executable containing the modified Library. (It is understood - that the user who changes the contents of definitions files in the - Library will not necessarily be able to recompile the application - to use the modified definitions.) - - b) Accompany the work with a written offer, valid for at - least three years, to give the same user the materials - specified in Subsection 6a, above, for a charge no more - than the cost of performing this distribution. - - c) If distribution of the work is made by offering access to copy - from a designated place, offer equivalent access to copy the above - specified materials from the same place. - - d) Verify that the user has already received a copy of these - materials or that you have already sent this user a copy. - - For an executable, the required form of the "work that uses the -Library" must include any data and utility programs needed for -reproducing the executable from it. However, as a special exception, -the source code distributed need not include anything that is normally -distributed (in either source or binary form) with the major -components (compiler, kernel, and so on) of the operating system on -which the executable runs, unless that component itself accompanies -the executable. - - It may happen that this requirement contradicts the license -restrictions of other proprietary libraries that do not normally -accompany the operating system. Such a contradiction means you cannot -use both them and the Library together in an executable that you -distribute. - - 7. You may place library facilities that are a work based on the -Library side-by-side in a single library together with other library -facilities not covered by this License, and distribute such a combined -library, provided that the separate distribution of the work based on -the Library and of the other library facilities is otherwise -permitted, and provided that you do these two things: - - a) Accompany the combined library with a copy of the same work - based on the Library, uncombined with any other library - facilities. This must be distributed under the terms of the - Sections above. - - b) Give prominent notice with the combined library of the fact - that part of it is a work based on the Library, and explaining - where to find the accompanying uncombined form of the same work. - - 8. You may not copy, modify, sublicense, link with, or distribute -the Library except as expressly provided under this License. Any -attempt otherwise to copy, modify, sublicense, link with, or -distribute the Library is void, and will automatically terminate your -rights under this License. However, parties who have received copies, -or rights, from you under this License will not have their licenses -terminated so long as such parties remain in full compliance. - - 9. You are not required to accept this License, since you have not -signed it. However, nothing else grants you permission to modify or -distribute the Library or its derivative works. These actions are -prohibited by law if you do not accept this License. Therefore, by -modifying or distributing the Library (or any work based on the -Library), you indicate your acceptance of this License to do so, and -all its terms and conditions for copying, distributing or modifying -the Library or works based on it. - - 10. Each time you redistribute the Library (or any work based on the -Library), the recipient automatically receives a license from the -original licensor to copy, distribute, link with or modify the Library -subject to these terms and conditions. You may not impose any further -restrictions on the recipients' exercise of the rights granted herein. -You are not responsible for enforcing compliance by third parties to -this License. - - 11. If, as a consequence of a court judgment or allegation of patent -infringement or for any other reason (not limited to patent issues), -conditions are imposed on you (whether by court order, agreement or -otherwise) that contradict the conditions of this License, they do not -excuse you from the conditions of this License. If you cannot -distribute so as to satisfy simultaneously your obligations under this -License and any other pertinent obligations, then as a consequence you -may not distribute the Library at all. For example, if a patent -license would not permit royalty-free redistribution of the Library by -all those who receive copies directly or indirectly through you, then -the only way you could satisfy both it and this License would be to -refrain entirely from distribution of the Library. - -If any portion of this section is held invalid or unenforceable under any -particular circumstance, the balance of the section is intended to apply, -and the section as a whole is intended to apply in other circumstances. - -It is not the purpose of this section to induce you to infringe any -patents or other property right claims or to contest validity of any -such claims; this section has the sole purpose of protecting the -integrity of the free software distribution system which is -implemented by public license practices. Many people have made -generous contributions to the wide range of software distributed -through that system in reliance on consistent application of that -system; it is up to the author/donor to decide if he or she is willing -to distribute software through any other system and a licensee cannot -impose that choice. - -This section is intended to make thoroughly clear what is believed to -be a consequence of the rest of this License. - - 12. If the distribution and/or use of the Library is restricted in -certain countries either by patents or by copyrighted interfaces, the -original copyright holder who places the Library under this License may add -an explicit geographical distribution limitation excluding those countries, -so that distribution is permitted only in or among countries not thus -excluded. In such case, this License incorporates the limitation as if -written in the body of this License. - - 13. The Free Software Foundation may publish revised and/or new -versions of the Library General Public License from time to time. -Such new versions will be similar in spirit to the present version, -but may differ in detail to address new problems or concerns. - -Each version is given a distinguishing version number. If the Library -specifies a version number of this License which applies to it and -"any later version", you have the option of following the terms and -conditions either of that version or of any later version published by -the Free Software Foundation. If the Library does not specify a -license version number, you may choose any version ever published by -the Free Software Foundation. - - 14. If you wish to incorporate parts of the Library into other free -programs whose distribution conditions are incompatible with these, -write to the author to ask for permission. For software which is -copyrighted by the Free Software Foundation, write to the Free -Software Foundation; we sometimes make exceptions for this. Our -decision will be guided by the two goals of preserving the free status -of all derivatives of our free software and of promoting the sharing -and reuse of software generally. - - NO WARRANTY - - 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO -WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. -EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR -OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY -KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE -IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE -LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME -THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. - - 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN -WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY -AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU -FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR -CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE -LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING -RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A -FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF -SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH -DAMAGES. - - END OF TERMS AND CONDITIONS - - Appendix: How to Apply These Terms to Your New Libraries - - If you develop a new library, and you want it to be of the greatest -possible use to the public, we recommend making it free software that -everyone can redistribute and change. You can do so by permitting -redistribution under these terms (or, alternatively, under the terms of the -ordinary General Public License). - - To apply these terms, attach the following notices to the library. It is -safest to attach them to the start of each source file to most effectively -convey the exclusion of warranty; and each file should have at least the -"copyright" line and a pointer to where the full notice is found. - - - Copyright (C) - - This library is free software; you can redistribute it and/or - modify it under the terms of the GNU Library General Public - License as published by the Free Software Foundation; either - version 2 of the License, or (at your option) any later version. - - This library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Library General Public License for more details. - - You should have received a copy of the GNU Library General Public - License along with this library; if not, write to the Free - Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, - MA 02111-1307, USA - -Also add information on how to contact you by electronic and paper mail. - -You should also get your employer (if you work as a programmer) or your -school, if any, to sign a "copyright disclaimer" for the library, if -necessary. Here is a sample; alter the names: - - Yoyodyne, Inc., hereby disclaims all copyright interest in the - library `Frob' (a library for tweaking knobs) written by James Random Hacker. - - , 1 April 1990 - Ty Coon, President of Vice - -That's all there is to it! diff --git a/Makefile b/Makefile deleted file mode 100644 index 5683940e55..0000000000 --- a/Makefile +++ /dev/null @@ -1,671 +0,0 @@ -######################################################################### -# # -# Objective Caml # -# # -# Xavier Leroy, projet Cristal, INRIA Rocquencourt # -# # -# Copyright 1999 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### - -# $Id$ - -# The main Makefile - -include config/Makefile -include stdlib/StdlibModules - -CAMLC=boot/ocamlrun boot/ocamlc -nostdlib -I boot -CAMLOPT=boot/ocamlrun ./ocamlopt -nostdlib -I stdlib -COMPFLAGS=-warn-error A $(INCLUDES) -LINKFLAGS= - -CAMLYACC=boot/ocamlyacc -YACCFLAGS=-v -CAMLLEX=boot/ocamlrun boot/ocamllex -CAMLDEP=boot/ocamlrun tools/ocamldep -DEPFLAGS=$(INCLUDES) -CAMLRUN=byterun/ocamlrun -SHELL=/bin/sh -MKDIR=mkdir -p - -INCLUDES=-I utils -I parsing -I typing -I bytecomp -I asmcomp -I driver \ - -I toplevel - -UTILS=utils/misc.cmo utils/tbl.cmo utils/config.cmo \ - utils/clflags.cmo utils/terminfo.cmo utils/ccomp.cmo utils/warnings.cmo \ - utils/consistbl.cmo - -OPTUTILS=$(UTILS) - -PARSING=parsing/linenum.cmo parsing/location.cmo parsing/longident.cmo \ - parsing/syntaxerr.cmo parsing/parser.cmo \ - parsing/lexer.cmo parsing/parse.cmo parsing/printast.cmo - -TYPING=typing/ident.cmo typing/path.cmo \ - typing/primitive.cmo typing/types.cmo \ - typing/btype.cmo typing/oprint.cmo \ - typing/subst.cmo typing/predef.cmo \ - typing/datarepr.cmo typing/env.cmo \ - typing/typedtree.cmo typing/ctype.cmo \ - typing/printtyp.cmo typing/includeclass.cmo \ - typing/mtype.cmo typing/includecore.cmo \ - typing/includemod.cmo typing/parmatch.cmo \ - typing/typetexp.cmo typing/stypes.cmo typing/typecore.cmo \ - typing/typedecl.cmo typing/typeclass.cmo \ - typing/typemod.cmo - -COMP=bytecomp/lambda.cmo bytecomp/printlambda.cmo \ - bytecomp/typeopt.cmo bytecomp/switch.cmo bytecomp/matching.cmo \ - bytecomp/translobj.cmo bytecomp/translcore.cmo \ - bytecomp/translclass.cmo bytecomp/translmod.cmo \ - bytecomp/simplif.cmo bytecomp/runtimedef.cmo - -BYTECOMP=bytecomp/meta.cmo bytecomp/instruct.cmo bytecomp/bytegen.cmo \ - bytecomp/printinstr.cmo bytecomp/opcodes.cmo bytecomp/emitcode.cmo \ - bytecomp/bytesections.cmo bytecomp/dll.cmo bytecomp/symtable.cmo \ - bytecomp/bytelink.cmo bytecomp/bytelibrarian.cmo bytecomp/bytepackager.cmo - -ASMCOMP=asmcomp/arch.cmo asmcomp/cmm.cmo asmcomp/printcmm.cmo \ - asmcomp/reg.cmo asmcomp/mach.cmo asmcomp/proc.cmo \ - asmcomp/clambda.cmo asmcomp/compilenv.cmo \ - asmcomp/closure.cmo asmcomp/cmmgen.cmo \ - asmcomp/printmach.cmo asmcomp/selectgen.cmo asmcomp/selection.cmo \ - asmcomp/comballoc.cmo asmcomp/liveness.cmo \ - asmcomp/spill.cmo asmcomp/split.cmo \ - asmcomp/interf.cmo asmcomp/coloring.cmo \ - asmcomp/reloadgen.cmo asmcomp/reload.cmo \ - asmcomp/printlinear.cmo asmcomp/linearize.cmo \ - asmcomp/schedgen.cmo asmcomp/scheduling.cmo \ - asmcomp/emitaux.cmo asmcomp/emit.cmo asmcomp/asmgen.cmo \ - asmcomp/asmlink.cmo asmcomp/asmlibrarian.cmo asmcomp/asmpackager.cmo - -DRIVER=driver/pparse.cmo driver/errors.cmo driver/compile.cmo \ - driver/main_args.cmo driver/main.cmo - -OPTDRIVER= driver/pparse.cmo driver/opterrors.cmo driver/optcompile.cmo \ - driver/optmain.cmo - -TOPLEVEL=driver/pparse.cmo driver/errors.cmo driver/compile.cmo \ - toplevel/genprintval.cmo toplevel/toploop.cmo \ - toplevel/trace.cmo toplevel/topdirs.cmo toplevel/topmain.cmo - -TOPLEVELLIB=toplevel/toplevellib.cma -TOPLEVELSTART=toplevel/topstart.cmo - -COMPOBJS=$(UTILS) $(PARSING) $(TYPING) $(COMP) $(BYTECOMP) $(DRIVER) - -TOPLIB=$(UTILS) $(PARSING) $(TYPING) $(COMP) $(BYTECOMP) $(TOPLEVEL) - -TOPOBJS=$(TOPLEVELLIB) $(TOPLEVELSTART) - -OPTOBJS=$(OPTUTILS) $(PARSING) $(TYPING) $(COMP) $(ASMCOMP) $(OPTDRIVER) - -EXPUNGEOBJS=utils/misc.cmo utils/tbl.cmo \ - utils/config.cmo utils/clflags.cmo \ - typing/ident.cmo typing/path.cmo typing/types.cmo typing/btype.cmo \ - typing/predef.cmo bytecomp/runtimedef.cmo bytecomp/bytesections.cmo \ - bytecomp/dll.cmo bytecomp/symtable.cmo toplevel/expunge.cmo - -PERVASIVES=$(STDLIB_MODULES) outcometree topdirs toploop - -# For users who don't read the INSTALL file -defaultentry: - @echo "Please refer to the installation instructions in file INSTALL." - @echo "If you've just unpacked the distribution, something like" - @echo " ./configure" - @echo " make world" - @echo " make opt" - @echo " make install" - @echo "should work. But see the file INSTALL for more details." - -# Recompile the system using the bootstrap compiler -all: runtime ocamlc ocamllex ocamlyacc ocamltools library ocaml \ - otherlibraries camlp4out $(DEBUGGER) ocamldoc - -# The compilation of ocaml will fail if the runtime has changed. -# Never mind, just do make bootstrap to reach fixpoint again. - -# Compile everything the first time -world: coldstart all - -# Compile also native code compiler and libraries, fast -world.opt: coldstart opt.opt - -# Core bootstrapping cycle -coreboot: -# Save the original bootstrap compiler - $(MAKE) backup -# Promote the new compiler but keep the old runtime -# This compiler runs on boot/ocamlrun and produces bytecode for -# byterun/ocamlrun - $(MAKE) promote-cross -# Rebuild ocamlc and ocamllex (run on byterun/ocamlrun) - $(MAKE) partialclean - $(MAKE) ocamlc ocamllex -# Rebuild the library (using byterun/ocamlrun ./ocamlc) - $(MAKE) library-cross -# Promote the new compiler and the new runtime - $(MAKE) promote -# Rebuild the core system - $(MAKE) partialclean - $(MAKE) core -# Check if fixpoint reached - $(MAKE) compare - -# Bootstrap and rebuild the whole system. -bootstrap: - $(MAKE) coreboot - $(MAKE) all - $(MAKE) compare - -LIBFILES=stdlib.cma std_exit.cmo *.cmi camlheader - -# Start up the system from the distribution compiler -coldstart: - cd byterun; $(MAKE) all - cp byterun/ocamlrun$(EXE) boot/ocamlrun$(EXE) - cd yacc; $(MAKE) all - cp yacc/ocamlyacc$(EXE) boot/ocamlyacc$(EXE) - cd stdlib; $(MAKE) COMPILER=../boot/ocamlc all - cd stdlib; cp $(LIBFILES) ../boot - if test -f boot/libcamlrun.a; then :; else \ - ln -s ../byterun/libcamlrun.a boot/libcamlrun.a; fi - if test -d stdlib/caml; then :; else \ - ln -s ../byterun stdlib/caml; fi - -# Build the core system: the minimum needed to make depend and bootstrap -core : runtime ocamlc ocamllex ocamlyacc ocamltools library - -# Save the current bootstrap compiler -MAXSAVED=boot/Saved/Saved.prev/Saved.prev/Saved.prev/Saved.prev/Saved.prev -backup: - if test -d boot/Saved; then : ; else mkdir boot/Saved; fi - if test -d $(MAXSAVED); then rm -r $(MAXSAVED); else : ; fi - mv boot/Saved boot/Saved.prev - mkdir boot/Saved - mv boot/Saved.prev boot/Saved/Saved.prev - cp boot/ocamlrun$(EXE) boot/Saved - mv boot/ocamlc boot/ocamllex boot/ocamlyacc$(EXE) boot/Saved - cd boot; cp $(LIBFILES) Saved - -# Promote the newly compiled system to the rank of cross compiler -# (Runs on the old runtime, produces code for the new runtime) -promote-cross: - cp ocamlc boot/ocamlc - cp lex/ocamllex boot/ocamllex - cp yacc/ocamlyacc$(EXE) boot/ocamlyacc$(EXE) - cd stdlib; cp $(LIBFILES) ../boot - -# Promote the newly compiled system to the rank of bootstrap compiler -# (Runs on the new runtime, produces code for the new runtime) -promote: promote-cross - cp byterun/ocamlrun$(EXE) boot/ocamlrun$(EXE) - -# Restore the saved bootstrap compiler if a problem arises -restore: - mv boot/Saved/* boot - rmdir boot/Saved - mv boot/Saved.prev boot/Saved - -# Check if fixpoint reached -compare: - @if cmp boot/ocamlc ocamlc && cmp boot/ocamllex lex/ocamllex; \ - then echo "Fixpoint reached, bootstrap succeeded."; \ - else echo "Fixpoint not reached, try one more bootstrapping cycle."; \ - fi - -# Remove old bootstrap compilers -cleanboot: - rm -rf boot/Saved/Saved.prev/* - -# Compile the native-code compiler -opt-core:runtimeopt ocamlopt libraryopt -opt: runtimeopt ocamlopt libraryopt otherlibrariesopt camlp4opt - -# Native-code versions of the tools -opt.opt: checkstack core ocaml opt-core ocamlc.opt otherlibraries camlp4out \ - $(DEBUGGER) ocamldoc ocamlopt.opt otherlibrariesopt \ - camlp4opt ocamllex.opt ocamltoolsopt.opt camlp4optopt ocamldoc.opt - -# Installation -install: FORCE - if test -d $(BINDIR); then : ; else $(MKDIR) $(BINDIR); fi - if test -d $(LIBDIR); then : ; else $(MKDIR) $(LIBDIR); fi - if test -d $(STUBLIBDIR); then : ; else $(MKDIR) $(LIBDIR)/stublibs; fi - if test -d $(MANDIR)/man$(MANEXT); then : ; else $(MKDIR) $(MANDIR)/man$(MANEXT); fi - cd $(LIBDIR); rm -f dllbigarray.so dlllabltk.so dllnums.so \ - dllthreads.so dllunix.so dllgraphics.so dllmldbm.so dllstr.so \ - dlltkanim.so - cd byterun; $(MAKE) install - echo "$(STUBLIBDIR)" > $(LIBDIR)/ld.conf - echo "$(LIBDIR)" >> $(LIBDIR)/ld.conf - cp ocamlc $(BINDIR)/ocamlc$(EXE) - cp ocaml $(BINDIR)/ocaml$(EXE) - cd stdlib; $(MAKE) install - cp lex/ocamllex $(BINDIR)/ocamllex$(EXE) - cp yacc/ocamlyacc$(EXE) $(BINDIR)/ocamlyacc$(EXE) - cp toplevel/toplevellib.cma $(LIBDIR)/toplevellib.cma - cp expunge $(LIBDIR)/expunge$(EXE) - cp typing/outcometree.cmi typing/outcometree.mli $(LIBDIR) - cp toplevel/topstart.cmo $(LIBDIR) - cp toplevel/toploop.cmi toplevel/topdirs.cmi toplevel/topmain.cmi $(LIBDIR) - cd tools; $(MAKE) install - -cd man; $(MAKE) install - for i in $(OTHERLIBRARIES); do \ - (cd otherlibs/$$i; $(MAKE) install) || exit $$?; \ - done - cd ocamldoc; $(MAKE) install - if test -f ocamlopt; then $(MAKE) installopt; else :; fi - cd camlp4; $(MAKE) install BINDIR=$(BINDIR) LIBDIR=$(LIBDIR) MANDIR=$(MANDIR) - if test -f debugger/ocamldebug; then (cd debugger; $(MAKE) install); \ - else :; fi - -# Installation of the native-code compiler -installopt: - cd asmrun; $(MAKE) install - cp ocamlopt $(BINDIR)/ocamlopt$(EXE) - cd stdlib; $(MAKE) installopt - cd ocamldoc; $(MAKE) installopt - for i in $(OTHERLIBRARIES); do (cd otherlibs/$$i; $(MAKE) installopt) || exit $$?; done - if test -f ocamlc.opt; \ - then cp ocamlc.opt $(BINDIR)/ocamlc.opt$(EXE); else :; fi - if test -f ocamlopt.opt; \ - then cp ocamlopt.opt $(BINDIR)/ocamlopt.opt$(EXE); else :; fi - if test -f lex/ocamllex.opt; \ - then cp lex/ocamllex.opt $(BINDIR)/ocamllex.opt$(EXE); else :; fi - -clean:: partialclean - -# The compiler - -ocamlc: $(COMPOBJS) - $(CAMLC) $(LINKFLAGS) -o ocamlc $(COMPOBJS) - @sed -e 's|@compiler@|$$topdir/boot/ocamlrun $$topdir/ocamlc|' \ - driver/ocamlcomp.sh.in > ocamlcomp.sh - @chmod +x ocamlcomp.sh - -partialclean:: - rm -f ocamlc ocamlcomp.sh - -# The native-code compiler - -ocamlopt: $(OPTOBJS) - $(CAMLC) $(LINKFLAGS) -o ocamlopt $(OPTOBJS) - @sed -e 's|@compiler@|$$topdir/boot/ocamlrun $$topdir/ocamlopt|' \ - driver/ocamlcomp.sh.in > ocamlcompopt.sh - @chmod +x ocamlcompopt.sh - -partialclean:: - rm -f ocamlopt ocamlcompopt.sh - -# The toplevel - -ocaml: $(TOPOBJS) expunge - $(CAMLC) $(LINKFLAGS) -linkall -o ocaml.tmp $(TOPOBJS) - - $(CAMLRUN) ./expunge ocaml.tmp ocaml $(PERVASIVES) - rm -f ocaml.tmp - -toplevel/toplevellib.cma: $(TOPLIB) - $(CAMLC) -a -o $@ $(TOPLIB) - -partialclean:: - rm -f ocaml toplevel/toplevellib.cma - -# The configuration file - -utils/config.ml: utils/config.mlp config/Makefile - @rm -f utils/config.ml - sed -e 's|%%LIBDIR%%|$(LIBDIR)|' \ - -e 's|%%BYTERUN%%|$(BINDIR)/ocamlrun|' \ - -e 's|%%CCOMPTYPE%%|cc|' \ - -e 's|%%BYTECC%%|$(BYTECC) $(BYTECCCOMPOPTS) $(SHAREDCCCOMPOPTS)|' \ - -e 's|%%BYTELINK%%|$(BYTECC) $(BYTECCLINKOPTS)|' \ - -e 's|%%NATIVECC%%|$(NATIVECC) $(NATIVECCCOMPOPTS)|' \ - -e 's|%%NATIVELINK%%|$(NATIVECC) $(NATIVECCLINKOPTS)|' \ - -e 's|%%PARTIALLD%%|ld -r $(NATIVECCLINKOPTS)|' \ - -e 's|%%PACKLD%%|ld -r $(NATIVECCLINKOPTS)|' \ - -e 's|%%BYTECCLIBS%%|$(BYTECCLIBS)|' \ - -e 's|%%NATIVECCLIBS%%|$(NATIVECCLIBS)|' \ - -e 's|%%RANLIBCMD%%|$(RANLIBCMD)|' \ - -e 's|%%BINUTILS_NM%%|$(BINUTILS_NM)|' \ - -e 's|%%CC_PROFILE%%|$(CC_PROFILE)|' \ - -e 's|%%BINUTILS_OBJCOPY%%|$(BINUTILS_OBJCOPY)|' \ - -e 's|%%ARCH%%|$(ARCH)|' \ - -e 's|%%MODEL%%|$(MODEL)|' \ - -e 's|%%SYSTEM%%|$(SYSTEM)|' \ - -e 's|%%EXT_OBJ%%|.o|' \ - -e 's|%%EXT_ASM%%|.s|' \ - -e 's|%%EXT_LIB%%|.a|' \ - -e 's|%%EXT_DLL%%|.so|' \ - utils/config.mlp > utils/config.ml - @chmod -w utils/config.ml - -partialclean:: - rm -f utils/config.ml - -beforedepend:: utils/config.ml - -# The parser - -parsing/parser.mli parsing/parser.ml: parsing/parser.mly - $(CAMLYACC) $(YACCFLAGS) parsing/parser.mly - -partialclean:: - rm -f parsing/parser.mli parsing/parser.ml parsing/parser.output - -beforedepend:: parsing/parser.mli parsing/parser.ml - -# The lexer - -parsing/lexer.ml: parsing/lexer.mll - $(CAMLLEX) parsing/lexer.mll - -partialclean:: - rm -f parsing/lexer.ml - -beforedepend:: parsing/lexer.ml - -# The auxiliary lexer for counting line numbers - -parsing/linenum.ml: parsing/linenum.mll - $(CAMLLEX) parsing/linenum.mll - -partialclean:: - rm -f parsing/linenum.ml - -beforedepend:: parsing/linenum.ml - -# The bytecode compiler compiled with the native-code compiler - -ocamlc.opt: $(COMPOBJS:.cmo=.cmx) - cd asmrun; $(MAKE) meta.o dynlink.o - $(CAMLOPT) $(LINKFLAGS) -ccopt "$(BYTECCLINKOPTS)" -o ocamlc.opt \ - $(COMPOBJS:.cmo=.cmx) \ - asmrun/meta.o asmrun/dynlink.o -cclib "$(BYTECCLIBS)" - @sed -e 's|@compiler@|$$topdir/ocamlc.opt|' \ - driver/ocamlcomp.sh.in > ocamlcomp.sh - @chmod +x ocamlcomp.sh - -partialclean:: - rm -f ocamlc.opt - -# The native-code compiler compiled with itself - -ocamlopt.opt: $(OPTOBJS:.cmo=.cmx) - $(CAMLOPT) $(LINKFLAGS) -o ocamlopt.opt $(OPTOBJS:.cmo=.cmx) - @sed -e 's|@compiler@|$$topdir/ocamlopt.opt|' \ - driver/ocamlcomp.sh.in > ocamlcompopt.sh - @chmod +x ocamlcompopt.sh - -partialclean:: - rm -f ocamlopt.opt - -$(OPTOBJS:.cmo=.cmx): ocamlopt - -# The numeric opcodes - -bytecomp/opcodes.ml: byterun/instruct.h - sed -n -e '/^enum/p' -e 's/,//g' -e '/^ /p' byterun/instruct.h | \ - awk -f tools/make-opcodes > bytecomp/opcodes.ml - -partialclean:: - rm -f bytecomp/opcodes.ml - -beforedepend:: bytecomp/opcodes.ml - -# The predefined exceptions and primitives - -byterun/primitives: - cd byterun; $(MAKE) primitives - -bytecomp/runtimedef.ml: byterun/primitives byterun/fail.h - (echo 'let builtin_exceptions = [|'; \ - sed -n -e 's|.*/\* \("[A-Za-z_]*"\) \*/$$| \1;|p' byterun/fail.h | \ - sed -e '$$s/;$$//'; \ - echo '|]'; \ - echo 'let builtin_primitives = [|'; \ - sed -e 's/.*/ "&";/' -e '$$s/;$$//' byterun/primitives; \ - echo '|]') > bytecomp/runtimedef.ml - -partialclean:: - rm -f bytecomp/runtimedef.ml - -beforedepend:: bytecomp/runtimedef.ml - -# Choose the right machine-dependent files - -asmcomp/arch.ml: asmcomp/$(ARCH)/arch.ml - ln -s $(ARCH)/arch.ml asmcomp/arch.ml - -partialclean:: - rm -f asmcomp/arch.ml - -beforedepend:: asmcomp/arch.ml - -asmcomp/proc.ml: asmcomp/$(ARCH)/proc.ml - ln -s $(ARCH)/proc.ml asmcomp/proc.ml - -partialclean:: - rm -f asmcomp/proc.ml - -beforedepend:: asmcomp/proc.ml - -asmcomp/selection.ml: asmcomp/$(ARCH)/selection.ml - ln -s $(ARCH)/selection.ml asmcomp/selection.ml - -partialclean:: - rm -f asmcomp/selection.ml - -beforedepend:: asmcomp/selection.ml - -asmcomp/reload.ml: asmcomp/$(ARCH)/reload.ml - ln -s $(ARCH)/reload.ml asmcomp/reload.ml - -partialclean:: - rm -f asmcomp/reload.ml - -beforedepend:: asmcomp/reload.ml - -asmcomp/scheduling.ml: asmcomp/$(ARCH)/scheduling.ml - ln -s $(ARCH)/scheduling.ml asmcomp/scheduling.ml - -partialclean:: - rm -f asmcomp/scheduling.ml - -beforedepend:: asmcomp/scheduling.ml - -# Preprocess the code emitters - -asmcomp/emit.ml: asmcomp/$(ARCH)/emit.mlp tools/cvt_emit - $(CAMLRUN) tools/cvt_emit < asmcomp/$(ARCH)/emit.mlp > asmcomp/emit.ml \ - || { rm -f asmcomp/emit.ml; exit 2; } - -partialclean:: - rm -f asmcomp/emit.ml - -beforedepend:: asmcomp/emit.ml - -tools/cvt_emit: tools/cvt_emit.mll - cd tools; $(MAKE) CAMLC="../$(CAMLRUN) ../ocamlc -I ../stdlib" cvt_emit - -# The "expunge" utility - -expunge: $(EXPUNGEOBJS) - $(CAMLC) $(LINKFLAGS) -o expunge $(EXPUNGEOBJS) - -partialclean:: - rm -f expunge - -# The runtime system for the bytecode compiler - -runtime: - cd byterun; $(MAKE) all - if test -f stdlib/libcamlrun.a; then :; else \ - ln -s ../byterun/libcamlrun.a stdlib/libcamlrun.a; fi -clean:: - cd byterun; $(MAKE) clean - rm -f stdlib/libcamlrun.a - rm -f stdlib/caml -alldepend:: - cd byterun; $(MAKE) depend - -# The runtime system for the native-code compiler - -runtimeopt: - cd asmrun; $(MAKE) all - if test -f stdlib/libasmrun.a; then :; else \ - ln -s ../asmrun/libasmrun.a stdlib/libasmrun.a; fi -clean:: - cd asmrun; $(MAKE) clean - rm -f stdlib/libasmrun.a -alldepend:: - cd asmrun; $(MAKE) depend - -# The library - -library: ocamlc - cd stdlib; $(MAKE) all -library-cross: - cd stdlib; $(MAKE) RUNTIME=../byterun/ocamlrun all -libraryopt: - cd stdlib; $(MAKE) allopt -partialclean:: - cd stdlib; $(MAKE) clean -alldepend:: - cd stdlib; $(MAKE) depend - -# The lexer and parser generators - -ocamllex: ocamlyacc ocamlc - cd lex; $(MAKE) all -ocamllex.opt: ocamlopt - cd lex; $(MAKE) allopt -partialclean:: - cd lex; $(MAKE) clean -alldepend:: - cd lex; $(MAKE) depend - -ocamlyacc: - cd yacc; $(MAKE) all -clean:: - cd yacc; $(MAKE) clean - -# Tools - -ocamltools: ocamlc ocamlyacc ocamllex - cd tools; $(MAKE) all -ocamltoolsopt.opt: ocamlc.opt ocamlyacc ocamllex - cd tools; $(MAKE) opt.opt -partialclean:: - cd tools; $(MAKE) clean -alldepend:: - cd tools; $(MAKE) depend - -# OCamldoc - -ocamldoc: ocamlc ocamlyacc ocamllex - cd ocamldoc && $(MAKE) all -ocamldoc.opt: ocamlc.opt ocamlyacc ocamllex - cd ocamldoc && $(MAKE) opt.opt -partialclean:: - cd ocamldoc && $(MAKE) clean -alldepend:: - cd ocamldoc && $(MAKE) depend - -# The extra libraries - -otherlibraries: - for i in $(OTHERLIBRARIES); do \ - (cd otherlibs/$$i; $(MAKE) RUNTIME=$(RUNTIME) all) || exit $$?; \ - done -otherlibrariesopt: - for i in $(OTHERLIBRARIES); do \ - (cd otherlibs/$$i; $(MAKE) allopt) || exit $$?; \ - done -partialclean:: - for i in $(OTHERLIBRARIES); do \ - (cd otherlibs/$$i; $(MAKE) partialclean); \ - done -clean:: - for i in $(OTHERLIBRARIES); do (cd otherlibs/$$i; $(MAKE) clean); done -alldepend:: - for i in $(OTHERLIBRARIES); do (cd otherlibs/$$i; $(MAKE) depend); done - -# The replay debugger - -ocamldebugger: ocamlc ocamlyacc ocamllex - cd debugger; $(MAKE) all -partialclean:: - cd debugger; $(MAKE) clean -alldepend:: - cd debugger; $(MAKE) depend - -# Camlp4 - -camlp4out: ocamlc - cd camlp4; $(MAKE) all -camlp4opt: ocamlopt - cd camlp4; $(MAKE) opt -camlp4optopt: ocamlopt - cd camlp4; $(MAKE) opt.opt -partialclean:: - cd camlp4; $(MAKE) clean -alldepend:: - cd camlp4; $(MAKE) depend - -# Check that the stack limit is reasonable. - -checkstack: - @if $(BYTECC) -o tools/checkstack tools/checkstack.c; \ - then tools/checkstack; \ - else :; \ - fi - @rm -f tools/checkstack - -# Make MacOS X package - -package-macosx: FORCE - make BINDIR="`pwd`"/package-macosx/root$(BINDIR) \ - LIBDIR="`pwd`"/package-macosx/root$(LIBDIR) \ - MANDIR="`pwd`"/package-macosx/root$(MANDIR) install - tools/make-package-macosx -clean:: - rm -rf package-macosx/root package-macosx/*.pkg package-macosx/*.dmg - -# Default rules - -.SUFFIXES: .ml .mli .cmo .cmi .cmx - -.ml.cmo: - $(CAMLC) $(COMPFLAGS) -c $< - -.mli.cmi: - $(CAMLC) $(COMPFLAGS) -c $< - -.ml.cmx: - $(CAMLOPT) $(COMPFLAGS) -c $< - -partialclean:: - rm -f utils/*.cm[iox] utils/*.[so] utils/*~ - rm -f parsing/*.cm[iox] parsing/*.[so] parsing/*~ - rm -f typing/*.cm[iox] typing/*.[so] typing/*~ - rm -f bytecomp/*.cm[iox] bytecomp/*.[so] bytecomp/*~ - rm -f asmcomp/*.cm[iox] asmcomp/*.[so] asmcomp/*~ - rm -f driver/*.cm[iox] driver/*.[so] driver/*~ - rm -f toplevel/*.cm[iox] toplevel/*.[so] toplevel/*~ - rm -f tools/*.cm[iox] tools/*.[so] tools/*~ - rm -f *~ - -depend: beforedepend - (for d in utils parsing typing bytecomp asmcomp driver toplevel; \ - do $(CAMLDEP) $(DEPFLAGS) $$d/*.mli $$d/*.ml; \ - done) > .depend - -alldepend:: depend - -FORCE: - -include .depend diff --git a/Makefile.Mac b/Makefile.Mac deleted file mode 100644 index 9fa3f69b66..0000000000 --- a/Makefile.Mac +++ /dev/null @@ -1,488 +0,0 @@ -######################################################################### -# # -# Objective Caml # -# # -# Damien Doligez, projet Para, INRIA Rocquencourt # -# # -# Copyright 1999 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### - -# $Id$ - -# The main Makefile - -MacVersion = "Mac{MAJOR}.{MINOR}.{BUGFIX}{STAGE}{REV}" - -CAMLC = :boot:ocamlrun :boot:ocamlc -I :boot: -COMPFLAGS = {INCLUDES} -LINKFLAGS = -CAMLYACC = :boot:ocamlyacc -YACCFLAGS = -CAMLLEX = :boot:ocamlrun :boot:ocamllex -CAMLDEP = :boot:ocamlrun :tools:ocamldep -DEPFLAGS = {INCLUDES} -CAMLRUN = :byterun:ocamlrun - -INCLUDES = -I :utils: -I :parsing: -I :typing: -I :bytecomp: ¶ - -I :driver: -I :toplevel: - -UTILS = :utils:misc.cmo :utils:tbl.cmo :utils:config.cmo ¶ - :utils:clflags.cmo :utils:terminfo.cmo :utils:ccomp.cmo ¶ - :utils:warnings.cmo - -PARSING = :parsing:linenum.cmo :parsing:location.cmo :parsing:longident.cmo ¶ - :parsing:syntaxerr.cmo :parsing:parser.cmo ¶ - :parsing:lexer.cmo :parsing:parse.cmo :parsing:printast.cmo - -TYPING = :typing:ident.cmo :typing:path.cmo ¶ - :typing:primitive.cmo :typing:types.cmo ¶ - :typing:btype.cmo ¶ - :typing:subst.cmo :typing:predef.cmo ¶ - :typing:datarepr.cmo :typing:env.cmo ¶ - :typing:typedtree.cmo ¶ - :typing:ctype.cmo :typing:printtyp.cmo ¶ - :typing:includeclass.cmo ¶ - :typing:mtype.cmo :typing:includecore.cmo ¶ - :typing:includemod.cmo :typing:parmatch.cmo ¶ - :typing:typetexp.cmo :typing:typecore.cmo ¶ - :typing:typedecl.cmo :typing:typeclass.cmo ¶ - :typing:typemod.cmo - -COMP = :bytecomp:lambda.cmo :bytecomp:printlambda.cmo ¶ - :bytecomp:typeopt.cmo :bytecomp:switch.cmo :bytecomp:matching.cmo ¶ - :bytecomp:translobj.cmo :bytecomp:translcore.cmo ¶ - :bytecomp:translclass.cmo :bytecomp:translmod.cmo ¶ - :bytecomp:simplif.cmo :bytecomp:runtimedef.cmo - -BYTECOMP = :bytecomp:meta.cmo :bytecomp:instruct.cmo :bytecomp:bytegen.cmo ¶ - :bytecomp:printinstr.cmo :bytecomp:opcodes.cmo :bytecomp:emitcode.cmo ¶ - :bytecomp:bytesections.cmo :bytecomp:dll.cmo ¶ - :bytecomp:symtable.cmo :bytecomp:bytelink.cmo :bytecomp:bytelibrarian.cmo - -DRIVER = :driver:errors.cmo :driver:compile.cmo :driver:main_args.cmo ¶ - :driver:main.cmo - -TOPLEVEL = :driver:errors.cmo :driver:compile.cmo ¶ - :toplevel:genprintval.cmo :toplevel:toploop.cmo ¶ - :toplevel:trace.cmo :toplevel:topdirs.cmo - -TOPLEVELMAIN = :toplevel:topmain.cmo - -COMPOBJS = {UTILS} {PARSING} {TYPING} {COMP} {BYTECOMP} {DRIVER} - -TOPLIB = {UTILS} {PARSING} {TYPING} {COMP} {BYTECOMP} {TOPLEVEL} - -EXPUNGEOBJS = :utils:misc.cmo :utils:tbl.cmo ¶ - :utils:config.cmo :utils:clflags.cmo ¶ - :typing:ident.cmo :typing:path.cmo ¶ - :typing:types.cmo :typing:btype.cmo :typing:predef.cmo ¶ - :bytecomp:runtimedef.cmo :bytecomp:bytesections.cmo ¶ - :bytecomp:dll.cmo :bytecomp:symtable.cmo ¶ - :toplevel:expunge.cmo - -PERVASIVES = arg array buffer callback char digest filename format gc hashtbl ¶ - lexing list map obj parsing pervasives printexc printf queue random ¶ - set sort stack string stream sys oo genlex topdirs toploop weak lazy ¶ - marshal int32 int64 nativeint outcometree - -# Recompile the system using the bootstrap compiler -all Ä runtime ocamlc ocamllex ocamlyacc ocamltools library ocaml ¶ - otherlibraries camlp4out maccaml - -# The compilation of ocaml will fail if the runtime has changed. -# Never mind, just do make bootstrap to reach fixpoint again. - -# Compile everything the first time -world Ä - domake coldstart - domake all - -# Complete bootstrapping cycle -bootstrap Ä - # Save the original bootstrap compiler - domake backup - # Promote the new compiler but keep the old runtime - # This compiler runs on :boot:ocamlrun and produces bytecode for - # :byterun:ocamlrun - domake promote-cross - # Rebuild ocamlc and ocamllex (run on :byterun:ocamlrun) - domake partialclean - domake ocamlc ocamllex - # Rebuild the library (using :byterun:ocamlrun :ocamlc) - domake library-cross - # Promote the new compiler and the new runtime - domake promote - # Rebuild everything, including ocaml and the tools - domake partialclean - domake all - # Check if fixpoint reached - domake compare - -LIBFILES = :stdlib.cma :std_exit.cmo :Å.cmi camlheader - -# Start up the system from the distribution compiler -coldstart Ä - directory :byterun; domake all; directory :: - duplicate -y :byterun:ocamlrun :boot:ocamlrun - directory :yacc; domake all; directory :: - duplicate -y :yacc:ocamlyacc :boot:ocamlyacc - directory :stdlib - domake -d COMPILER=::boot:ocamlc all - duplicate -y {LIBFILES} ::boot: - directory :: - -# Build the core system: the minimum needed to make depend and bootstrap -core Ä runtime ocamlc ocamllex ocamlyacc ocamltools library - -# Save the current bootstrap compiler -backup Ä - if `exists -d :boot:Saved:` == "" - newfolder :boot:Saved: - end - move :boot:Saved: :boot:Saved.prev: - newfolder :boot:Saved: - move :boot:Saved.prev: :boot:Saved:Saved.prev: - duplicate -y :boot:ocamlrun :boot:Saved: - move :boot:ocamlc :boot:ocamllex :boot:ocamlyacc :boot:Saved: - directory :boot; duplicate -y {LIBFILES} :Saved:; directory :: - -# Promote the newly compiled system to the rank of cross compiler -# (Runs on the old runtime, produces code for the new runtime) -promote-cross Ä - duplicate -y :ocamlc :boot:ocamlc - duplicate -y :lex:ocamllex :boot:ocamllex - duplicate -y :yacc:ocamlyacc :boot:ocamlyacc - directory :stdlib - duplicate -y {LIBFILES} ::boot: || set status 0 - directory :: - -# Promote the newly compiled system to the rank of bootstrap compiler -# (Runs on the new runtime, produces code for the new runtime) -promote Ä promote-cross - duplicate -y :byterun:ocamlrun :boot:ocamlrun - -clean ÄÄ - delete -i :boot:Å.cm[aio] || set status 0 - delete -i :boot:camlheader :boot:ocamlrun :boot:ocamlyacc - -# Restore the saved bootstrap compiler if a problem arises -restore Ä - move -y :boot:Saved:Å :boot: - delete -y :boot:Saved: - move -y :boot:Saved.prev: :boot:Saved: - -# Check if fixpoint reached -compare Ä - set exit 0 - equal -q :boot:ocamlc :ocamlc && equal -q :boot:ocamllex :lex:ocamllex - if {status} - echo "¶nFixpoint not reached, try one more bootstrapping cycle.¶n" - else - echo "¶nFixpoint reached, bootstrap succeeded.¶n" - end - -# Remove old bootstrap compilers -cleanboot Ä - delete -i -y :boot:Saved:Saved.prev:Å || set status 0 - - -install Ä $OutOfDate - flush - for i in "{BINDIR}" "{LIBDIR}" "{APPLIDIR}" "{APPLIDIR}stdlib:" - if "`exists -d "{i}"`" == "" - newfolder "{i}" - end - end - directory :byterun: - domake install - directory :: - duplicate -y :ocamlc "{BINDIR}ocamlc" - duplicate -y :ocaml "{BINDIR}ocaml" - directory :stdlib: - domake install - directory :: - duplicate -y :lex:ocamllex "{BINDIR}ocamllex" - duplicate -y :yacc:ocamlyacc "{BINDIR}ocamlyacc" - duplicate -y toplevellib.cma expunge "{LIBDIR}" - duplicate -y :typing:outcometree.cmi :typing:outcometree.mli "{LIBDIR}" - duplicate -y :toplevel:topmain.cmo "{LIBDIR}topmain.cmo" - duplicate -y :toplevel:toploop.cmi :toplevel:topdirs.cmi "{LIBDIR}" - directory :tools: - domake install - directory :: - directory :camlp4: - execute :config:config.mpw - domake install -d LIBDIR="{LIBDIR}camlp4:" - directory :: - duplicate -y :man:ocaml.help "{HELPFILE}" - for i in {OTHERLIBRARIES} - directory :otherlibs:{i} - domake install - directory ::: - end - duplicate -y "{LIBDIR}"Å "{APPLIDIR}stdlib:" - duplicate -y :test:Moretest:graph_example.ml "{APPLIDIR}" - directory :maccaml: - domake install - directory :: - -clean ÄÄ partialclean - - -# The compiler - -ocamlc Ä {COMPOBJS} - {CAMLC} {LINKFLAGS} -o ocamlc {COMPOBJS} - -partialclean ÄÄ - delete -i ocamlc - - -# The toplevel - -ocaml Ä toplevellib.cma {TOPLEVELMAIN} expunge - {CAMLC} {LINKFLAGS} -linkall -o ocaml.tmp toplevellib.cma {TOPLEVELMAIN} - {CAMLRUN} :expunge ocaml.tmp ocaml {PERVASIVES} || set status 0 - delete -i ocaml.tmp - -toplevellib.cma Ä {TOPLIB} - {CAMLC} -a -o toplevellib.cma {TOPLIB} - -partialclean ÄÄ - delete -i ocaml toplevellib.cma - - -# The configuration file - -:utils:config.ml Ä :utils:config.mlp :config:config.Mac - delete -i :utils:config.ml - streamedit -e "/let version =/ replace /¶¶¶"°/ ¶"/{MacVersion}¶¶¶"¶"" ¶ - -e "1,$ replace /%%BYTERUN%%/ ¶"{BINDIR}ocamlrun¶"" ¶ - -e "1,$ replace /%%LIBDIR%%/ ¶"{LIBDIR}¶"" ¶ - -e "1,$ replace /%%EXT_OBJ%%/ '.o'" ¶ - -e "1,$ replace /%%EXT_LIB%%/ '.x'" ¶ - :utils:config.mlp > :utils:config.ml - -partialclean ÄÄ - delete -i :utils:config.ml - -beforedepend ÄÄ :utils:config.ml - - -# The parser - -:parsing:parser.mli Ä :parsing:parser.ml - echo -n - -:parsing:parser.ml Ä :parsing:parser.mly - {CAMLYACC} {YACCFLAGS} :parsing:parser.mly - -partialclean ÄÄ - delete -i :parsing:parser.mli :parsing:parser.ml :parsing:parser.output - -beforedepend ÄÄ :parsing:parser.mli :parsing:parser.ml - - -# The lexer - -:parsing:lexer.ml Ä :parsing:lexer.mll - streamedit -e "1,$ replace /¶¶''\223'¶¶'-¶¶''\246'¶¶'/ '' -c °" ¶ - -e "1,$ replace /¶¶''\248'¶¶'-¶¶''\255'¶¶'/ '' -c °" ¶ - -e "1,$ replace /¶¶''\192'¶¶'-¶¶''\214'¶¶'/ '' -c °" ¶ - -e "1,$ replace /¶¶''\216'¶¶'-¶¶''\222'¶¶'/ '' -c °" ¶ - -e "1,$ replace /¶¶''\216'¶¶'-¶¶''\246'¶¶'/ '' -c °" ¶ - <:parsing:lexer.mll >:parsing:lexer_tmp.mll - {CAMLLEX} :parsing:lexer_tmp.mll - rename -y :parsing:lexer_tmp.ml :parsing:lexer.ml - -partialclean ÄÄ - delete -i :parsing:lexer.ml - -beforedepend ÄÄ :parsing:lexer.ml - - -# The auxiliary lexer for counting line numbers - -:parsing:linenum.ml Ä :parsing:linenum.mll - {CAMLLEX} :parsing:linenum.mll - -partialclean ÄÄ - delete -i :parsing:linenum.ml - -beforedepend ÄÄ :parsing:linenum.ml - - -# The numeric opcodes - -:bytecomp:opcodes.ml Ä :byterun:instruct.h - :tools:make-opcodes.Mac :byterun:instruct.h :bytecomp:opcodes.ml - -partialclean ÄÄ - delete -i :bytecomp:opcodes.ml - -beforedepend ÄÄ :bytecomp:opcodes.ml - - -# The predefined exceptions and primitives - -:byterun:primitives Ä - directory :byterun: - domake primitives - directory :: - -:bytecomp:runtimedef.ml Ä :byterun:primitives :byterun:fail.h - (echo 'let builtin_exceptions = [|' ; ¶ - streamedit -d -e '/¶/¶* (¶"[A-Za-z_]*¶")¨0 ¶*¶/°/ print ¨0 ";"' :byterun:fail.h | ¶ - streamedit -e '$ replace /;°/ "|]"'; ¶ - echo 'let builtin_primitives = [|'; ¶ - streamedit -e "1,$ replace /(Å)¨0/ ' ¶"' ¨0 '¶";'" -e '$ replace /;°/ "|]"' :byterun:primitives; ¶ - ) > :bytecomp:runtimedef.ml - -partialclean ÄÄ - delete -i :bytecomp:runtimedef.ml - -beforedepend ÄÄ :bytecomp:runtimedef.ml - - -# The "expunge" utility - -expunge Ä {EXPUNGEOBJS} - {CAMLC} {LINKFLAGS} -o expunge {EXPUNGEOBJS} - -partialclean ÄÄ - delete -i expunge - - -# The runtime system for the bytecode compiler - -runtime Ä - directory :byterun:; domake all; directory :: -clean ÄÄ - directory :byterun:; domake clean; directory :: -alldepend ÄÄ - directory :byterun:; domake depend; directory :: - - -# The library - -library Ä ocamlc - directory :stdlib; domake all; directory :: -library-cross Ä - directory :stdlib; domake -d RUNTIME=::byterun:ocamlrun all; directory :: -partialclean ÄÄ - directory :stdlib; domake clean; directory :: -alldepend ÄÄ - directory :stdlib; domake depend; directory :: - - -# The lexer and parser generators - -ocamllex Ä ocamlyacc ocamlc - directory :lex; domake all; directory :: -partialclean ÄÄ - directory :lex; domake clean; directory :: -alldepend ÄÄ - directory :lex; domake depend; directory :: - -ocamlyacc Ä - directory :yacc; domake all; directory :: -clean ÄÄ - directory :yacc; domake clean; directory :: - - -# Tools - -ocamltools Ä ocamlc ocamlyacc ocamllex - directory :tools; domake all; directory :: -partialclean ÄÄ - directory :tools; domake clean; directory :: -alldepend ÄÄ - directory :tools; domake depend; directory :: - - -# The extra libraries - -otherlibraries Ä - for i in {OTHERLIBRARIES} - directory :otherlibs:{i}; domake all; directory ::: - end -partialclean ÄÄ - for i in {OTHERLIBRARIES} - directory :otherlibs:{i}; domake partialclean; directory ::: - end -clean ÄÄ - for i in {OTHERLIBRARIES} - directory :otherlibs:{i}; domake clean; directory ::: - end -alldepend ÄÄ - for i in {OTHERLIBRARIES} - directory :otherlibs:{i}; domake depend; directory ::: - end - - -# Camlp4 - -camlp4out Ä ocamlc - directory :camlp4: - execute :config:config.mpw - domake all - directory :: - -partialclean ÄÄ - directory :camlp4: - execute :config:config.mpw - domake clean - directory :: - -alldepend ÄÄ - directory :camlp4: - execute :config:config.mpw - domake depend - directory :: - -# The standalone application - -maccaml Ä - directory :maccaml:; domake all; directory :: -partialclean ÄÄ - directory :maccaml:; domake partialclean; directory :: -clean ÄÄ - directory :maccaml:; domake clean; directory :: -alldepend ÄÄ - directory :maccaml:; domake depend; directory :: - - -# Clean up the test directory - -clean ÄÄ - if `exists :test:` - directory :test:; domake clean; directory :: - end - - -# Default rules - -.cmo Ä .ml - {CAMLC} {COMPFLAGS} -c {depdir}{default}.ml - -.cmi Ä .mli - {CAMLC} {COMPFLAGS} -c {depdir}{default}.mli - -partialclean ÄÄ - for i in utils parsing typing bytecomp driver toplevel tools - delete -i :{i}:Å.cm[io] || set status 0 - end - -depend Ä beforedepend - for d in utils parsing typing bytecomp driver toplevel - {CAMLDEP} {DEPFLAGS} :{d}:Å.mli :{d}:Å.ml - end > Makefile.Mac.depend - -alldepend ÄÄ depend - - -# Make sure the config file was executed -dummy Ä {OTHERLIBRARIES} diff --git a/Makefile.Mac.depend b/Makefile.Mac.depend deleted file mode 100644 index ecc9ddd1f8..0000000000 --- a/Makefile.Mac.depend +++ /dev/null @@ -1,548 +0,0 @@ -:bytecomp:dll.cmo Ä :bytecomp:dll.cmi -:utils:ccomp.cmoÄ :utils:clflags.cmo :utils:config.cmi :utils:misc.cmi ¶ - :utils:ccomp.cmi -:utils:ccomp.cmxÄ :utils:clflags.cmx :utils:config.cmx :utils:misc.cmx ¶ - :utils:ccomp.cmi -:utils:clflags.cmoÄ :utils:config.cmi -:utils:clflags.cmxÄ :utils:config.cmx -:utils:config.cmoÄ :utils:config.cmi -:utils:config.cmxÄ :utils:config.cmi -:utils:misc.cmoÄ :utils:misc.cmi -:utils:misc.cmxÄ :utils:misc.cmi -:utils:tbl.cmoÄ :utils:tbl.cmi -:utils:tbl.cmxÄ :utils:tbl.cmi -:utils:terminfo.cmoÄ :utils:terminfo.cmi -:utils:terminfo.cmxÄ :utils:terminfo.cmi -:utils:warnings.cmoÄ :utils:warnings.cmi -:utils:warnings.cmxÄ :utils:warnings.cmi -:parsing:lexer.cmiÄ :parsing:parser.cmi -:parsing:location.cmiÄ :utils:warnings.cmi -:parsing:parse.cmiÄ :parsing:parsetree.cmi -:parsing:parser.cmiÄ :parsing:parsetree.cmi -:parsing:parsetree.cmiÄ :parsing:asttypes.cmi :parsing:location.cmi ¶ - :parsing:longident.cmi -:parsing:printast.cmiÄ :parsing:parsetree.cmi -:parsing:pstream.cmiÄ :parsing:parsetree.cmi -:parsing:syntaxerr.cmiÄ :parsing:location.cmi -:parsing:lexer.cmoÄ :parsing:location.cmi :utils:misc.cmi :parsing:parser.cmi ¶ - :utils:warnings.cmi :parsing:lexer.cmi -:parsing:lexer.cmxÄ :parsing:location.cmx :utils:misc.cmx :parsing:parser.cmx ¶ - :utils:warnings.cmx :parsing:lexer.cmi -:parsing:linenum.cmoÄ :utils:misc.cmi :parsing:linenum.cmi -:parsing:linenum.cmxÄ :utils:misc.cmx :parsing:linenum.cmi -:parsing:location.cmoÄ :parsing:linenum.cmi :utils:terminfo.cmi ¶ - :utils:warnings.cmi :parsing:location.cmi -:parsing:location.cmxÄ :parsing:linenum.cmx :utils:terminfo.cmx ¶ - :utils:warnings.cmx :parsing:location.cmi -:parsing:longident.cmoÄ :utils:misc.cmi :parsing:longident.cmi -:parsing:longident.cmxÄ :utils:misc.cmx :parsing:longident.cmi -:parsing:parse.cmoÄ :parsing:lexer.cmi :parsing:location.cmi ¶ - :parsing:parser.cmi :parsing:syntaxerr.cmi :parsing:parse.cmi -:parsing:parse.cmxÄ :parsing:lexer.cmx :parsing:location.cmx ¶ - :parsing:parser.cmx :parsing:syntaxerr.cmx :parsing:parse.cmi -:parsing:parser.cmoÄ :parsing:asttypes.cmi :utils:clflags.cmo ¶ - :parsing:location.cmi :parsing:longident.cmi :parsing:parsetree.cmi ¶ - :parsing:pstream.cmi :parsing:syntaxerr.cmi :parsing:parser.cmi -:parsing:parser.cmxÄ :parsing:asttypes.cmi :utils:clflags.cmx ¶ - :parsing:location.cmx :parsing:longident.cmx :parsing:parsetree.cmi ¶ - :parsing:pstream.cmx :parsing:syntaxerr.cmx :parsing:parser.cmi -:parsing:printast.cmoÄ :parsing:asttypes.cmi :parsing:location.cmi ¶ - :parsing:longident.cmi :parsing:parsetree.cmi :parsing:printast.cmi -:parsing:printast.cmxÄ :parsing:asttypes.cmi :parsing:location.cmx ¶ - :parsing:longident.cmx :parsing:parsetree.cmi :parsing:printast.cmi -:parsing:pstream.cmoÄ :parsing:asttypes.cmi :parsing:location.cmi ¶ - :parsing:longident.cmi :parsing:parsetree.cmi :parsing:pstream.cmi -:parsing:pstream.cmxÄ :parsing:asttypes.cmi :parsing:location.cmx ¶ - :parsing:longident.cmx :parsing:parsetree.cmi :parsing:pstream.cmi -:parsing:syntaxerr.cmoÄ :parsing:location.cmi :parsing:syntaxerr.cmi -:parsing:syntaxerr.cmxÄ :parsing:location.cmx :parsing:syntaxerr.cmi -:typing:btype.cmiÄ :parsing:asttypes.cmi :typing:path.cmi :typing:types.cmi -:typing:ctype.cmiÄ :parsing:asttypes.cmi :typing:env.cmi :typing:ident.cmi ¶ - :typing:path.cmi :typing:types.cmi -:typing:datarepr.cmiÄ :parsing:asttypes.cmi :typing:path.cmi ¶ - :typing:types.cmi -:typing:env.cmiÄ :typing:ident.cmi :parsing:longident.cmi :typing:path.cmi ¶ - :typing:types.cmi -:typing:includeclass.cmiÄ :typing:ctype.cmi :typing:env.cmi ¶ - :typing:typedtree.cmi :typing:types.cmi -:typing:includecore.cmiÄ :typing:env.cmi :typing:ident.cmi ¶ - :typing:typedtree.cmi :typing:types.cmi -:typing:includemod.cmiÄ :typing:ctype.cmi :typing:env.cmi :typing:ident.cmi ¶ - :typing:typedtree.cmi :typing:types.cmi -:typing:mtype.cmiÄ :typing:env.cmi :typing:ident.cmi :typing:path.cmi ¶ - :typing:types.cmi -:typing:parmatch.cmiÄ :typing:env.cmi :parsing:location.cmi ¶ - :typing:typedtree.cmi :typing:types.cmi -:typing:path.cmiÄ :typing:ident.cmi -:typing:predef.cmiÄ :typing:ident.cmi :typing:path.cmi :typing:types.cmi -:typing:printtyp.cmiÄ :typing:ident.cmi :parsing:longident.cmi ¶ - :typing:outcometree.cmi :typing:path.cmi :typing:types.cmi -:typing:subst.cmiÄ :typing:ident.cmi :typing:path.cmi :typing:types.cmi -:typing:typeclass.cmiÄ :parsing:asttypes.cmi :typing:ctype.cmi ¶ - :typing:env.cmi :typing:ident.cmi :parsing:location.cmi ¶ - :parsing:longident.cmi :parsing:parsetree.cmi :typing:typedtree.cmi ¶ - :typing:types.cmi -:typing:typecore.cmiÄ :parsing:asttypes.cmi :typing:env.cmi :typing:ident.cmi ¶ - :parsing:location.cmi :parsing:longident.cmi :parsing:parsetree.cmi ¶ - :typing:typedtree.cmi :typing:types.cmi -:typing:typedecl.cmiÄ :typing:env.cmi :typing:ident.cmi :parsing:location.cmi ¶ - :parsing:longident.cmi :parsing:parsetree.cmi :typing:path.cmi ¶ - :typing:types.cmi -:typing:typedtree.cmiÄ :parsing:asttypes.cmi :typing:env.cmi ¶ - :typing:ident.cmi :parsing:location.cmi :typing:path.cmi ¶ - :typing:primitive.cmi :typing:types.cmi -:typing:typemod.cmiÄ :typing:env.cmi :typing:ident.cmi :typing:includemod.cmi ¶ - :parsing:location.cmi :parsing:longident.cmi :parsing:parsetree.cmi ¶ - :typing:typedtree.cmi :typing:types.cmi -:typing:types.cmiÄ :parsing:asttypes.cmi :typing:ident.cmi :typing:path.cmi ¶ - :typing:primitive.cmi -:typing:typetexp.cmiÄ :typing:env.cmi :parsing:location.cmi ¶ - :parsing:longident.cmi :parsing:parsetree.cmi :typing:types.cmi -:typing:btype.cmoÄ :utils:misc.cmi :typing:path.cmi :typing:types.cmi ¶ - :typing:btype.cmi -:typing:btype.cmxÄ :utils:misc.cmx :typing:path.cmx :typing:types.cmx ¶ - :typing:btype.cmi -:typing:ctype.cmoÄ :parsing:asttypes.cmi :typing:btype.cmi :utils:clflags.cmo ¶ - :typing:env.cmi :typing:ident.cmi :parsing:longident.cmi :utils:misc.cmi ¶ - :typing:path.cmi :typing:subst.cmi :typing:types.cmi :typing:ctype.cmi -:typing:ctype.cmxÄ :parsing:asttypes.cmi :typing:btype.cmx :utils:clflags.cmx ¶ - :typing:env.cmx :typing:ident.cmx :parsing:longident.cmx :utils:misc.cmx ¶ - :typing:path.cmx :typing:subst.cmx :typing:types.cmx :typing:ctype.cmi -:typing:datarepr.cmoÄ :parsing:asttypes.cmi :utils:misc.cmi ¶ - :typing:predef.cmi :typing:types.cmi :typing:datarepr.cmi -:typing:datarepr.cmxÄ :parsing:asttypes.cmi :utils:misc.cmx ¶ - :typing:predef.cmx :typing:types.cmx :typing:datarepr.cmi -:typing:env.cmoÄ :parsing:asttypes.cmi :typing:btype.cmi :utils:config.cmi ¶ - :typing:datarepr.cmi :typing:ident.cmi :parsing:longident.cmi ¶ - :utils:misc.cmi :typing:path.cmi :typing:predef.cmi :typing:subst.cmi ¶ - :utils:tbl.cmi :typing:types.cmi :typing:env.cmi -:typing:env.cmxÄ :parsing:asttypes.cmi :typing:btype.cmx :utils:config.cmx ¶ - :typing:datarepr.cmx :typing:ident.cmx :parsing:longident.cmx ¶ - :utils:misc.cmx :typing:path.cmx :typing:predef.cmx :typing:subst.cmx ¶ - :utils:tbl.cmx :typing:types.cmx :typing:env.cmi -:typing:ident.cmoÄ :typing:ident.cmi -:typing:ident.cmxÄ :typing:ident.cmi -:typing:includeclass.cmoÄ :typing:ctype.cmi :typing:printtyp.cmi ¶ - :typing:types.cmi :typing:includeclass.cmi -:typing:includeclass.cmxÄ :typing:ctype.cmx :typing:printtyp.cmx ¶ - :typing:types.cmx :typing:includeclass.cmi -:typing:includecore.cmoÄ :parsing:asttypes.cmi :typing:btype.cmi ¶ - :typing:ctype.cmi :utils:misc.cmi :typing:path.cmi :typing:predef.cmi ¶ - :typing:typedtree.cmi :typing:types.cmi :typing:includecore.cmi -:typing:includecore.cmxÄ :parsing:asttypes.cmi :typing:btype.cmx ¶ - :typing:ctype.cmx :utils:misc.cmx :typing:path.cmx :typing:predef.cmx ¶ - :typing:typedtree.cmx :typing:types.cmx :typing:includecore.cmi -:typing:includemod.cmoÄ :typing:ctype.cmi :typing:env.cmi :typing:ident.cmi ¶ - :typing:includeclass.cmi :typing:includecore.cmi :utils:misc.cmi ¶ - :typing:mtype.cmi :typing:path.cmi :typing:printtyp.cmi :typing:subst.cmi ¶ - :utils:tbl.cmi :typing:typedtree.cmi :typing:types.cmi ¶ - :typing:includemod.cmi -:typing:includemod.cmxÄ :typing:ctype.cmx :typing:env.cmx :typing:ident.cmx ¶ - :typing:includeclass.cmx :typing:includecore.cmx :utils:misc.cmx ¶ - :typing:mtype.cmx :typing:path.cmx :typing:printtyp.cmx :typing:subst.cmx ¶ - :utils:tbl.cmx :typing:typedtree.cmx :typing:types.cmx ¶ - :typing:includemod.cmi -:typing:mtype.cmoÄ :typing:btype.cmi :typing:ctype.cmi :typing:env.cmi ¶ - :typing:ident.cmi :typing:path.cmi :typing:types.cmi :typing:mtype.cmi -:typing:mtype.cmxÄ :typing:btype.cmx :typing:ctype.cmx :typing:env.cmx ¶ - :typing:ident.cmx :typing:path.cmx :typing:types.cmx :typing:mtype.cmi -:typing:parmatch.cmoÄ :parsing:asttypes.cmi :typing:btype.cmi ¶ - :typing:ctype.cmi :typing:datarepr.cmi :typing:env.cmi :typing:ident.cmi ¶ - :parsing:location.cmi :utils:misc.cmi :typing:path.cmi ¶ - :typing:typedtree.cmi :typing:types.cmi :utils:warnings.cmi ¶ - :typing:parmatch.cmi -:typing:parmatch.cmxÄ :parsing:asttypes.cmi :typing:btype.cmx ¶ - :typing:ctype.cmx :typing:datarepr.cmx :typing:env.cmx :typing:ident.cmx ¶ - :parsing:location.cmx :utils:misc.cmx :typing:path.cmx ¶ - :typing:typedtree.cmx :typing:types.cmx :utils:warnings.cmx ¶ - :typing:parmatch.cmi -:typing:path.cmoÄ :typing:ident.cmi :typing:path.cmi -:typing:path.cmxÄ :typing:ident.cmx :typing:path.cmi -:typing:predef.cmoÄ :typing:btype.cmi :typing:ident.cmi :typing:path.cmi ¶ - :typing:types.cmi :typing:predef.cmi -:typing:predef.cmxÄ :typing:btype.cmx :typing:ident.cmx :typing:path.cmx ¶ - :typing:types.cmx :typing:predef.cmi -:typing:primitive.cmoÄ :utils:misc.cmi :typing:primitive.cmi -:typing:primitive.cmxÄ :utils:misc.cmx :typing:primitive.cmi -:typing:printtyp.cmoÄ :parsing:asttypes.cmi :typing:btype.cmi ¶ - :utils:clflags.cmo :typing:ctype.cmi :typing:env.cmi :typing:ident.cmi ¶ - :parsing:longident.cmi :utils:misc.cmi :typing:outcometree.cmi ¶ - :typing:path.cmi :typing:predef.cmi :typing:primitive.cmi ¶ - :typing:types.cmi :typing:printtyp.cmi -:typing:printtyp.cmxÄ :parsing:asttypes.cmi :typing:btype.cmx ¶ - :utils:clflags.cmx :typing:ctype.cmx :typing:env.cmx :typing:ident.cmx ¶ - :parsing:longident.cmx :utils:misc.cmx :typing:outcometree.cmi ¶ - :typing:path.cmx :typing:predef.cmx :typing:primitive.cmx ¶ - :typing:types.cmx :typing:printtyp.cmi -:typing:subst.cmoÄ :typing:btype.cmi :typing:ident.cmi :utils:misc.cmi ¶ - :typing:path.cmi :utils:tbl.cmi :typing:types.cmi :typing:subst.cmi -:typing:subst.cmxÄ :typing:btype.cmx :typing:ident.cmx :utils:misc.cmx ¶ - :typing:path.cmx :utils:tbl.cmx :typing:types.cmx :typing:subst.cmi -:typing:typeclass.cmoÄ :parsing:asttypes.cmi :typing:btype.cmi ¶ - :utils:clflags.cmo :typing:ctype.cmi :typing:env.cmi :typing:ident.cmi ¶ - :typing:includeclass.cmi :parsing:location.cmi :parsing:longident.cmi ¶ - :utils:misc.cmi :typing:parmatch.cmi :parsing:parsetree.cmi ¶ - :typing:path.cmi :typing:predef.cmi :typing:printtyp.cmi ¶ - :typing:typecore.cmi :typing:typedecl.cmi :typing:typedtree.cmi ¶ - :typing:types.cmi :typing:typetexp.cmi :utils:warnings.cmi ¶ - :typing:typeclass.cmi -:typing:typeclass.cmxÄ :parsing:asttypes.cmi :typing:btype.cmx ¶ - :utils:clflags.cmx :typing:ctype.cmx :typing:env.cmx :typing:ident.cmx ¶ - :typing:includeclass.cmx :parsing:location.cmx :parsing:longident.cmx ¶ - :utils:misc.cmx :typing:parmatch.cmx :parsing:parsetree.cmi ¶ - :typing:path.cmx :typing:predef.cmx :typing:printtyp.cmx ¶ - :typing:typecore.cmx :typing:typedecl.cmx :typing:typedtree.cmx ¶ - :typing:types.cmx :typing:typetexp.cmx :utils:warnings.cmx ¶ - :typing:typeclass.cmi -:typing:typecore.cmoÄ :parsing:asttypes.cmi :typing:btype.cmi ¶ - :utils:clflags.cmo :typing:ctype.cmi :typing:env.cmi :typing:ident.cmi ¶ - :parsing:location.cmi :parsing:longident.cmi :utils:misc.cmi ¶ - :typing:parmatch.cmi :parsing:parsetree.cmi :typing:path.cmi ¶ - :typing:predef.cmi :typing:primitive.cmi :typing:printtyp.cmi ¶ - :typing:typedtree.cmi :typing:types.cmi :typing:typetexp.cmi ¶ - :utils:warnings.cmi :typing:typecore.cmi -:typing:typecore.cmxÄ :parsing:asttypes.cmi :typing:btype.cmx ¶ - :utils:clflags.cmx :typing:ctype.cmx :typing:env.cmx :typing:ident.cmx ¶ - :parsing:location.cmx :parsing:longident.cmx :utils:misc.cmx ¶ - :typing:parmatch.cmx :parsing:parsetree.cmi :typing:path.cmx ¶ - :typing:predef.cmx :typing:primitive.cmx :typing:printtyp.cmx ¶ - :typing:typedtree.cmx :typing:types.cmx :typing:typetexp.cmx ¶ - :utils:warnings.cmx :typing:typecore.cmi -:typing:typedecl.cmoÄ :parsing:asttypes.cmi :typing:btype.cmi ¶ - :utils:clflags.cmo :utils:config.cmi :typing:ctype.cmi :typing:env.cmi ¶ - :typing:ident.cmi :typing:includecore.cmi :parsing:location.cmi ¶ - :parsing:longident.cmi :utils:misc.cmi :parsing:parsetree.cmi ¶ - :typing:path.cmi :typing:predef.cmi :typing:primitive.cmi ¶ - :typing:printtyp.cmi :typing:subst.cmi :typing:typedtree.cmi ¶ - :typing:types.cmi :typing:typetexp.cmi :typing:typedecl.cmi -:typing:typedecl.cmxÄ :parsing:asttypes.cmi :typing:btype.cmx ¶ - :utils:clflags.cmx :utils:config.cmx :typing:ctype.cmx :typing:env.cmx ¶ - :typing:ident.cmx :typing:includecore.cmx :parsing:location.cmx ¶ - :parsing:longident.cmx :utils:misc.cmx :parsing:parsetree.cmi ¶ - :typing:path.cmx :typing:predef.cmx :typing:primitive.cmx ¶ - :typing:printtyp.cmx :typing:subst.cmx :typing:typedtree.cmx ¶ - :typing:types.cmx :typing:typetexp.cmx :typing:typedecl.cmi -:typing:typedtree.cmoÄ :parsing:asttypes.cmi :typing:env.cmi ¶ - :typing:ident.cmi :parsing:location.cmi :utils:misc.cmi :typing:path.cmi ¶ - :typing:primitive.cmi :typing:types.cmi :typing:typedtree.cmi -:typing:typedtree.cmxÄ :parsing:asttypes.cmi :typing:env.cmx ¶ - :typing:ident.cmx :parsing:location.cmx :utils:misc.cmx :typing:path.cmx ¶ - :typing:primitive.cmx :typing:types.cmx :typing:typedtree.cmi -:typing:typemod.cmoÄ :utils:clflags.cmo :utils:config.cmi :typing:ctype.cmi ¶ - :typing:env.cmi :typing:ident.cmi :typing:includemod.cmi ¶ - :parsing:location.cmi :parsing:longident.cmi :utils:misc.cmi ¶ - :typing:mtype.cmi :parsing:parsetree.cmi :typing:path.cmi ¶ - :typing:printtyp.cmi :typing:subst.cmi :typing:typeclass.cmi ¶ - :typing:typecore.cmi :typing:typedecl.cmi :typing:typedtree.cmi ¶ - :typing:types.cmi :typing:typemod.cmi -:typing:typemod.cmxÄ :utils:clflags.cmx :utils:config.cmx :typing:ctype.cmx ¶ - :typing:env.cmx :typing:ident.cmx :typing:includemod.cmx ¶ - :parsing:location.cmx :parsing:longident.cmx :utils:misc.cmx ¶ - :typing:mtype.cmx :parsing:parsetree.cmi :typing:path.cmx ¶ - :typing:printtyp.cmx :typing:subst.cmx :typing:typeclass.cmx ¶ - :typing:typecore.cmx :typing:typedecl.cmx :typing:typedtree.cmx ¶ - :typing:types.cmx :typing:typemod.cmi -:typing:types.cmoÄ :parsing:asttypes.cmi :typing:ident.cmi :utils:misc.cmi ¶ - :typing:path.cmi :typing:primitive.cmi :typing:types.cmi -:typing:types.cmxÄ :parsing:asttypes.cmi :typing:ident.cmx :utils:misc.cmx ¶ - :typing:path.cmx :typing:primitive.cmx :typing:types.cmi -:typing:typetexp.cmoÄ :typing:btype.cmi :typing:ctype.cmi :typing:env.cmi ¶ - :parsing:location.cmi :parsing:longident.cmi :utils:misc.cmi ¶ - :parsing:parsetree.cmi :typing:printtyp.cmi :utils:tbl.cmi ¶ - :typing:types.cmi :typing:typetexp.cmi -:typing:typetexp.cmxÄ :typing:btype.cmx :typing:ctype.cmx :typing:env.cmx ¶ - :parsing:location.cmx :parsing:longident.cmx :utils:misc.cmx ¶ - :parsing:parsetree.cmi :typing:printtyp.cmx :utils:tbl.cmx ¶ - :typing:types.cmx :typing:typetexp.cmi -:bytecomp:bytegen.cmiÄ :bytecomp:instruct.cmi :bytecomp:lambda.cmi -:bytecomp:bytelink.cmiÄ :bytecomp:emitcode.cmi :bytecomp:symtable.cmi -:bytecomp:emitcode.cmiÄ :typing:ident.cmi :bytecomp:instruct.cmi ¶ - :bytecomp:lambda.cmi -:bytecomp:instruct.cmiÄ :typing:env.cmi :typing:ident.cmi ¶ - :bytecomp:lambda.cmi :typing:types.cmi -:bytecomp:lambda.cmiÄ :parsing:asttypes.cmi :typing:env.cmi :typing:ident.cmi ¶ - :typing:path.cmi :typing:primitive.cmi :typing:types.cmi -:bytecomp:matching.cmiÄ :typing:ident.cmi :bytecomp:lambda.cmi ¶ - :parsing:location.cmi :typing:typedtree.cmi -:bytecomp:printinstr.cmiÄ :bytecomp:instruct.cmi -:bytecomp:printlambda.cmiÄ :bytecomp:lambda.cmi -:bytecomp:simplif.cmiÄ :bytecomp:lambda.cmi -:bytecomp:symtable.cmiÄ :bytecomp:emitcode.cmi :typing:ident.cmi -:bytecomp:translclass.cmiÄ :typing:ident.cmi :bytecomp:lambda.cmi ¶ - :parsing:location.cmi :typing:typedtree.cmi -:bytecomp:translcore.cmiÄ :parsing:asttypes.cmi :typing:ident.cmi ¶ - :bytecomp:lambda.cmi :parsing:location.cmi :typing:path.cmi ¶ - :typing:primitive.cmi :typing:typedtree.cmi :typing:types.cmi -:bytecomp:translmod.cmiÄ :typing:ident.cmi :bytecomp:lambda.cmi ¶ - :typing:typedtree.cmi -:bytecomp:translobj.cmiÄ :typing:ident.cmi :bytecomp:lambda.cmi -:bytecomp:typeopt.cmiÄ :bytecomp:lambda.cmi :typing:path.cmi ¶ - :typing:typedtree.cmi -:bytecomp:bytegen.cmoÄ :parsing:asttypes.cmi :utils:config.cmi ¶ - :typing:ident.cmi :bytecomp:instruct.cmi :bytecomp:lambda.cmi ¶ - :utils:misc.cmi :typing:primitive.cmi :bytecomp:switch.cmi ¶ - :typing:types.cmi :bytecomp:bytegen.cmi -:bytecomp:bytegen.cmxÄ :parsing:asttypes.cmi :utils:config.cmx ¶ - :typing:ident.cmx :bytecomp:instruct.cmx :bytecomp:lambda.cmx ¶ - :utils:misc.cmx :typing:primitive.cmx :bytecomp:switch.cmx ¶ - :typing:types.cmx :bytecomp:bytegen.cmi -:bytecomp:bytelibrarian.cmoÄ :utils:clflags.cmo :utils:config.cmi ¶ - :bytecomp:emitcode.cmi :utils:misc.cmi :bytecomp:bytelibrarian.cmi -:bytecomp:bytelibrarian.cmxÄ :utils:clflags.cmx :utils:config.cmx ¶ - :bytecomp:emitcode.cmx :utils:misc.cmx :bytecomp:bytelibrarian.cmi -:bytecomp:bytelink.cmoÄ :bytecomp:bytesections.cmi :utils:ccomp.cmi ¶ - :utils:clflags.cmo :utils:config.cmi :bytecomp:emitcode.cmi ¶ - :typing:ident.cmi :bytecomp:instruct.cmi :utils:misc.cmi ¶ - :bytecomp:opcodes.cmo :bytecomp:symtable.cmi :bytecomp:bytelink.cmi -:bytecomp:bytelink.cmxÄ :bytecomp:bytesections.cmx :utils:ccomp.cmx ¶ - :utils:clflags.cmx :utils:config.cmx :bytecomp:emitcode.cmx ¶ - :typing:ident.cmx :bytecomp:instruct.cmx :utils:misc.cmx ¶ - :bytecomp:opcodes.cmx :bytecomp:symtable.cmx :bytecomp:bytelink.cmi -:bytecomp:bytesections.cmoÄ :utils:config.cmi :bytecomp:bytesections.cmi -:bytecomp:bytesections.cmxÄ :utils:config.cmx :bytecomp:bytesections.cmi -:bytecomp:emitcode.cmoÄ :parsing:asttypes.cmi :typing:btype.cmi ¶ - :utils:clflags.cmo :utils:config.cmi :typing:env.cmi :typing:ident.cmi ¶ - :bytecomp:instruct.cmi :bytecomp:lambda.cmi :bytecomp:meta.cmi ¶ - :utils:misc.cmi :bytecomp:opcodes.cmo :bytecomp:translmod.cmi ¶ - :bytecomp:emitcode.cmi -:bytecomp:emitcode.cmxÄ :parsing:asttypes.cmi :typing:btype.cmx ¶ - :utils:clflags.cmx :utils:config.cmx :typing:env.cmx :typing:ident.cmx ¶ - :bytecomp:instruct.cmx :bytecomp:lambda.cmx :bytecomp:meta.cmx ¶ - :utils:misc.cmx :bytecomp:opcodes.cmx :bytecomp:translmod.cmx ¶ - :bytecomp:emitcode.cmi -:bytecomp:instruct.cmoÄ :typing:env.cmi :typing:ident.cmi ¶ - :bytecomp:lambda.cmi :typing:types.cmi :bytecomp:instruct.cmi -:bytecomp:instruct.cmxÄ :typing:env.cmx :typing:ident.cmx ¶ - :bytecomp:lambda.cmx :typing:types.cmx :bytecomp:instruct.cmi -:bytecomp:lambda.cmoÄ :parsing:asttypes.cmi :typing:env.cmi :typing:ident.cmi ¶ - :utils:misc.cmi :typing:path.cmi :typing:primitive.cmi :typing:types.cmi ¶ - :bytecomp:lambda.cmi -:bytecomp:lambda.cmxÄ :parsing:asttypes.cmi :typing:env.cmx :typing:ident.cmx ¶ - :utils:misc.cmx :typing:path.cmx :typing:primitive.cmx :typing:types.cmx ¶ - :bytecomp:lambda.cmi -:bytecomp:matching.cmoÄ :parsing:asttypes.cmi :typing:btype.cmi ¶ - :typing:ident.cmi :bytecomp:lambda.cmi :parsing:location.cmi ¶ - :utils:misc.cmi :typing:parmatch.cmi :typing:predef.cmi ¶ - :typing:primitive.cmi :bytecomp:printlambda.cmi :bytecomp:switch.cmi ¶ - :typing:typedtree.cmi :bytecomp:typeopt.cmi :typing:types.cmi ¶ - :bytecomp:matching.cmi -:bytecomp:matching.cmxÄ :parsing:asttypes.cmi :typing:btype.cmx ¶ - :typing:ident.cmx :bytecomp:lambda.cmx :parsing:location.cmx ¶ - :utils:misc.cmx :typing:parmatch.cmx :typing:predef.cmx ¶ - :typing:primitive.cmx :bytecomp:printlambda.cmx :bytecomp:switch.cmx ¶ - :typing:typedtree.cmx :bytecomp:typeopt.cmx :typing:types.cmx ¶ - :bytecomp:matching.cmi -:bytecomp:meta.cmoÄ :bytecomp:meta.cmi -:bytecomp:meta.cmxÄ :bytecomp:meta.cmi -:bytecomp:printinstr.cmoÄ :typing:ident.cmi :bytecomp:instruct.cmi ¶ - :bytecomp:lambda.cmi :bytecomp:printlambda.cmi :bytecomp:printinstr.cmi -:bytecomp:printinstr.cmxÄ :typing:ident.cmx :bytecomp:instruct.cmx ¶ - :bytecomp:lambda.cmx :bytecomp:printlambda.cmx :bytecomp:printinstr.cmi -:bytecomp:printlambda.cmoÄ :parsing:asttypes.cmi :typing:ident.cmi ¶ - :bytecomp:lambda.cmi :typing:primitive.cmi :typing:types.cmi ¶ - :bytecomp:printlambda.cmi -:bytecomp:printlambda.cmxÄ :parsing:asttypes.cmi :typing:ident.cmx ¶ - :bytecomp:lambda.cmx :typing:primitive.cmx :typing:types.cmx ¶ - :bytecomp:printlambda.cmi -:bytecomp:runtimedef.cmoÄ :bytecomp:runtimedef.cmi -:bytecomp:runtimedef.cmxÄ :bytecomp:runtimedef.cmi -:bytecomp:simplif.cmoÄ :parsing:asttypes.cmi :utils:clflags.cmo ¶ - :typing:ident.cmi :bytecomp:lambda.cmi :bytecomp:simplif.cmi -:bytecomp:simplif.cmxÄ :parsing:asttypes.cmi :utils:clflags.cmx ¶ - :typing:ident.cmx :bytecomp:lambda.cmx :bytecomp:simplif.cmi -:bytecomp:switch.cmoÄ :bytecomp:switch.cmi -:bytecomp:switch.cmxÄ :bytecomp:switch.cmi -:bytecomp:symtable.cmoÄ :parsing:asttypes.cmi :bytecomp:bytesections.cmi ¶ - :utils:clflags.cmo :bytecomp:emitcode.cmi :typing:ident.cmi ¶ - :bytecomp:lambda.cmi :bytecomp:meta.cmi :utils:misc.cmi ¶ - :typing:predef.cmi :bytecomp:runtimedef.cmi :utils:tbl.cmi ¶ - :bytecomp:symtable.cmi -:bytecomp:symtable.cmxÄ :parsing:asttypes.cmi :bytecomp:bytesections.cmx ¶ - :utils:clflags.cmx :bytecomp:emitcode.cmx :typing:ident.cmx ¶ - :bytecomp:lambda.cmx :bytecomp:meta.cmx :utils:misc.cmx ¶ - :typing:predef.cmx :bytecomp:runtimedef.cmx :utils:tbl.cmx ¶ - :bytecomp:symtable.cmi -:bytecomp:translclass.cmoÄ :parsing:asttypes.cmi :typing:ident.cmi ¶ - :bytecomp:lambda.cmi :parsing:location.cmi :bytecomp:matching.cmi ¶ - :utils:misc.cmi :bytecomp:translcore.cmi :bytecomp:translobj.cmi ¶ - :typing:typedtree.cmi :bytecomp:typeopt.cmi :typing:types.cmi ¶ - :bytecomp:translclass.cmi -:bytecomp:translclass.cmxÄ :parsing:asttypes.cmi :typing:ident.cmx ¶ - :bytecomp:lambda.cmx :parsing:location.cmx :bytecomp:matching.cmx ¶ - :utils:misc.cmx :bytecomp:translcore.cmx :bytecomp:translobj.cmx ¶ - :typing:typedtree.cmx :bytecomp:typeopt.cmx :typing:types.cmx ¶ - :bytecomp:translclass.cmi -:bytecomp:translcore.cmoÄ :parsing:asttypes.cmi :typing:btype.cmi ¶ - :utils:clflags.cmo :utils:config.cmi :typing:env.cmi :typing:ident.cmi ¶ - :bytecomp:lambda.cmi :parsing:location.cmi :bytecomp:matching.cmi ¶ - :utils:misc.cmi :typing:path.cmi :typing:predef.cmi :typing:primitive.cmi ¶ - :bytecomp:translobj.cmi :typing:typedtree.cmi :bytecomp:typeopt.cmi ¶ - :typing:types.cmi :bytecomp:translcore.cmi -:bytecomp:translcore.cmxÄ :parsing:asttypes.cmi :typing:btype.cmx ¶ - :utils:clflags.cmx :utils:config.cmx :typing:env.cmx :typing:ident.cmx ¶ - :bytecomp:lambda.cmx :parsing:location.cmx :bytecomp:matching.cmx ¶ - :utils:misc.cmx :typing:path.cmx :typing:predef.cmx :typing:primitive.cmx ¶ - :bytecomp:translobj.cmx :typing:typedtree.cmx :bytecomp:typeopt.cmx ¶ - :typing:types.cmx :bytecomp:translcore.cmi -:bytecomp:translmod.cmoÄ :parsing:asttypes.cmi :typing:ident.cmi ¶ - :bytecomp:lambda.cmi :utils:misc.cmi :typing:path.cmi ¶ - :typing:primitive.cmi :bytecomp:translclass.cmi :bytecomp:translcore.cmi ¶ - :bytecomp:translobj.cmi :typing:typedtree.cmi :typing:types.cmi ¶ - :bytecomp:translmod.cmi -:bytecomp:translmod.cmxÄ :parsing:asttypes.cmi :typing:ident.cmx ¶ - :bytecomp:lambda.cmx :utils:misc.cmx :typing:path.cmx ¶ - :typing:primitive.cmx :bytecomp:translclass.cmx :bytecomp:translcore.cmx ¶ - :bytecomp:translobj.cmx :typing:typedtree.cmx :typing:types.cmx ¶ - :bytecomp:translmod.cmi -:bytecomp:translobj.cmoÄ :parsing:asttypes.cmi :typing:env.cmi ¶ - :typing:ident.cmi :bytecomp:lambda.cmi :parsing:longident.cmi ¶ - :utils:misc.cmi :bytecomp:translobj.cmi -:bytecomp:translobj.cmxÄ :parsing:asttypes.cmi :typing:env.cmx ¶ - :typing:ident.cmx :bytecomp:lambda.cmx :parsing:longident.cmx ¶ - :utils:misc.cmx :bytecomp:translobj.cmi -:bytecomp:typeopt.cmoÄ :parsing:asttypes.cmi :typing:ctype.cmi ¶ - :typing:env.cmi :typing:ident.cmi :bytecomp:lambda.cmi :utils:misc.cmi ¶ - :typing:path.cmi :typing:predef.cmi :typing:primitive.cmi ¶ - :typing:typedtree.cmi :typing:types.cmi :bytecomp:typeopt.cmi -:bytecomp:typeopt.cmxÄ :parsing:asttypes.cmi :typing:ctype.cmx ¶ - :typing:env.cmx :typing:ident.cmx :bytecomp:lambda.cmx :utils:misc.cmx ¶ - :typing:path.cmx :typing:predef.cmx :typing:primitive.cmx ¶ - :typing:typedtree.cmx :typing:types.cmx :bytecomp:typeopt.cmi -:driver:compile.cmiÄ :typing:env.cmi -:driver:optcompile.cmiÄ :typing:env.cmi -:driver:compile.cmoÄ :bytecomp:bytegen.cmi :utils:ccomp.cmi ¶ - :utils:clflags.cmo :utils:config.cmi :bytecomp:emitcode.cmi ¶ - :typing:env.cmi :parsing:location.cmi :utils:misc.cmi :parsing:parse.cmi ¶ - :parsing:printast.cmi :bytecomp:printinstr.cmi :bytecomp:printlambda.cmi ¶ - :typing:printtyp.cmi :bytecomp:simplif.cmi :bytecomp:translmod.cmi ¶ - :typing:typedtree.cmi :typing:typemod.cmi :utils:warnings.cmi ¶ - :driver:compile.cmi -:driver:compile.cmxÄ :bytecomp:bytegen.cmx :utils:ccomp.cmx ¶ - :utils:clflags.cmx :utils:config.cmx :bytecomp:emitcode.cmx ¶ - :typing:env.cmx :parsing:location.cmx :utils:misc.cmx :parsing:parse.cmx ¶ - :parsing:printast.cmx :bytecomp:printinstr.cmx :bytecomp:printlambda.cmx ¶ - :typing:printtyp.cmx :bytecomp:simplif.cmx :bytecomp:translmod.cmx ¶ - :typing:typedtree.cmx :typing:typemod.cmx :utils:warnings.cmx ¶ - :driver:compile.cmi -:driver:errors.cmoÄ :bytecomp:bytelibrarian.cmi :bytecomp:bytelink.cmi ¶ - :typing:ctype.cmi :typing:env.cmi :typing:includemod.cmi ¶ - :parsing:lexer.cmi :parsing:location.cmi :bytecomp:symtable.cmi ¶ - :parsing:syntaxerr.cmi :bytecomp:translclass.cmi :bytecomp:translcore.cmi ¶ - :typing:typeclass.cmi :typing:typecore.cmi :typing:typedecl.cmi ¶ - :typing:typemod.cmi :typing:typetexp.cmi :utils:warnings.cmi ¶ - :driver:errors.cmi -:driver:errors.cmxÄ :bytecomp:bytelibrarian.cmx :bytecomp:bytelink.cmx ¶ - :typing:ctype.cmx :typing:env.cmx :typing:includemod.cmx ¶ - :parsing:lexer.cmx :parsing:location.cmx :bytecomp:symtable.cmx ¶ - :parsing:syntaxerr.cmx :bytecomp:translclass.cmx :bytecomp:translcore.cmx ¶ - :typing:typeclass.cmx :typing:typecore.cmx :typing:typedecl.cmx ¶ - :typing:typemod.cmx :typing:typetexp.cmx :utils:warnings.cmx ¶ - :driver:errors.cmi -:driver:main.cmoÄ :bytecomp:bytelibrarian.cmi :bytecomp:bytelink.cmi ¶ - :utils:clflags.cmo :driver:compile.cmi :utils:config.cmi ¶ - :driver:errors.cmi :driver:main_args.cmi :utils:warnings.cmi ¶ - :driver:main.cmi -:driver:main.cmxÄ :bytecomp:bytelibrarian.cmx :bytecomp:bytelink.cmx ¶ - :utils:clflags.cmx :driver:compile.cmx :utils:config.cmx ¶ - :driver:errors.cmx :driver:main_args.cmx :utils:warnings.cmx ¶ - :driver:main.cmi -:driver:main_args.cmoÄ :driver:main_args.cmi -:driver:main_args.cmxÄ :driver:main_args.cmi -:driver:optcompile.cmoÄ :utils:ccomp.cmi :utils:clflags.cmo :utils:config.cmi ¶ - :typing:env.cmi :parsing:location.cmi :utils:misc.cmi :parsing:parse.cmi ¶ - :parsing:printast.cmi :bytecomp:printlambda.cmi :typing:printtyp.cmi ¶ - :bytecomp:simplif.cmi :bytecomp:translmod.cmi :typing:typedtree.cmi ¶ - :typing:typemod.cmi :utils:warnings.cmi :driver:optcompile.cmi -:driver:optcompile.cmxÄ :utils:ccomp.cmx :utils:clflags.cmx :utils:config.cmx ¶ - :typing:env.cmx :parsing:location.cmx :utils:misc.cmx :parsing:parse.cmx ¶ - :parsing:printast.cmx :bytecomp:printlambda.cmx :typing:printtyp.cmx ¶ - :bytecomp:simplif.cmx :bytecomp:translmod.cmx :typing:typedtree.cmx ¶ - :typing:typemod.cmx :utils:warnings.cmx :driver:optcompile.cmi -:driver:opterrors.cmoÄ :typing:ctype.cmi :typing:env.cmi ¶ - :typing:includemod.cmi :parsing:lexer.cmi :parsing:location.cmi ¶ - :parsing:syntaxerr.cmi :bytecomp:translclass.cmi :bytecomp:translcore.cmi ¶ - :typing:typeclass.cmi :typing:typecore.cmi :typing:typedecl.cmi ¶ - :typing:typemod.cmi :typing:typetexp.cmi :utils:warnings.cmi ¶ - :driver:opterrors.cmi -:driver:opterrors.cmxÄ :typing:ctype.cmx :typing:env.cmx ¶ - :typing:includemod.cmx :parsing:lexer.cmx :parsing:location.cmx ¶ - :parsing:syntaxerr.cmx :bytecomp:translclass.cmx :bytecomp:translcore.cmx ¶ - :typing:typeclass.cmx :typing:typecore.cmx :typing:typedecl.cmx ¶ - :typing:typemod.cmx :typing:typetexp.cmx :utils:warnings.cmx ¶ - :driver:opterrors.cmi -:driver:optmain.cmoÄ :utils:clflags.cmo :utils:config.cmi ¶ - :driver:optcompile.cmi :driver:opterrors.cmi :utils:warnings.cmi ¶ - :driver:optmain.cmi -:driver:optmain.cmxÄ :utils:clflags.cmx :utils:config.cmx ¶ - :driver:optcompile.cmx :driver:opterrors.cmx :utils:warnings.cmx ¶ - :driver:optmain.cmi -:toplevel:genprintval.cmiÄ :typing:env.cmi :typing:outcometree.cmi ¶ - :typing:path.cmi :typing:types.cmi -:toplevel:topdirs.cmiÄ :parsing:longident.cmi -:toplevel:toploop.cmiÄ :typing:env.cmi :parsing:location.cmi ¶ - :parsing:longident.cmi :typing:outcometree.cmi :parsing:parsetree.cmi ¶ - :typing:path.cmi :typing:types.cmi :utils:warnings.cmi -:toplevel:trace.cmiÄ :typing:env.cmi :parsing:longident.cmi :typing:path.cmi ¶ - :typing:types.cmi -:toplevel:expunge.cmoÄ :bytecomp:bytesections.cmi :typing:ident.cmi ¶ - :utils:misc.cmi :bytecomp:runtimedef.cmi :bytecomp:symtable.cmi -:toplevel:expunge.cmxÄ :bytecomp:bytesections.cmx :typing:ident.cmx ¶ - :utils:misc.cmx :bytecomp:runtimedef.cmx :bytecomp:symtable.cmx -:toplevel:genprintval.cmoÄ :typing:btype.cmi :typing:ctype.cmi ¶ - :typing:datarepr.cmi :typing:env.cmi :typing:ident.cmi ¶ - :parsing:longident.cmi :utils:misc.cmi :typing:outcometree.cmi ¶ - :typing:path.cmi :typing:predef.cmi :typing:printtyp.cmi ¶ - :typing:types.cmi :toplevel:genprintval.cmi -:toplevel:genprintval.cmxÄ :typing:btype.cmx :typing:ctype.cmx ¶ - :typing:datarepr.cmx :typing:env.cmx :typing:ident.cmx ¶ - :parsing:longident.cmx :utils:misc.cmx :typing:outcometree.cmi ¶ - :typing:path.cmx :typing:predef.cmx :typing:printtyp.cmx ¶ - :typing:types.cmx :toplevel:genprintval.cmi -:toplevel:topdirs.cmoÄ :bytecomp:bytelink.cmi :utils:clflags.cmo ¶ - :utils:config.cmi :typing:ctype.cmi :bytecomp:emitcode.cmi ¶ - :typing:env.cmi :typing:ident.cmi :parsing:longident.cmi ¶ - :bytecomp:meta.cmi :utils:misc.cmi :bytecomp:opcodes.cmo :typing:path.cmi ¶ - :typing:printtyp.cmi :bytecomp:symtable.cmi :toplevel:toploop.cmi ¶ - :toplevel:trace.cmi :typing:types.cmi :utils:warnings.cmi ¶ - :toplevel:topdirs.cmi -:toplevel:topdirs.cmxÄ :bytecomp:bytelink.cmx :utils:clflags.cmx ¶ - :utils:config.cmx :typing:ctype.cmx :bytecomp:emitcode.cmx ¶ - :typing:env.cmx :typing:ident.cmx :parsing:longident.cmx ¶ - :bytecomp:meta.cmx :utils:misc.cmx :bytecomp:opcodes.cmx :typing:path.cmx ¶ - :typing:printtyp.cmx :bytecomp:symtable.cmx :toplevel:toploop.cmx ¶ - :toplevel:trace.cmx :typing:types.cmx :utils:warnings.cmx ¶ - :toplevel:topdirs.cmi -:toplevel:toploop.cmoÄ :bytecomp:bytegen.cmi :utils:clflags.cmo ¶ - :driver:compile.cmi :utils:config.cmi :bytecomp:emitcode.cmi ¶ - :typing:env.cmi :driver:errors.cmi :toplevel:genprintval.cmi ¶ - :typing:ident.cmi :parsing:lexer.cmi :parsing:location.cmi ¶ - :parsing:longident.cmi :bytecomp:meta.cmi :utils:misc.cmi ¶ - :typing:outcometree.cmi :parsing:parse.cmi :parsing:parsetree.cmi ¶ - :typing:path.cmi :typing:predef.cmi :parsing:printast.cmi ¶ - :bytecomp:printinstr.cmi :bytecomp:printlambda.cmi :typing:printtyp.cmi ¶ - :bytecomp:simplif.cmi :bytecomp:symtable.cmi :bytecomp:translmod.cmi ¶ - :typing:typedtree.cmi :typing:typemod.cmi :typing:types.cmi ¶ - :utils:warnings.cmi :toplevel:toploop.cmi -:toplevel:toploop.cmxÄ :bytecomp:bytegen.cmx :utils:clflags.cmx ¶ - :driver:compile.cmx :utils:config.cmx :bytecomp:emitcode.cmx ¶ - :typing:env.cmx :driver:errors.cmx :toplevel:genprintval.cmx ¶ - :typing:ident.cmx :parsing:lexer.cmx :parsing:location.cmx ¶ - :parsing:longident.cmx :bytecomp:meta.cmx :utils:misc.cmx ¶ - :typing:outcometree.cmi :parsing:parse.cmx :parsing:parsetree.cmi ¶ - :typing:path.cmx :typing:predef.cmx :parsing:printast.cmx ¶ - :bytecomp:printinstr.cmx :bytecomp:printlambda.cmx :typing:printtyp.cmx ¶ - :bytecomp:simplif.cmx :bytecomp:symtable.cmx :bytecomp:translmod.cmx ¶ - :typing:typedtree.cmx :typing:typemod.cmx :typing:types.cmx ¶ - :utils:warnings.cmx :toplevel:toploop.cmi -:toplevel:topmain.cmoÄ :utils:clflags.cmo :utils:config.cmi :utils:misc.cmi ¶ - :toplevel:toploop.cmi :utils:warnings.cmi -:toplevel:topmain.cmxÄ :utils:clflags.cmx :utils:config.cmx :utils:misc.cmx ¶ - :toplevel:toploop.cmx :utils:warnings.cmx -:toplevel:trace.cmoÄ :typing:ctype.cmi :parsing:longident.cmi ¶ - :bytecomp:meta.cmi :utils:misc.cmi :typing:path.cmi :typing:predef.cmi ¶ - :typing:printtyp.cmi :toplevel:toploop.cmi :typing:types.cmi ¶ - :toplevel:trace.cmi -:toplevel:trace.cmxÄ :typing:ctype.cmx :parsing:longident.cmx ¶ - :bytecomp:meta.cmx :utils:misc.cmx :typing:path.cmx :typing:predef.cmx ¶ - :typing:printtyp.cmx :toplevel:toploop.cmx :typing:types.cmx ¶ - :toplevel:trace.cmi diff --git a/Makefile.nt b/Makefile.nt deleted file mode 100644 index a69385439d..0000000000 --- a/Makefile.nt +++ /dev/null @@ -1,622 +0,0 @@ -######################################################################### -# # -# Objective Caml # -# # -# Xavier Leroy, projet Cristal, INRIA Rocquencourt # -# # -# Copyright 1999 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### - -# $Id$ - -# The main Makefile - -include config/Makefile -include stdlib/StdlibModules - -CAMLC=boot/ocamlrun boot/ocamlc -I boot -CAMLOPT=boot/ocamlrun ./ocamlopt -I stdlib -COMPFLAGS=$(INCLUDES) -LINKFLAGS= -CAMLYACC=boot/ocamlyacc -YACCFLAGS= -CAMLLEX=boot/ocamlrun boot/ocamllex -CAMLDEP=boot/ocamlrun tools/ocamldep -DEPFLAGS=$(INCLUDES) -CAMLRUN=byterun/ocamlrun - -INCLUDES=-I utils -I parsing -I typing -I bytecomp -I asmcomp -I driver -I toplevel - -UTILS=utils/misc.cmo utils/tbl.cmo utils/config.cmo \ - utils/clflags.cmo utils/terminfo.cmo utils/ccomp.cmo utils/warnings.cmo \ - utils/consistbl.cmo - -OPTUTILS=$(UTILS) - -PARSING=parsing/linenum.cmo parsing/location.cmo parsing/longident.cmo \ - parsing/syntaxerr.cmo parsing/parser.cmo \ - parsing/lexer.cmo parsing/parse.cmo parsing/printast.cmo - -TYPING=typing/ident.cmo typing/path.cmo \ - typing/primitive.cmo typing/types.cmo \ - typing/btype.cmo typing/oprint.cmo \ - typing/subst.cmo typing/predef.cmo \ - typing/datarepr.cmo typing/env.cmo \ - typing/typedtree.cmo typing/ctype.cmo \ - typing/printtyp.cmo typing/includeclass.cmo \ - typing/mtype.cmo typing/includecore.cmo \ - typing/includemod.cmo typing/parmatch.cmo \ - typing/typetexp.cmo typing/stypes.cmo typing/typecore.cmo \ - typing/typedecl.cmo typing/typeclass.cmo \ - typing/typemod.cmo - -COMP=bytecomp/lambda.cmo bytecomp/printlambda.cmo \ - bytecomp/typeopt.cmo bytecomp/switch.cmo bytecomp/matching.cmo \ - bytecomp/translobj.cmo bytecomp/translcore.cmo \ - bytecomp/translclass.cmo bytecomp/translmod.cmo \ - bytecomp/simplif.cmo bytecomp/runtimedef.cmo - -BYTECOMP=bytecomp/meta.cmo bytecomp/instruct.cmo bytecomp/bytegen.cmo \ - bytecomp/printinstr.cmo bytecomp/opcodes.cmo bytecomp/emitcode.cmo \ - bytecomp/bytesections.cmo bytecomp/dll.cmo bytecomp/symtable.cmo \ - bytecomp/bytelink.cmo bytecomp/bytelibrarian.cmo bytecomp/bytepackager.cmo - -ASMCOMP=asmcomp/arch.cmo asmcomp/cmm.cmo asmcomp/printcmm.cmo \ - asmcomp/reg.cmo asmcomp/mach.cmo asmcomp/proc.cmo \ - asmcomp/clambda.cmo asmcomp/compilenv.cmo \ - asmcomp/closure.cmo asmcomp/cmmgen.cmo \ - asmcomp/printmach.cmo asmcomp/selectgen.cmo asmcomp/selection.cmo \ - asmcomp/comballoc.cmo asmcomp/liveness.cmo \ - asmcomp/spill.cmo asmcomp/split.cmo \ - asmcomp/interf.cmo asmcomp/coloring.cmo \ - asmcomp/reloadgen.cmo asmcomp/reload.cmo \ - asmcomp/printlinear.cmo asmcomp/linearize.cmo \ - asmcomp/schedgen.cmo asmcomp/scheduling.cmo \ - asmcomp/emitaux.cmo asmcomp/emit.cmo asmcomp/asmgen.cmo \ - asmcomp/asmlink.cmo asmcomp/asmlibrarian.cmo asmcomp/asmpackager.cmo - -DRIVER=driver/pparse.cmo driver/errors.cmo driver/compile.cmo \ - driver/main_args.cmo driver/main.cmo - -OPTDRIVER=driver/pparse.cmo driver/opterrors.cmo driver/optcompile.cmo \ - driver/optmain.cmo - -TOPLEVEL=driver/pparse.cmo driver/errors.cmo driver/compile.cmo \ - toplevel/genprintval.cmo toplevel/toploop.cmo \ - toplevel/trace.cmo toplevel/topdirs.cmo toplevel/topmain.cmo - -TOPLEVELLIB=toplevel/toplevellib.cma -TOPLEVELSTART=toplevel/topstart.cmo - -COMPOBJS=$(UTILS) $(PARSING) $(TYPING) $(COMP) $(BYTECOMP) $(DRIVER) - -TOPLIB=$(UTILS) $(PARSING) $(TYPING) $(COMP) $(BYTECOMP) $(TOPLEVEL) - -TOPOBJS=$(TOPLEVELLIB) $(TOPLEVELSTART) - -OPTOBJS=$(OPTUTILS) $(PARSING) $(TYPING) $(COMP) $(ASMCOMP) $(OPTDRIVER) - -EXPUNGEOBJS=utils/misc.cmo utils/tbl.cmo \ - utils/config.cmo utils/clflags.cmo \ - typing/ident.cmo typing/path.cmo typing/types.cmo typing/btype.cmo \ - typing/predef.cmo bytecomp/runtimedef.cmo bytecomp/bytesections.cmo \ - bytecomp/dll.cmo \ - bytecomp/symtable.cmo toplevel/expunge.cmo - -PERVASIVES=$(STDLIB_MODULES) topdirs toploop outcometree - -# For users who don't read the INSTALL file -defaultentry: - @echo "Please refer to the installation instructions in file README.win32." - -# Recompile the system using the bootstrap compiler -all: runtime ocamlc ocamllex ocamlyacc ocamltools library ocaml otherlibraries ocamldoc.byte camlp4out win32gui - -# The compilation of ocaml will fail if the runtime has changed. -# Never mind, just do make bootstrap to reach fixpoint again. - -# Compile everything the first time -world: coldstart all - -# Complete bootstrapping cycle -bootstrap: -# Save the original bootstrap compiler - $(MAKEREC) backup -# Promote the new compiler but keep the old runtime -# This compiler runs on boot/ocamlrun and produces bytecode for byterun/ocamlrun - $(MAKEREC) promote-cross -# Rebuild ocamlc and ocamllex (run on byterun/ocamlrun) - $(MAKEREC) partialclean - $(MAKEREC) ocamlc ocamllex -# Rebuild the library (using byterun/ocamlrun ./ocamlc) - $(MAKEREC) library-cross -# Promote the new compiler and the new runtime - $(MAKEREC) promote -# Rebuild everything, including ocaml and the tools - $(MAKEREC) partialclean - $(MAKEREC) all -# Check if fixpoint reached - $(MAKEREC) compare - -LIBFILES=stdlib.cma std_exit.cmo *.cmi camlheader - -# Start up the system from the distribution compiler -coldstart: - cd byterun ; $(MAKEREC) all - cp byterun/ocamlrun.exe boot/ocamlrun.exe - cp byterun/ocamlrun.dll boot/ocamlrun.dll - cd yacc ; $(MAKEREC) all - cp yacc/ocamlyacc.exe boot/ocamlyacc.exe - cd stdlib ; $(MAKEREC) COMPILER=../boot/ocamlc all - cd stdlib ; cp $(LIBFILES) ../boot - -# Build the core system: the minimum needed to make depend and bootstrap -core : runtime ocamlc ocamllex ocamlyacc ocamltools library - -# Save the current bootstrap compiler -MAXSAVED=boot/Saved/Saved.prev/Saved.prev/Saved.prev/Saved.prev/Saved.prev -backup: - mkdir -p boot/Saved - if test -d $(MAXSAVED); then rm -r $(MAXSAVED); fi - mv boot/Saved boot/Saved.prev - mkdir boot/Saved - mv boot/Saved.prev boot/Saved/Saved.prev - cp boot/ocamlrun.exe boot/Saved/ocamlrun.exe - cd boot ; mv ocamlc ocamllex ocamlyacc.exe Saved - cd boot ; cp $(LIBFILES) Saved - -# Promote the newly compiled system to the rank of cross compiler -# (Runs on the old runtime, produces code for the new runtime) -promote-cross: - cp ocamlc boot/ocamlc - cp lex/ocamllex boot/ocamllex - cp yacc/ocamlyacc.exe boot/ocamlyacc.exe - cd stdlib ; cp $(LIBFILES) ../boot - -# Promote the newly compiled system to the rank of bootstrap compiler -# (Runs on the new runtime, produces code for the new runtime) -promote: promote-cross - cp byterun/ocamlrun.exe boot/ocamlrun.exe - -# Restore the saved bootstrap compiler if a problem arises -restore: - cd boot/Saved ; mv * .. - rmdir boot/Saved - mv boot/Saved.prev boot/Saved - -# Check if fixpoint reached -compare: - - cmp -i 4096 boot/ocamlc ocamlc - - cmp -i 4096 boot/ocamllex lex/ocamllex - -# Remove old bootstrap compilers -cleanboot: - rm -rf boot/Saved/Saved.prev/* - -# Compile the native-code compiler -opt: runtimeopt ocamlopt libraryopt otherlibrariesopt camlp4opt - -# Native-code versions of the tools -opt.opt: ocamlc.opt ocamlopt.opt ocamllex.opt ocamltoolsopt.opt \ - camlp4optopt ocamldoc.opt - -# Installation -install: installbyt installopt - -installbyt: - mkdir -p $(BINDIR) - mkdir -p $(LIBDIR) - cd byterun ; $(MAKEREC) install - echo "$(STUBLIBDIR)" > $(LIBDIR)/ld.conf - echo "$(LIBDIR)" >> $(LIBDIR)/ld.conf - cp ocamlc $(BINDIR)/ocamlc.exe - cp ocaml $(BINDIR)/ocaml.exe - cd stdlib ; $(MAKEREC) install - cp lex/ocamllex $(BINDIR)/ocamllex.exe - cp yacc/ocamlyacc.exe $(BINDIR)/ocamlyacc.exe - cp toplevel/toplevellib.cma $(LIBDIR)/toplevellib.cma - cp expunge $(LIBDIR)/expunge.exe - cp typing/outcometree.cmi typing/outcometree.mli $(LIBDIR) - cp toplevel/topstart.cmo $(LIBDIR) - cp toplevel/toploop.cmi toplevel/topdirs.cmi toplevel/topmain.cmi $(LIBDIR) - cd tools ; $(MAKEREC) install - cd ocamldoc ; $(MAKEREC) install - mkdir -p $(STUBLIBDIR) - for i in $(OTHERLIBRARIES); do $(MAKEREC) -C otherlibs/$$i install; done - cd win32caml ; $(MAKE) install - cd camlp4 ; make install - cp README $(DISTRIB)/Readme.gen - cp README.win32 $(DISTRIB)/Readme.win - cp LICENSE $(DISTRIB)/License.txt - cp Changes $(DISTRIB)/Changes.txt - -# Installation of the native-code compiler -installopt: - cd asmrun ; $(MAKEREC) install - cp ocamlopt $(BINDIR)/ocamlopt.exe - cd stdlib ; $(MAKEREC) installopt - cd ocamldoc ; $(MAKEREC) installopt - for i in $(OTHERLIBRARIES); do $(MAKEREC) -C otherlibs/$$i installopt; done - if test -f ocamlc.opt; \ - then cp ocamlc.opt $(BINDIR)/ocamlc.opt.exe; else :; fi - if test -f ocamlopt.opt; \ - then cp ocamlopt.opt $(BINDIR)/ocamlopt.opt.exe; else :; fi - if test -f lex/ocamllex.opt; \ - then cp lex/ocamllex.opt $(BINDIR)/ocamllex.opt.exe; else :; fi - -clean:: partialclean - -# The compiler - -ocamlc: $(COMPOBJS) - $(CAMLC) $(LINKFLAGS) -o ocamlc $(COMPOBJS) - @sed -e 's|@compiler@|$$topdir/boot/ocamlrun $$topdir/ocamlc|' \ - driver/ocamlcomp.sh.in > ocamlcomp.sh - @chmod +x ocamlcomp.sh - -partialclean:: - rm -f ocamlc - -# The native-code compiler - -ocamlopt: $(OPTOBJS) - $(CAMLC) $(LINKFLAGS) -o ocamlopt $(OPTOBJS) - @sed -e 's|@compiler@|$$topdir/boot/ocamlrun $$topdir/ocamlopt|' \ - driver/ocamlcomp.sh.in > ocamlcompopt.sh - @chmod +x ocamlcompopt.sh - -partialclean:: - rm -f ocamlopt - -# The toplevel - -ocaml: $(TOPOBJS) expunge - $(CAMLC) $(LINKFLAGS) -linkall -o ocaml.tmp $(TOPOBJS) - - $(CAMLRUN) ./expunge ocaml.tmp ocaml $(PERVASIVES) - rm -f ocaml.tmp - -toplevel/toplevellib.cma: $(TOPLIB) - $(CAMLC) -a -o $@ $(TOPLIB) - -partialclean:: - rm -f ocaml - -# The configuration file - -utils/config.ml: utils/config.mlp config/Makefile - @rm -f utils/config.ml - sed -e "s|%%LIBDIR%%|$(LIBDIR)|" \ - -e "s|%%BYTERUN%%|ocamlrun|" \ - -e 's|%%CCOMPTYPE%%|$(CCOMPTYPE)|' \ - -e "s|%%BYTECC%%|$(BYTECC) $(BYTECCCOMPOPTS)|" \ - -e "s|%%BYTELINK%%|$(BYTECC) $(BYTECCLINKOPTS)|" \ - -e "s|%%NATIVECC%%|$(NATIVECC) $(NATIVECCCOMPOPTS)|" \ - -e "s|%%NATIVELINK%%|$(NATIVECC) $(NATIVECCLINKOPTS)|" \ - -e "s|%%PARTIALLD%%|$(PARTIALLD)|" \ - -e "s|%%PACKLD%%|$(PACKLD)|" \ - -e "s|%%BYTECCLIBS%%|$(BYTECCLIBS)|" \ - -e "s|%%NATIVECCLIBS%%|$(NATIVECCLIBS)|" \ - -e 's|%%RANLIBCMD%%|$(RANLIBCMD)|' \ - -e 's|%%BINUTILS_NM%%|$(BINUTILS_NM)|' \ - -e 's|%%BINUTILS_OBJCOPY%%|$(BINUTILS_OBJCOPY)|' \ - -e "s|%%ARCH%%|$(ARCH)|" \ - -e "s|%%MODEL%%|$(MODEL)|" \ - -e "s|%%SYSTEM%%|$(SYSTEM)|" \ - -e "s|%%EXT_OBJ%%|.$(O)|" \ - -e "s|%%EXT_ASM%%|.$(S)|" \ - -e "s|%%EXT_LIB%%|.$(A)|" \ - -e "s|%%EXT_DLL%%|.dll|" \ - utils/config.mlp > utils/config.ml - @chmod -w utils/config.ml - -partialclean:: - rm -f utils/config.ml - -beforedepend:: utils/config.ml - -# The parser - -parsing/parser.mli parsing/parser.ml: parsing/parser.mly - $(CAMLYACC) $(YACCFLAGS) parsing/parser.mly - -partialclean:: - rm -f parsing/parser.mli parsing/parser.ml parsing/parser.output - -beforedepend:: parsing/parser.mli parsing/parser.ml - -# The lexer - -parsing/lexer.ml: parsing/lexer.mll - $(CAMLLEX) parsing/lexer.mll - -partialclean:: - rm -f parsing/lexer.ml - -beforedepend:: parsing/lexer.ml - -# The auxiliary lexer for counting line numbers - -parsing/linenum.ml: parsing/linenum.mll - $(CAMLLEX) parsing/linenum.mll - -partialclean:: - rm -f parsing/linenum.ml - -beforedepend:: parsing/linenum.ml - -# The bytecode compiler compiled with the native-code compiler - -ocamlc.opt: $(COMPOBJS:.cmo=.cmx) - cd asmrun ; $(MAKEREC) meta.$(O) dynlink.$(O) - $(CAMLOPT) $(LINKFLAGS) -o ocamlc.opt $(COMPOBJS:.cmo=.cmx) asmrun/meta.$(O) asmrun/dynlink.$(O) - -partialclean:: - rm -f ocamlc.opt - -# The native-code compiler compiled with itself - -ocamlopt.opt: $(OPTOBJS:.cmo=.cmx) - $(CAMLOPT) $(LINKFLAGS) -o ocamlopt.opt $(OPTOBJS:.cmo=.cmx) - -partialclean:: - rm -f ocamlopt.opt - -$(OPTOBJS:.cmo=.cmx): ocamlopt - -# The numeric opcodes - -bytecomp/opcodes.ml: byterun/instruct.h - sed -n -e "/^enum/p" -e "s|,||g" -e "/^ /p" byterun/instruct.h | \ - gawk -f tools/make-opcodes > bytecomp/opcodes.ml - -partialclean:: - rm -f bytecomp/opcodes.ml - -beforedepend:: bytecomp/opcodes.ml - -# The predefined exceptions and primitives - -byterun/primitives: - cd byterun ; $(MAKEREC) primitives - -bytecomp/runtimedef.ml: byterun/primitives byterun/fail.h - (echo 'let builtin_exceptions = [|'; \ - sed -n -e 's|.*/\* \("[A-Za-z_]*"\) \*/$$| \1;|p' byterun/fail.h | \ - sed -e '$$s/;$$//'; \ - echo '|]'; \ - echo 'let builtin_primitives = [|'; \ - sed -e 's/.*/ "&";/' -e '$$s/;$$//' byterun/primitives; \ - echo '|]') > bytecomp/runtimedef.ml - -partialclean:: - rm -f bytecomp/runtimedef.ml - -beforedepend:: bytecomp/runtimedef.ml - -# Choose the right machine-dependent files - -asmcomp/arch.ml: asmcomp/$(ARCH)/arch.ml - cp asmcomp/$(ARCH)/arch.ml asmcomp/arch.ml - -partialclean:: - rm -f asmcomp/arch.ml - -beforedepend:: asmcomp/arch.ml - -ifeq ($(TOOLCHAIN),msvc) -ASMCOMP_PROC=asmcomp/$(ARCH)/proc_nt.ml -ASMCOMP_EMIT=asmcomp/$(ARCH)/emit_nt.mlp -else -ASMCOMP_PROC=asmcomp/$(ARCH)/proc.ml -ASMCOMP_EMIT=asmcomp/$(ARCH)/emit.mlp -endif - -asmcomp/proc.ml: $(ASMCOMP_PROC) - cp $(ASMCOMP_PROC) asmcomp/proc.ml - -partialclean:: - rm -f asmcomp/proc.ml - -beforedepend:: asmcomp/proc.ml - -asmcomp/selection.ml: asmcomp/$(ARCH)/selection.ml - cp asmcomp/$(ARCH)/selection.ml asmcomp/selection.ml - -partialclean:: - rm -f asmcomp/selection.ml - -beforedepend:: asmcomp/selection.ml - -asmcomp/reload.ml: asmcomp/$(ARCH)/reload.ml - cp asmcomp/$(ARCH)/reload.ml asmcomp/reload.ml - -partialclean:: - rm -f asmcomp/reload.ml - -beforedepend:: asmcomp/reload.ml - -asmcomp/scheduling.ml: asmcomp/$(ARCH)/scheduling.ml - cp asmcomp/$(ARCH)/scheduling.ml asmcomp/scheduling.ml - -partialclean:: - rm -f asmcomp/scheduling.ml - -beforedepend:: asmcomp/scheduling.ml - -# Preprocess the code emitters - -asmcomp/emit.ml: $(ASMCOMP_EMIT) tools/cvt_emit - boot/ocamlrun tools/cvt_emit < $(ASMCOMP_EMIT) > asmcomp/emit.ml - -partialclean:: - rm -f asmcomp/emit.ml - -beforedepend:: asmcomp/emit.ml - -tools/cvt_emit: tools/cvt_emit.mll - cd tools ; $(MAKEREC) cvt_emit - -# The "expunge" utility - -expunge: $(EXPUNGEOBJS) - $(CAMLC) $(LINKFLAGS) -o expunge $(EXPUNGEOBJS) - -partialclean:: - rm -f expunge - -# The runtime system for the bytecode compiler - -runtime: makeruntime stdlib/libcamlrun.$(A) - -makeruntime: - cd byterun ; $(MAKEREC) all -stdlib/libcamlrun.$(A): byterun/libcamlrun.$(A) - cp byterun/libcamlrun.$(A) stdlib/libcamlrun.$(A) -clean:: - cd byterun ; $(MAKEREC) clean - rm -f stdlib/libcamlrun.$(A) -alldepend:: - cd byterun ; $(MAKEREC) depend - -# The runtime system for the native-code compiler - -runtimeopt: makeruntimeopt stdlib/libasmrun.$(A) - -makeruntimeopt: - cd asmrun ; $(MAKEREC) all -stdlib/libasmrun.$(A): asmrun/libasmrun.$(A) - cp asmrun/libasmrun.$(A) stdlib/libasmrun.$(A) -clean:: - cd asmrun ; $(MAKEREC) clean - rm -f stdlib/libasmrun.$(A) -alldepend:: - cd asmrun ; $(MAKEREC) depend - -# The library - -library: - cd stdlib ; $(MAKEREC) all -library-cross: - cd stdlib ; $(MAKEREC) RUNTIME=../byterun/ocamlrun all -libraryopt: - cd stdlib ; $(MAKEREC) allopt -partialclean:: - cd stdlib ; $(MAKEREC) clean -alldepend:: - cd stdlib ; $(MAKEREC) depend - -# The lexer and parser generators - -ocamllex: - cd lex ; $(MAKEREC) all -ocamllex.opt: - cd lex ; $(MAKEREC) allopt -partialclean:: - cd lex ; $(MAKEREC) clean -alldepend:: - cd lex ; $(MAKEREC) depend - -ocamlyacc: - cd yacc ; $(MAKEREC) all -clean:: - cd yacc ; $(MAKEREC) clean - -# Tools - -ocamltools: - cd tools ; $(MAKEREC) all -ocamltoolsopt.opt: - cd tools ; $(MAKEREC) opt.opt -partialclean:: - cd tools ; $(MAKEREC) clean -alldepend:: - cd tools ; $(MAKEREC) depend - -# OCamldoc - -ocamldoc.byte: - cd ocamldoc ; $(MAKEREC) all -ocamldoc.opt: - cd ocamldoc ; $(MAKEREC) opt.opt -partialclean:: - cd ocamldoc ; $(MAKEREC) clean -alldepend:: - cd ocamldoc ; $(MAKEREC) depend - -# The extra libraries - -otherlibraries: - for i in $(OTHERLIBRARIES); do $(MAKEREC) -C otherlibs/$$i all; done -otherlibrariesopt: - for i in $(OTHERLIBRARIES); do $(MAKEREC) -C otherlibs/$$i allopt; done -partialclean:: - for i in $(OTHERLIBRARIES); do $(MAKEREC) -C otherlibs/$$i partialclean; done -clean:: - for i in $(OTHERLIBRARIES); do $(MAKEREC) -C otherlibs/$$i clean; done -alldepend:: - for i in $(OTHERLIBRARIES); do $(MAKEREC) -C otherlibs/$$i depend; done - -# Camlp4 - -camlp4out: - cd camlp4/config ; \ - (cat Makefile.tpl; \ - echo 'EXE=.exe'; \ - echo 'O=$(O)'; \ - echo 'A=$(A)'; \ - echo 'OPT='; \ - echo 'OTOP=../..'; \ - echo 'OLIBDIR=$$(OTOP)/boot'; \ - echo 'BINDIR=$(BINDIR)'; \ - echo 'LIBDIR=$(LIBDIR)'; \ - echo 'MANDIR=' ) > Makefile - cd camlp4 ; $(MAKE) -camlp4opt: - cd camlp4 ; $(MAKE) opt -camlp4optopt: - cd camlp4; $(MAKE) opt.opt -partialclean:: - cd camlp4 ; $(MAKE) clean - -# The Win32 toplevel GUI - -win32gui: - cd win32caml ; $(MAKE) all - -clean:: - cd win32caml ; $(MAKE) clean - -# Default rules - -.SUFFIXES: .ml .mli .cmo .cmi .cmx - -.ml.cmo: - $(CAMLC) $(COMPFLAGS) -c $< - -.mli.cmi: - $(CAMLC) $(COMPFLAGS) -c $< - -.ml.cmx: - $(CAMLOPT) $(COMPFLAGS) -c $< - -partialclean:: - rm -f utils/*.cm* utils/*.$(O) utils/*.$(S) - rm -f parsing/*.cm* parsing/*.$(O) parsing/*.$(S) - rm -f typing/*.cm* typing/*.$(O) typing/*.$(S) - rm -f bytecomp/*.cm* bytecomp/*.$(O) bytecomp/*.$(S) - rm -f asmcomp/*.cm* asmcomp/*.$(O) asmcomp/*.$(S) - rm -f driver/*.cm* driver/*.$(O) driver/*.$(S) - rm -f toplevel/*.cm* toplevel/*.$(O) toplevel/*.$(S) - rm -f tools/*.cm* tools/*.$(O) tools/*.$(S) - -depend: beforedepend - (for d in utils parsing typing bytecomp asmcomp driver toplevel; \ - do $(CAMLDEP) $(DEPFLAGS) $$d/*.mli $$d/*.ml; \ - done) > .depend - -alldepend:: depend - -include .depend diff --git a/README b/README deleted file mode 100644 index 400812aa55..0000000000 --- a/README +++ /dev/null @@ -1,144 +0,0 @@ -OVERVIEW: - -Objective Caml is an implementation of the ML language, based on -the Caml Light dialect extended with a complete class-based object system -and a powerful module system in the style of Standard ML. - -Objective Caml comprises two compilers. One generates bytecode -which is then interpreted by a C program. This compiler runs quickly, -generates compact code with moderate memory requirements, and is -portable to essentially any 32 or 64 bit Unix platform. Performance of -generated programs is quite good for a bytecoded implementation: -almost twice as fast as Caml Light 0.7. This compiler can be used -either as a standalone, batch-oriented compiler that produces -standalone programs, or as an interactive, toplevel-based system. - -The other compiler generates high-performance native code for a number -of processors. Compilation takes longer and generates bigger code, but -the generated programs deliver excellent performance, while retaining -the moderate memory requirements of the bytecode compiler. The -native-code compiler currently runs on the following platforms: - - Intel/AMD Pentium processors: PCs under Linux, FreeBSD, NetBSD, - OpenBSD, Windows, NextStep, Solaris 2, BeOS. - PowerPC processors: PowerMacintosh under MacOS X and LinuxPPC, - IBM RS6000 and PowerPC workstations under AIX 4.3 - AMD64 (Opteron) processors: PCs under Linux. - Alpha processors: Digital/Compaq/HP Alpha machines under - Digital Unix/Compaq Tru64, Linux, NetBSD and OpenBSD. - Sparc processors: Sun Sparc machines under Solaris 2, NetBSD, Linux - Mips processors: SGI workstations and mainframes under IRIX 6 - Intel IA64 processors: HP stations under Linux - HP PA-RISC processors: HP 9000/700 under HPUX 10 - Strong ARM processors: Corel Netwinder under Linux - -Other operating systems for the processors above have not been tested, -but the compiler may work under other operating systems with little work. - -Before the introduction of objects, Objective Caml was known as Caml -Special Light. Objective Caml is almost upwards compatible with Caml -Special Light, except for a few additional reserved keywords that have -forced some renaming of standard library functions. - -CONTENTS: - - Changes what's new with each release - INSTALL instructions for installation - INSTALL.MPW infos on the Macintosh MPW port of Objective Caml - LICENSE license and copyright notice - Makefile main Makefile - README this file - README.win32 infos on the MS Windows 98/ME/NT/2000 ports of O.Caml - asmcomp/ native-code compiler and linker - asmrun/ native-code runtime library - boot/ bootstrap compiler - bytecomp/ bytecode compiler and linker - byterun/ bytecode interpreter and runtime system - config/ autoconfiguration stuff - debugger/ source-level replay debugger - driver/ driver code for the compilers - emacs/ Caml editing mode and debugger interface for GNU Emacs - lex/ lexer generator - maccaml/ the Macintosh GUI - ocamldoc/ documentation generator - otherlibs/ several external libraries - parsing/ syntax analysis - stdlib/ standard library - tools/ various utilities - toplevel/ interactive system - typing/ typechecking - utils/ utility libraries - yacc/ parser generator - -COPYRIGHT: - -All files marked "Copyright INRIA" in this distribution are copyright -1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003 Institut National de -Recherche en Informatique et en Automatique (INRIA) and distributed -under the conditions stated in file LICENSE. - -INSTALLATION: - -See the file INSTALL for installation instructions on Unix, Linux and -MacOS X machines. For MS Windows, see README.win32. -For the MacOS 7, 8, 9, see INSTALL.MPW. - -DOCUMENTATION: - -The Objective Caml manual is distributed in HTML, PDF, Postscript, -DVI, and Emacs Info files. It is available on the World Wide Web, at - - http://caml.inria.fr/ - -AVAILABILITY: - -The complete Objective Caml distribution can be accessed through a Web -browser at - - http://caml.inria.fr/ - -or by anonymous FTP: - - host: ftp.inria.fr - directory: INRIA/caml-light - -KEEPING IN TOUCH WITH THE CAML COMMUNITY: - -There exists a mailing list of users of the Caml implementations -developed at INRIA. The purpose of this list is to share -experience, exchange ideas (and even code), and report on applications -of the Caml language. Messages can be written in English or in -French. The list has about 500 subscribers. - -Messages to the list should be sent to: - - caml-list@inria.fr - -If you wish to subscribe to this list, please send a message to: - - caml-list-request@inria.fr - -with the single word "subscribe" in the body of the message. - -Archives of the list are available on the World Wide Web at URL -http://caml.inria.fr/ - -The Usenet news groups comp.lang.ml and comp.lang.functional -also contains discussions about the ML family of programming languages, -including Caml. - -BUG REPORTS AND USER FEEDBACK: - -Send your bug reports by E-mail to: - - caml-bugs@inria.fr - -or report them using the Web interface to the bug-tracking system -at http://caml.inria.fr/bin/caml-bugs - -To be effective, bug reports should include a complete program -(preferably small) that exhibits the unexpected behavior, and the -configuration you are using (machine type, etc). - -You can also contact the implementors directly at caml@inria.fr. - diff --git a/README.win32 b/README.win32 deleted file mode 100644 index c872c3ebb5..0000000000 --- a/README.win32 +++ /dev/null @@ -1,248 +0,0 @@ - Release notes on the MS Windows ports of Objective Caml - ------------------------------------------------------- - -Starting with OCaml 3.05, there are no less than three ports of -Objective Caml for MS Windows available: - - a native Win32 port, built with the Microsoft development tools; - - a native Win32 port, built with the Cygwin/MinGW development tools; - - a port consisting of the Unix sources compiled under the Cygwin - Unix-like environment for Windows. - -Here is a summary of the main differences between these ports: - - Native MS Native MinGW Cygwin -Third-party software required - - for base bytecode system none none none - - for ocamlc -custom MSVC Cygwin Cygwin - - for native-code generation MSVC+MASM Cygwin Cygwin - -Speed of bytecode interpreter 70% 100% 100% - -Replay debugger no no yes - -The Unix library partial partial full - -The Threads library yes yes yes - -The Graphics library yes yes no - -Restrictions on generated executables? none none yes (*) - -(*) Cygwin-generated .exe files refer to a DLL that is distributed under -the GPL. Thus, these .exe files can only be distributed under a license -that is compatible with the GPL. Executables generated by MSVC or by -MinGW have no such restrictions. - -The remainder of this document gives more information on each port. - ------------------------------------------------------------------------------- - - The native Win32 port built with Microsoft Visual C - --------------------------------------------------- - -REQUIREMENTS: - -This port runs under MS Windows NT, 2000 and XP. -Windows 95, 98 and ME are also supported, but less reliably. - -The base bytecode system (ocamlc, ocaml, ocamllex, ocamlyacc, ...) -runs without any additional tools. - -Statically linking Caml bytecode with C code (ocamlc -custom) requires the -Microsoft Visual C++ compiler. Dynamic loading of DLLs is -supported out of the box, without additional software. - -The native-code compiler (ocamlopt) requires Visual C++ and the -Microsoft assembler MASM version 6.11 or later. MASM can be -downloaded for free from Microsoft's Web site; for directions, see - http://www.easystreet.com/~jkirwan/pctools.html - or http://www2.dgsys.com/~raymoon/faq/masm.html - or the comp.lang.asm.x86 FAQ. - -The LablTk GUI requires Tcl/Tk 8.3. Windows binaries are -available from http://prdownloads.sourceforge.net/tcl/tcl832.exe. - - -INSTALLATION: - -The binary distribution is a self-installing executable archive. -Just run it and it should install OCaml automatically. - -If you are using Windows 95, 98 or ME, you need to adjust environment -variables as follows: - - add the "bin" subdirectory of the OCaml installation directory - to the PATH variable; - - set the OCAMLLIB variable to the "lib" subdirectory of the - OCaml installation directory. -For instance, if you installed OCaml in C:\Program Files\Objective Caml, -add the following two lines at the end of C:\autoexec.bat: - - set PATH=%PATH%;"C:\Program Files\Objective Caml\bin" - set OCAMLLIB=C:\Program Files\Objective Caml\lib - -No such tweaking of environment variables is needed under NT, 2000 and XP. - -To run programs that use the LablTK GUI, the directory where the -DLLs tk83.dll and tcl83.dll were installed (by the Tcl/Tk -installer) must be added to the PATH environment variable. - -To compile programs that use the LablTK GUI, the directory where the -libraries tk83.lib and tcl83.lib were installed (by the Tcl/Tk -installer) must be added to the library search path in the LIB -environment variable. E.g. if Tcl/Tk was installed in C:\tcl, add -"C:\tcl\lib" to the LIB environment variable. - - -RECOMPILATION FROM THE SOURCES: - -The command-line tools can be recompiled from the Unix source -distribution (ocaml-X.YZ.tar.gz), which also contains the files modified -for Windows. - -You will need the following software components to perform the recompilation: -- Windows NT, 2000, or XP (we advise against compiling under Windows 95/98/ME) -- Visual C++ version 6 or 7 -- MASM version 6.11 (see above) -- The CygWin port of GNU tools, available from - http://sourceware.cygnus.com/cygwin/ -- TCL/TK version 8.3 (for the LablTK GUI) (see above). - -Remember to add the directory where the libraries tk83.lib and -tcl83.lib were installed (by the Tcl/Tk installer) to the LIB variable -(library search path). - -To recompile, start a Cygwin shell and change to the top-level -directory of the OCaml distribution. Then, do - - cp config/m-nt.h config/m.h - cp config/s-nt.h config/s.h - cp config/Makefile.msvc config/Makefile - -Then, edit config/Makefile as needed, following the comments in this file. -Normally, the only variables that need to be changed are - PREFIX where to install everything - TK_ROOT where TCL/TK was installed - -Finally, use "make -f Makefile.nt" to build the system, e.g. - - make -f Makefile.nt world - make -f Makefile.nt bootstrap - make -f Makefile.nt opt - make -f Makefile.nt install - - -NOTES: - -* The VC++ compiler does not implement "computed gotos", and therefore -generates inefficient code for byterun/interp.c. Consequently, the -performance of bytecode programs is about 2/3 of that obtained under -Unix/GCC or Cygwin or Mingw on similar hardware. - -* Libraries available in this port: "num", "str", "threads", "graphics", -"labltk", and large parts of "unix". - -* The replay debugger is not supported. - -CREDITS: - -The initial port of Caml Special Light (the ancestor of Objective Caml) -to Windows NT was done by Kevin Gallo at Microsoft Research, who -kindly contributed his changes to the Caml project. - -The graphical user interface for the toplevel is due to Jacob Navia. - ------------------------------------------------------------------------------- - - The native Win32 port built with Mingw - -------------------------------------- - -REQUIREMENTS: - -This port runs under MS Windows NT, 2000 and XP. -Windows 95, 98 and ME are also supported, but less reliably. - -The base bytecode system (ocamlc, ocaml, ocamllex, ocamlyacc, ...) -runs without any additional tools. - -The native-code compiler (ocamlopt), as well as static linking of -Caml bytecode with C code (ocamlc -custom), require -the Cygwin development tools, available at - http://sources.redhat.com/cygwin/ - -The LablTk GUI requires Tcl/Tk 8.3. Windows binaries are -available from http://prdownloads.sourceforge.net/tcl/tcl832.exe. - - -INSTALLATION: - -There is no binary distribution yet, so please follow the compilation -instructions below. - - -RECOMPILATION FROM THE SOURCES: - -You will need the following software components to perform the recompilation: -- Windows NT, 2000, or XP (we advise against compiling under Windows 95/98/ME) -- Cygwin: http://sourceware.cygnus.com/cygwin/ -- TCL/TK version 8.3 (see above). - -Start a Cygwin shell and unpack the source distribution -(ocaml-X.YZ.tar.gz) with "tar xzf". Change to the top-level -directory of the OCaml distribution. Then, do - - cp config/m-nt.h config/m.h - cp config/s-nt.h config/s.h - cp config/Makefile.mingw config/Makefile - -Then, edit config/Makefile as needed, following the comments in this file. -Normally, the only variables that need to be changed are - PREFIX where to install everything - TK_ROOT where TCL/TK was installed - -Finally, use "make -f Makefile.nt" to build the system, e.g. - - make -f Makefile.nt world - make -f Makefile.nt bootstrap - make -f Makefile.nt opt - make -f Makefile.nt opt.opt - make -f Makefile.nt install - - -NOTES: - -* Libraries available in this port: "num", "str", "threads", "graphics", - "labltk", and large parts of "unix". - -* The replay debugger is not supported. - ------------------------------------------------------------------------------- - - The Cygwin port of Objective Caml - --------------------------------- - -REQUIREMENTS: - -This port requires the Cygwin environment from Cygnus/RedHat, which -is freely available at: - http://sources.redhat.com/cygwin/ - -This port runs under all versions of MS Windows supported by Cygwin. - - -INSTALLATION: - -For various reasons, no binary distribution of this port is available. -You need to recompile from the source distribution. - - -RECOMPILATION FROM THE SOURCES: - -Just follow the instructions for Unix machines given in the file INSTALL. - - -NOTES: - -The libraries available in this port are "num", "str", "threads", -"unix" and "labltk". "graph" is not available yet. -The replay debugger is supported. - diff --git a/Upgrading b/Upgrading deleted file mode 100644 index fac604233a..0000000000 --- a/Upgrading +++ /dev/null @@ -1,109 +0,0 @@ - - FAQ: how to upgrade from Objective Caml 3.02 to 3.03 - -I Installation - -Q1: When compiling the distribution, I am getting strange linking - errors in otherlibraries. - -A1: This is probably a problem with dynamic linking. You can disable - it with ./configure -no-shared-libs. If you really want to use - shared libraries, look in the manual pages of your system for how - to get some debugging output from the dynamic linker. - -II Non-label changes - -Q2: I get a syntax error when I try to compile a program using stream - parsers. - -A2: Stream parser now require camlp4. It is included in the - distribution, and you just need to use "ocamlc -pp camlp4o" in - place of "ocamlc". You can also use it under the toplevel with - #load"camlp4o.cma". - -Q3: I get a warning when I use the syntax "#variant" inside type - expressions. - -A3: The new syntax is [< variant], which just a special case of - the more general new syntax, which allows type expressions like - [ variant1 | variant2] or [> variant]. See the reference manual - for details. - -III Label changes - -Q4: I was using labels before, and now I get lots of type errors. - -A4: The handling of labels changed with 3.03-alpha. The new default - is a more flexible version of the commuting label mode, allowing - one to omit labels in total applications. There is still a - -nolabels mode, but it does not allow non-optional labels in - applications (this was unsound). - To keep full compatibility with Objective Caml 2, labels were - removed from the standard libraries. Some labelized libraries are - kept as StdLabels (contains Array, List and String), MoreLabels - (contains Hashtbl, Map and Set), and UnixLabels. - Note that MoreLabels' status is not yet decided. - -Q5: Why isn't there a ThreadUnixLabels module ? - -A5: ThreadUnix is deprecated. It only calls directly the Unix module. - -Q6: I was using commuting label mode, how can I upgrade ? - -A6: The new behaviour is compatible with commuting label mode, but - standard libraries have no labels. You can add the following - lines at the beginning of your files (according to your needs): - open Stdlabels - open MoreLabels - module Unix = UnixLabels - Alternatively, if you already have a common module opened by - everybody, you can add these: - include StdLabels - include MoreLabels - module Unix = UnixLabels - - You will then need to remove labels in functions from other modules. - This can be automated by using the scrapelabels tool, installed - in the Objective Caml library directory, which both removes labels - and inserts needed `open' clauses (see -help for details). - $CAMLLIB/scrapelabels -keepstd *.ml - or - $CAMLLIB/scrapelabels -keepmore *.ml - Note that scrapelabels is not guaranteed to be sound for commuting - label programs, since it will just remove labels, and not reorder - arguments. - -Q7: I was using a few labels in classic mode, and now I get all these - errors. I just want to get rid of all these silly labels. - -A7: scrapelabels will do it for you. - $CAMLLIB/scrapelabels [-all] *.ml - $CAMLLIB/scrapelabels -intf *.mli - You should specify the -all option only if you are sure that your - sources do not contain calls to functions with optional - parameters, as those labels would also be removed. - -Q8: I was using labels in classic mode, and I was actually pretty fond - of them. How much more labels will I have to write now ? How can I - convert my programs and libraries ? - -A8: The new default mode is more flexible than the original commuting - mode, so that you shouldn't see too much differences when using - labeled libraries. Labels are only compulsory in partial - applications (including the special case of function with an - unkwnown return type), or if you wrote some of them. - - On the other hand, for definitions, labels present in the - interface must also be present in the implementation. - The addlabels tool can help you to do that. Suppose that you have - mymod.ml and mymod.mli, where mymod.mli adds some labels. Then - doing - $CAMLLIB/addlabels mymod.ml - will insert labels from the interface inside the implementation. - It also takes care of inserting them in recursive calls, as - the return type of the function is not known while typing it. - - If you used labels from standard libraries, you will also have - problems with them. You can proceed as described in A6. Since you - used classic mode, you do not need to bother about changed - argument order. \ No newline at end of file diff --git a/asmrun/.cvsignore b/asmrun/.cvsignore deleted file mode 100644 index ee21b35990..0000000000 --- a/asmrun/.cvsignore +++ /dev/null @@ -1,33 +0,0 @@ -main.c -misc.c -freelist.c -major_gc.c -minor_gc.c -memory.c -alloc.c -array.c -compare.c -ints.c -floats.c -str.c -io.c -extern.c -intern.c -hash.c -sys.c -parsing.c -gc_ctrl.c -terminfo.c -md5.c -obj.c -lexing.c -printexc.c -callback.c -weak.c -compact.c -finalise.c -custom.c -meta.c -globroots.c -unix.c -dynlink.c diff --git a/asmrun/.depend b/asmrun/.depend deleted file mode 100644 index 63c99b5b41..0000000000 --- a/asmrun/.depend +++ /dev/null @@ -1,498 +0,0 @@ -alloc.o: alloc.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../config/m.h ../config/s.h ../byterun/mlvalues.h ../byterun/custom.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/minor_gc.h ../byterun/stacks.h -array.o: array.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../config/m.h ../config/s.h ../byterun/mlvalues.h ../byterun/fail.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h -callback.o: callback.c ../byterun/callback.h ../byterun/mlvalues.h \ - ../byterun/config.h ../config/m.h ../config/s.h ../byterun/misc.h \ - ../byterun/fail.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h -compact.o: compact.c ../byterun/config.h ../config/m.h ../config/s.h \ - ../byterun/finalise.h ../byterun/roots.h ../byterun/misc.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/mlvalues.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/gc_ctrl.h ../byterun/weak.h -compare.o: compare.c ../byterun/custom.h ../byterun/mlvalues.h \ - ../byterun/config.h ../config/m.h ../config/s.h ../byterun/misc.h \ - ../byterun/fail.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h -custom.o: custom.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../config/m.h ../config/s.h ../byterun/mlvalues.h \ - ../byterun/custom.h ../byterun/fail.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h -dynlink.o: dynlink.c ../byterun/config.h ../config/m.h ../config/s.h \ - ../byterun/alloc.h ../byterun/misc.h ../byterun/mlvalues.h \ - ../byterun/dynlink.h ../byterun/fail.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/osdeps.h ../byterun/prims.h -extern.o: extern.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../config/m.h ../config/s.h ../byterun/mlvalues.h \ - ../byterun/custom.h ../byterun/fail.h ../byterun/gc.h \ - ../byterun/intext.h ../byterun/io.h ../byterun/memory.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/reverse.h -fail.o: fail.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../config/m.h ../config/s.h ../byterun/mlvalues.h ../byterun/fail.h \ - ../byterun/io.h ../byterun/gc.h ../byterun/memory.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/printexc.h ../byterun/signals.h stack.h ../byterun/roots.h -finalise.o: finalise.c ../byterun/callback.h ../byterun/mlvalues.h \ - ../byterun/config.h ../config/m.h ../config/s.h ../byterun/misc.h \ - ../byterun/fail.h ../byterun/roots.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/signals.h -floats.o: floats.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../config/m.h ../config/s.h ../byterun/mlvalues.h \ - ../byterun/fail.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/reverse.h ../byterun/stacks.h -freelist.o: freelist.c ../byterun/config.h ../config/m.h ../config/s.h \ - ../byterun/freelist.h ../byterun/misc.h ../byterun/mlvalues.h \ - ../byterun/gc.h ../byterun/gc_ctrl.h ../byterun/major_gc.h -gc_ctrl.o: gc_ctrl.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../config/m.h ../config/s.h ../byterun/mlvalues.h \ - ../byterun/compact.h ../byterun/custom.h ../byterun/finalise.h \ - ../byterun/roots.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/gc_ctrl.h ../byterun/stacks.h -globroots.o: globroots.c ../byterun/memory.h ../byterun/config.h \ - ../config/m.h ../config/s.h ../byterun/gc.h ../byterun/mlvalues.h \ - ../byterun/misc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/globroots.h -hash.o: hash.c ../byterun/mlvalues.h ../byterun/config.h ../config/m.h \ - ../config/s.h ../byterun/misc.h ../byterun/custom.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h -intern.o: intern.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../config/m.h ../config/s.h ../byterun/mlvalues.h \ - ../byterun/custom.h ../byterun/fail.h ../byterun/gc.h \ - ../byterun/intext.h ../byterun/io.h ../byterun/memory.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/reverse.h ../byterun/md5.h -ints.o: ints.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../config/m.h ../config/s.h ../byterun/mlvalues.h ../byterun/custom.h \ - ../byterun/fail.h ../byterun/intext.h ../byterun/io.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/int64_native.h -io.o: io.c ../byterun/config.h ../config/m.h ../config/s.h \ - ../byterun/alloc.h ../byterun/misc.h ../byterun/mlvalues.h \ - ../byterun/custom.h ../byterun/fail.h ../byterun/io.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/signals.h \ - ../byterun/sys.h -lexing.o: lexing.c ../byterun/fail.h ../byterun/misc.h \ - ../byterun/config.h ../config/m.h ../config/s.h ../byterun/mlvalues.h \ - ../byterun/stacks.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h -main.o: main.c ../byterun/misc.h ../byterun/config.h ../config/m.h \ - ../config/s.h ../byterun/mlvalues.h ../byterun/sys.h -major_gc.o: major_gc.c ../byterun/compact.h ../byterun/config.h \ - ../config/m.h ../config/s.h ../byterun/misc.h ../byterun/custom.h \ - ../byterun/mlvalues.h ../byterun/fail.h ../byterun/finalise.h \ - ../byterun/roots.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/gc_ctrl.h ../byterun/weak.h -md5.o: md5.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../config/m.h ../config/s.h ../byterun/mlvalues.h ../byterun/fail.h \ - ../byterun/md5.h ../byterun/io.h ../byterun/reverse.h -memory.o: memory.c ../byterun/fail.h ../byterun/misc.h \ - ../byterun/config.h ../config/m.h ../config/s.h ../byterun/mlvalues.h \ - ../byterun/freelist.h ../byterun/gc.h ../byterun/gc_ctrl.h \ - ../byterun/major_gc.h ../byterun/memory.h ../byterun/minor_gc.h \ - ../byterun/signals.h -meta.o: meta.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../config/m.h ../config/s.h ../byterun/mlvalues.h ../byterun/fail.h \ - ../byterun/fix_code.h ../byterun/interp.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/minor_gc.h ../byterun/prims.h ../byterun/stacks.h -minor_gc.o: minor_gc.c ../byterun/config.h ../config/m.h ../config/s.h \ - ../byterun/fail.h ../byterun/misc.h ../byterun/mlvalues.h \ - ../byterun/finalise.h ../byterun/roots.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/gc_ctrl.h ../byterun/signals.h -misc.o: misc.c ../byterun/config.h ../config/m.h ../config/s.h \ - ../byterun/misc.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/mlvalues.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h -obj.o: obj.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../config/m.h ../config/s.h ../byterun/mlvalues.h ../byterun/fail.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/memory.h ../byterun/minor_gc.h ../byterun/prims.h -parsing.o: parsing.c ../byterun/config.h ../config/m.h ../config/s.h \ - ../byterun/mlvalues.h ../byterun/misc.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/alloc.h -printexc.o: printexc.c ../byterun/backtrace.h ../byterun/mlvalues.h \ - ../byterun/config.h ../config/m.h ../config/s.h ../byterun/misc.h \ - ../byterun/callback.h ../byterun/debugger.h ../byterun/fail.h \ - ../byterun/printexc.h -roots.o: roots.c ../byterun/finalise.h ../byterun/roots.h \ - ../byterun/misc.h ../byterun/config.h ../config/m.h ../config/s.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/mlvalues.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/globroots.h stack.h -signals.o: signals.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../config/m.h ../config/s.h ../byterun/mlvalues.h \ - ../byterun/callback.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/fail.h ../byterun/signals.h stack.h ../byterun/sys.h -startup.o: startup.c ../byterun/callback.h ../byterun/mlvalues.h \ - ../byterun/config.h ../config/m.h ../config/s.h ../byterun/misc.h \ - ../byterun/custom.h ../byterun/fail.h ../byterun/gc.h \ - ../byterun/gc_ctrl.h ../byterun/osdeps.h ../byterun/printexc.h \ - ../byterun/sys.h -str.o: str.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../config/m.h ../config/s.h ../byterun/mlvalues.h ../byterun/fail.h -sys.o: sys.c ../byterun/config.h ../config/m.h ../config/s.h \ - ../byterun/alloc.h ../byterun/misc.h ../byterun/mlvalues.h \ - ../byterun/debugger.h ../byterun/fail.h ../byterun/instruct.h \ - ../byterun/osdeps.h ../byterun/signals.h ../byterun/stacks.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/sys.h -terminfo.o: terminfo.c ../byterun/config.h ../config/m.h ../config/s.h \ - ../byterun/alloc.h ../byterun/misc.h ../byterun/mlvalues.h \ - ../byterun/fail.h ../byterun/io.h -unix.o: unix.c ../byterun/config.h ../config/m.h ../config/s.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/mlvalues.h \ - ../byterun/misc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/osdeps.h -weak.o: weak.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../config/m.h ../config/s.h ../byterun/mlvalues.h ../byterun/fail.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h -alloc.d.o: alloc.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../config/m.h ../config/s.h ../byterun/mlvalues.h ../byterun/custom.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/minor_gc.h ../byterun/stacks.h -array.d.o: array.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../config/m.h ../config/s.h ../byterun/mlvalues.h ../byterun/fail.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h -callback.d.o: callback.c ../byterun/callback.h ../byterun/mlvalues.h \ - ../byterun/config.h ../config/m.h ../config/s.h ../byterun/misc.h \ - ../byterun/fail.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h -compact.d.o: compact.c ../byterun/config.h ../config/m.h ../config/s.h \ - ../byterun/finalise.h ../byterun/roots.h ../byterun/misc.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/mlvalues.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/gc_ctrl.h ../byterun/weak.h -compare.d.o: compare.c ../byterun/custom.h ../byterun/mlvalues.h \ - ../byterun/config.h ../config/m.h ../config/s.h ../byterun/misc.h \ - ../byterun/fail.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h -custom.d.o: custom.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../config/m.h ../config/s.h ../byterun/mlvalues.h \ - ../byterun/custom.h ../byterun/fail.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h -dynlink.d.o: dynlink.c ../byterun/config.h ../config/m.h ../config/s.h \ - ../byterun/alloc.h ../byterun/misc.h ../byterun/mlvalues.h \ - ../byterun/dynlink.h ../byterun/fail.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/osdeps.h ../byterun/prims.h -extern.d.o: extern.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../config/m.h ../config/s.h ../byterun/mlvalues.h \ - ../byterun/custom.h ../byterun/fail.h ../byterun/gc.h \ - ../byterun/intext.h ../byterun/io.h ../byterun/memory.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/reverse.h -fail.d.o: fail.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../config/m.h ../config/s.h ../byterun/mlvalues.h ../byterun/fail.h \ - ../byterun/io.h ../byterun/gc.h ../byterun/memory.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/printexc.h ../byterun/signals.h stack.h ../byterun/roots.h -finalise.d.o: finalise.c ../byterun/callback.h ../byterun/mlvalues.h \ - ../byterun/config.h ../config/m.h ../config/s.h ../byterun/misc.h \ - ../byterun/fail.h ../byterun/roots.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/signals.h -floats.d.o: floats.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../config/m.h ../config/s.h ../byterun/mlvalues.h \ - ../byterun/fail.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/reverse.h ../byterun/stacks.h -freelist.d.o: freelist.c ../byterun/config.h ../config/m.h ../config/s.h \ - ../byterun/freelist.h ../byterun/misc.h ../byterun/mlvalues.h \ - ../byterun/gc.h ../byterun/gc_ctrl.h ../byterun/major_gc.h -gc_ctrl.d.o: gc_ctrl.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../config/m.h ../config/s.h ../byterun/mlvalues.h \ - ../byterun/compact.h ../byterun/custom.h ../byterun/finalise.h \ - ../byterun/roots.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/gc_ctrl.h ../byterun/stacks.h -globroots.d.o: globroots.c ../byterun/memory.h ../byterun/config.h \ - ../config/m.h ../config/s.h ../byterun/gc.h ../byterun/mlvalues.h \ - ../byterun/misc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/globroots.h -hash.d.o: hash.c ../byterun/mlvalues.h ../byterun/config.h ../config/m.h \ - ../config/s.h ../byterun/misc.h ../byterun/custom.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h -intern.d.o: intern.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../config/m.h ../config/s.h ../byterun/mlvalues.h \ - ../byterun/custom.h ../byterun/fail.h ../byterun/gc.h \ - ../byterun/intext.h ../byterun/io.h ../byterun/memory.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/reverse.h ../byterun/md5.h -ints.d.o: ints.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../config/m.h ../config/s.h ../byterun/mlvalues.h ../byterun/custom.h \ - ../byterun/fail.h ../byterun/intext.h ../byterun/io.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/int64_native.h -io.d.o: io.c ../byterun/config.h ../config/m.h ../config/s.h \ - ../byterun/alloc.h ../byterun/misc.h ../byterun/mlvalues.h \ - ../byterun/custom.h ../byterun/fail.h ../byterun/io.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/signals.h \ - ../byterun/sys.h -lexing.d.o: lexing.c ../byterun/fail.h ../byterun/misc.h \ - ../byterun/config.h ../config/m.h ../config/s.h ../byterun/mlvalues.h \ - ../byterun/stacks.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h -main.d.o: main.c ../byterun/misc.h ../byterun/config.h ../config/m.h \ - ../config/s.h ../byterun/mlvalues.h ../byterun/sys.h -major_gc.d.o: major_gc.c ../byterun/compact.h ../byterun/config.h \ - ../config/m.h ../config/s.h ../byterun/misc.h ../byterun/custom.h \ - ../byterun/mlvalues.h ../byterun/fail.h ../byterun/finalise.h \ - ../byterun/roots.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/gc_ctrl.h ../byterun/weak.h -md5.d.o: md5.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../config/m.h ../config/s.h ../byterun/mlvalues.h ../byterun/fail.h \ - ../byterun/md5.h ../byterun/io.h ../byterun/reverse.h -memory.d.o: memory.c ../byterun/fail.h ../byterun/misc.h \ - ../byterun/config.h ../config/m.h ../config/s.h ../byterun/mlvalues.h \ - ../byterun/freelist.h ../byterun/gc.h ../byterun/gc_ctrl.h \ - ../byterun/major_gc.h ../byterun/memory.h ../byterun/minor_gc.h \ - ../byterun/signals.h -meta.d.o: meta.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../config/m.h ../config/s.h ../byterun/mlvalues.h ../byterun/fail.h \ - ../byterun/fix_code.h ../byterun/interp.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/minor_gc.h ../byterun/prims.h ../byterun/stacks.h -minor_gc.d.o: minor_gc.c ../byterun/config.h ../config/m.h ../config/s.h \ - ../byterun/fail.h ../byterun/misc.h ../byterun/mlvalues.h \ - ../byterun/finalise.h ../byterun/roots.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/gc_ctrl.h ../byterun/signals.h -misc.d.o: misc.c ../byterun/config.h ../config/m.h ../config/s.h \ - ../byterun/misc.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/mlvalues.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h -obj.d.o: obj.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../config/m.h ../config/s.h ../byterun/mlvalues.h ../byterun/fail.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/memory.h ../byterun/minor_gc.h ../byterun/prims.h -parsing.d.o: parsing.c ../byterun/config.h ../config/m.h ../config/s.h \ - ../byterun/mlvalues.h ../byterun/misc.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/alloc.h -printexc.d.o: printexc.c ../byterun/backtrace.h ../byterun/mlvalues.h \ - ../byterun/config.h ../config/m.h ../config/s.h ../byterun/misc.h \ - ../byterun/callback.h ../byterun/debugger.h ../byterun/fail.h \ - ../byterun/printexc.h -roots.d.o: roots.c ../byterun/finalise.h ../byterun/roots.h \ - ../byterun/misc.h ../byterun/config.h ../config/m.h ../config/s.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/mlvalues.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/globroots.h stack.h -signals.d.o: signals.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../config/m.h ../config/s.h ../byterun/mlvalues.h \ - ../byterun/callback.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/fail.h ../byterun/signals.h stack.h ../byterun/sys.h -startup.d.o: startup.c ../byterun/callback.h ../byterun/mlvalues.h \ - ../byterun/config.h ../config/m.h ../config/s.h ../byterun/misc.h \ - ../byterun/custom.h ../byterun/fail.h ../byterun/gc.h \ - ../byterun/gc_ctrl.h ../byterun/osdeps.h ../byterun/printexc.h \ - ../byterun/sys.h -str.d.o: str.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../config/m.h ../config/s.h ../byterun/mlvalues.h ../byterun/fail.h -sys.d.o: sys.c ../byterun/config.h ../config/m.h ../config/s.h \ - ../byterun/alloc.h ../byterun/misc.h ../byterun/mlvalues.h \ - ../byterun/debugger.h ../byterun/fail.h ../byterun/instruct.h \ - ../byterun/osdeps.h ../byterun/signals.h ../byterun/stacks.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/sys.h -terminfo.d.o: terminfo.c ../byterun/config.h ../config/m.h ../config/s.h \ - ../byterun/alloc.h ../byterun/misc.h ../byterun/mlvalues.h \ - ../byterun/fail.h ../byterun/io.h -unix.d.o: unix.c ../byterun/config.h ../config/m.h ../config/s.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/mlvalues.h \ - ../byterun/misc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/osdeps.h -weak.d.o: weak.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../config/m.h ../config/s.h ../byterun/mlvalues.h ../byterun/fail.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h -alloc.p.o: alloc.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../config/m.h ../config/s.h ../byterun/mlvalues.h ../byterun/custom.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/minor_gc.h ../byterun/stacks.h -array.p.o: array.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../config/m.h ../config/s.h ../byterun/mlvalues.h ../byterun/fail.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h -callback.p.o: callback.c ../byterun/callback.h ../byterun/mlvalues.h \ - ../byterun/config.h ../config/m.h ../config/s.h ../byterun/misc.h \ - ../byterun/fail.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h -compact.p.o: compact.c ../byterun/config.h ../config/m.h ../config/s.h \ - ../byterun/finalise.h ../byterun/roots.h ../byterun/misc.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/mlvalues.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/gc_ctrl.h ../byterun/weak.h -compare.p.o: compare.c ../byterun/custom.h ../byterun/mlvalues.h \ - ../byterun/config.h ../config/m.h ../config/s.h ../byterun/misc.h \ - ../byterun/fail.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h -custom.p.o: custom.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../config/m.h ../config/s.h ../byterun/mlvalues.h \ - ../byterun/custom.h ../byterun/fail.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h -dynlink.p.o: dynlink.c ../byterun/config.h ../config/m.h ../config/s.h \ - ../byterun/alloc.h ../byterun/misc.h ../byterun/mlvalues.h \ - ../byterun/dynlink.h ../byterun/fail.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/osdeps.h ../byterun/prims.h -extern.p.o: extern.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../config/m.h ../config/s.h ../byterun/mlvalues.h \ - ../byterun/custom.h ../byterun/fail.h ../byterun/gc.h \ - ../byterun/intext.h ../byterun/io.h ../byterun/memory.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/reverse.h -fail.p.o: fail.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../config/m.h ../config/s.h ../byterun/mlvalues.h ../byterun/fail.h \ - ../byterun/io.h ../byterun/gc.h ../byterun/memory.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/printexc.h ../byterun/signals.h stack.h ../byterun/roots.h -finalise.p.o: finalise.c ../byterun/callback.h ../byterun/mlvalues.h \ - ../byterun/config.h ../config/m.h ../config/s.h ../byterun/misc.h \ - ../byterun/fail.h ../byterun/roots.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/signals.h -floats.p.o: floats.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../config/m.h ../config/s.h ../byterun/mlvalues.h \ - ../byterun/fail.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/reverse.h ../byterun/stacks.h -freelist.p.o: freelist.c ../byterun/config.h ../config/m.h ../config/s.h \ - ../byterun/freelist.h ../byterun/misc.h ../byterun/mlvalues.h \ - ../byterun/gc.h ../byterun/gc_ctrl.h ../byterun/major_gc.h -gc_ctrl.p.o: gc_ctrl.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../config/m.h ../config/s.h ../byterun/mlvalues.h \ - ../byterun/compact.h ../byterun/custom.h ../byterun/finalise.h \ - ../byterun/roots.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/gc_ctrl.h ../byterun/stacks.h -globroots.p.o: globroots.c ../byterun/memory.h ../byterun/config.h \ - ../config/m.h ../config/s.h ../byterun/gc.h ../byterun/mlvalues.h \ - ../byterun/misc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/globroots.h -hash.p.o: hash.c ../byterun/mlvalues.h ../byterun/config.h ../config/m.h \ - ../config/s.h ../byterun/misc.h ../byterun/custom.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h -intern.p.o: intern.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../config/m.h ../config/s.h ../byterun/mlvalues.h \ - ../byterun/custom.h ../byterun/fail.h ../byterun/gc.h \ - ../byterun/intext.h ../byterun/io.h ../byterun/memory.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/reverse.h ../byterun/md5.h -ints.p.o: ints.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../config/m.h ../config/s.h ../byterun/mlvalues.h ../byterun/custom.h \ - ../byterun/fail.h ../byterun/intext.h ../byterun/io.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/int64_native.h -io.p.o: io.c ../byterun/config.h ../config/m.h ../config/s.h \ - ../byterun/alloc.h ../byterun/misc.h ../byterun/mlvalues.h \ - ../byterun/custom.h ../byterun/fail.h ../byterun/io.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/signals.h \ - ../byterun/sys.h -lexing.p.o: lexing.c ../byterun/fail.h ../byterun/misc.h \ - ../byterun/config.h ../config/m.h ../config/s.h ../byterun/mlvalues.h \ - ../byterun/stacks.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h -main.p.o: main.c ../byterun/misc.h ../byterun/config.h ../config/m.h \ - ../config/s.h ../byterun/mlvalues.h ../byterun/sys.h -major_gc.p.o: major_gc.c ../byterun/compact.h ../byterun/config.h \ - ../config/m.h ../config/s.h ../byterun/misc.h ../byterun/custom.h \ - ../byterun/mlvalues.h ../byterun/fail.h ../byterun/finalise.h \ - ../byterun/roots.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/gc_ctrl.h ../byterun/weak.h -md5.p.o: md5.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../config/m.h ../config/s.h ../byterun/mlvalues.h ../byterun/fail.h \ - ../byterun/md5.h ../byterun/io.h ../byterun/reverse.h -memory.p.o: memory.c ../byterun/fail.h ../byterun/misc.h \ - ../byterun/config.h ../config/m.h ../config/s.h ../byterun/mlvalues.h \ - ../byterun/freelist.h ../byterun/gc.h ../byterun/gc_ctrl.h \ - ../byterun/major_gc.h ../byterun/memory.h ../byterun/minor_gc.h \ - ../byterun/signals.h -meta.p.o: meta.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../config/m.h ../config/s.h ../byterun/mlvalues.h ../byterun/fail.h \ - ../byterun/fix_code.h ../byterun/interp.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/minor_gc.h ../byterun/prims.h ../byterun/stacks.h -minor_gc.p.o: minor_gc.c ../byterun/config.h ../config/m.h ../config/s.h \ - ../byterun/fail.h ../byterun/misc.h ../byterun/mlvalues.h \ - ../byterun/finalise.h ../byterun/roots.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/gc_ctrl.h ../byterun/signals.h -misc.p.o: misc.c ../byterun/config.h ../config/m.h ../config/s.h \ - ../byterun/misc.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/mlvalues.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h -obj.p.o: obj.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../config/m.h ../config/s.h ../byterun/mlvalues.h ../byterun/fail.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/memory.h ../byterun/minor_gc.h ../byterun/prims.h -parsing.p.o: parsing.c ../byterun/config.h ../config/m.h ../config/s.h \ - ../byterun/mlvalues.h ../byterun/misc.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/alloc.h -printexc.p.o: printexc.c ../byterun/backtrace.h ../byterun/mlvalues.h \ - ../byterun/config.h ../config/m.h ../config/s.h ../byterun/misc.h \ - ../byterun/callback.h ../byterun/debugger.h ../byterun/fail.h \ - ../byterun/printexc.h -roots.p.o: roots.c ../byterun/finalise.h ../byterun/roots.h \ - ../byterun/misc.h ../byterun/config.h ../config/m.h ../config/s.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/mlvalues.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/globroots.h stack.h -signals.p.o: signals.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../config/m.h ../config/s.h ../byterun/mlvalues.h \ - ../byterun/callback.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/fail.h ../byterun/signals.h stack.h ../byterun/sys.h -startup.p.o: startup.c ../byterun/callback.h ../byterun/mlvalues.h \ - ../byterun/config.h ../config/m.h ../config/s.h ../byterun/misc.h \ - ../byterun/custom.h ../byterun/fail.h ../byterun/gc.h \ - ../byterun/gc_ctrl.h ../byterun/osdeps.h ../byterun/printexc.h \ - ../byterun/sys.h -str.p.o: str.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../config/m.h ../config/s.h ../byterun/mlvalues.h ../byterun/fail.h -sys.p.o: sys.c ../byterun/config.h ../config/m.h ../config/s.h \ - ../byterun/alloc.h ../byterun/misc.h ../byterun/mlvalues.h \ - ../byterun/debugger.h ../byterun/fail.h ../byterun/instruct.h \ - ../byterun/osdeps.h ../byterun/signals.h ../byterun/stacks.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/sys.h -terminfo.p.o: terminfo.c ../byterun/config.h ../config/m.h ../config/s.h \ - ../byterun/alloc.h ../byterun/misc.h ../byterun/mlvalues.h \ - ../byterun/fail.h ../byterun/io.h -unix.p.o: unix.c ../byterun/config.h ../config/m.h ../config/s.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/mlvalues.h \ - ../byterun/misc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/osdeps.h -weak.p.o: weak.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../config/m.h ../config/s.h ../byterun/mlvalues.h ../byterun/fail.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h diff --git a/asmrun/Makefile b/asmrun/Makefile deleted file mode 100644 index ee94d50ed7..0000000000 --- a/asmrun/Makefile +++ /dev/null @@ -1,195 +0,0 @@ -######################################################################### -# # -# Objective Caml # -# # -# Xavier Leroy, projet Cristal, INRIA Rocquencourt # -# # -# Copyright 1999 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the GNU Library General Public License, with # -# the special exception on linking described in file ../LICENSE. # -# # -######################################################################### - -# $Id$ - -include ../config/Makefile - -CC=$(NATIVECC) -FLAGS=-I../byterun -DNATIVE_CODE -DTARGET_$(ARCH) -DSYS_$(SYSTEM) -CFLAGS=$(FLAGS) -O $(NATIVECCCOMPOPTS) -DFLAGS=$(FLAGS) -g -DDEBUG $(NATIVECCCOMPOPTS) -PFLAGS=$(FLAGS) -pg -O -DPROFILING $(NATIVECCPROFOPTS) - -COBJS=startup.o main.o fail.o roots.o globroots.o signals.o \ - misc.o freelist.o major_gc.o minor_gc.o memory.o alloc.o compare.o ints.o \ - floats.o str.o array.o io.o extern.o intern.o hash.o sys.o parsing.o \ - gc_ctrl.o terminfo.o md5.o obj.o lexing.o printexc.o callback.o weak.o \ - compact.o finalise.o custom.o unix.o - -ASMOBJS=$(ARCH).o - -OBJS=$(COBJS) $(ASMOBJS) -DOBJS=$(COBJS:.o=.d.o) $(ASMOBJS) -POBJS=$(COBJS:.o=.p.o) $(ASMOBJS:.o=.p.o) - -all: libasmrun.a all-$(PROFILING) - -libasmrun.a: $(OBJS) - rm -f libasmrun.a - ar rc libasmrun.a $(OBJS) - $(RANLIB) libasmrun.a - -libasmrund.a: $(DOBJS) - rm -f libasmrund.a - ar rc libasmrund.a $(DOBJS) - $(RANLIB) libasmrund.a - -all-noprof: - -all-prof: libasmrunp.a - -libasmrunp.a: $(POBJS) - rm -f libasmrunp.a - ar rc libasmrunp.a $(POBJS) - $(RANLIB) libasmrunp.a - -install: install-default install-$(PROFILING) - -install-default: - cp libasmrun.a $(LIBDIR)/libasmrun.a - cd $(LIBDIR); $(RANLIB) libasmrun.a - -install-noprof: - rm -f $(LIBDIR)/libasmrunp.a; ln -s libasmrun.a $(LIBDIR)/libasmrunp.a - -install-prof: - cp libasmrunp.a $(LIBDIR)/libasmrunp.a - cd $(LIBDIR); $(RANLIB) libasmrunp.a - -power.o: power-$(SYSTEM).o - cp power-$(SYSTEM).o power.o - -power.p.o: power-$(SYSTEM).o - cp power-$(SYSTEM).o power.p.o - -main.c: ../byterun/main.c - ln -s ../byterun/main.c main.c -misc.c: ../byterun/misc.c - ln -s ../byterun/misc.c misc.c -freelist.c: ../byterun/freelist.c - ln -s ../byterun/freelist.c freelist.c -major_gc.c: ../byterun/major_gc.c - ln -s ../byterun/major_gc.c major_gc.c -minor_gc.c: ../byterun/minor_gc.c - ln -s ../byterun/minor_gc.c minor_gc.c -memory.c: ../byterun/memory.c - ln -s ../byterun/memory.c memory.c -alloc.c: ../byterun/alloc.c - ln -s ../byterun/alloc.c alloc.c -array.c: ../byterun/array.c - ln -s ../byterun/array.c array.c -compare.c: ../byterun/compare.c - ln -s ../byterun/compare.c compare.c -ints.c: ../byterun/ints.c - ln -s ../byterun/ints.c ints.c -floats.c: ../byterun/floats.c - ln -s ../byterun/floats.c floats.c -str.c: ../byterun/str.c - ln -s ../byterun/str.c str.c -io.c: ../byterun/io.c - ln -s ../byterun/io.c io.c -extern.c: ../byterun/extern.c - ln -s ../byterun/extern.c extern.c -intern.c: ../byterun/intern.c - ln -s ../byterun/intern.c intern.c -hash.c: ../byterun/hash.c - ln -s ../byterun/hash.c hash.c -sys.c: ../byterun/sys.c - ln -s ../byterun/sys.c sys.c -parsing.c: ../byterun/parsing.c - ln -s ../byterun/parsing.c parsing.c -gc_ctrl.c: ../byterun/gc_ctrl.c - ln -s ../byterun/gc_ctrl.c gc_ctrl.c -terminfo.c: ../byterun/terminfo.c - ln -s ../byterun/terminfo.c terminfo.c -md5.c: ../byterun/md5.c - ln -s ../byterun/md5.c md5.c -obj.c: ../byterun/obj.c - ln -s ../byterun/obj.c obj.c -lexing.c: ../byterun/lexing.c - ln -s ../byterun/lexing.c lexing.c -printexc.c: ../byterun/printexc.c - ln -s ../byterun/printexc.c printexc.c -callback.c: ../byterun/callback.c - ln -s ../byterun/callback.c callback.c -weak.c: ../byterun/weak.c - ln -s ../byterun/weak.c weak.c -compact.c: ../byterun/compact.c - ln -s ../byterun/compact.c compact.c -finalise.c: ../byterun/finalise.c - ln -s ../byterun/finalise.c finalise.c -custom.c: ../byterun/custom.c - ln -s ../byterun/custom.c custom.c -meta.c: ../byterun/meta.c - ln -s ../byterun/meta.c meta.c -globroots.c: ../byterun/globroots.c - ln -s ../byterun/globroots.c globroots.c -unix.c: ../byterun/unix.c - ln -s ../byterun/unix.c unix.c -dynlink.c: ../byterun/dynlink.c - ln -s ../byterun/dynlink.c dynlink.c - -LINKEDFILES=misc.c freelist.c major_gc.c minor_gc.c memory.c alloc.c array.c \ - compare.c ints.c floats.c str.c io.c extern.c intern.c hash.c sys.c \ - parsing.c gc_ctrl.c terminfo.c md5.c obj.c lexing.c printexc.c callback.c \ - weak.c compact.c finalise.c meta.c custom.c main.c globroots.c unix.c \ - dynlink.c - -clean:: - rm -f $(LINKEDFILES) - -# For HPUX, we can't use gcc as ASPP because it may have been configured with -# the vendor's assembler -hppa.o: hppa.S - gcc -traditional -E -DSYS_$(SYSTEM) -o hppa.s hppa.S - gas -o hppa.o hppa.s || { rm -f hppa.s; exit 2; } - rm -f hppa.s - -.SUFFIXES: .S .d.o .p.o - -.S.o: - $(ASPP) $(ASPPFLAGS) -o $*.o $*.S || \ - { echo "If your assembler produced syntax errors, it is probably unhappy with the"; echo "preprocessor. Check your assembler, or try producing $*.o by hand."; exit 2; } - -.S.p.o: - $(ASPP) $(ASPPFLAGS) $(ASPPPROFFLAGS) -o $*.p.o $*.S - -.c.d.o: - @ if test -f $*.o; then mv $*.o $*.f.o; else :; fi - $(CC) -c $(DFLAGS) $< - mv $*.o $*.d.o - @ if test -f $*.f.o; then mv $*.f.o $*.o; else :; fi - -.c.p.o: - @ if test -f $*.o; then mv $*.o $*.f.o; else :; fi - $(CC) -c $(PFLAGS) $< - mv $*.o $*.p.o - @ if test -f $*.f.o; then mv $*.f.o $*.o; else :; fi - -.s.o: - $(ASPP) $(ASPPFLAGS) -o $*.o $*.s - -.s.p.o: - $(ASPP) $(ASPPFLAGS) $(ASPPPROFFLAGS) -o $*.p.o $*.s - -clean:: - rm -f *.o *.a *~ - -depend: $(COBJS:.o=.c) ${LINKEDFILES} - gcc -MM $(FLAGS) *.c > .depend - gcc -MM $(FLAGS) -DDEBUG *.c | sed -e 's/\.o/.d.o/' >> .depend - gcc -MM $(FLAGS) -DDEBUG *.c | sed -e 's/\.o/.p.o/' >> .depend - -include .depend - diff --git a/asmrun/Makefile.nt b/asmrun/Makefile.nt deleted file mode 100644 index d505b25a96..0000000000 --- a/asmrun/Makefile.nt +++ /dev/null @@ -1,77 +0,0 @@ -######################################################################### -# # -# Objective Caml # -# # -# Xavier Leroy, projet Cristal, INRIA Rocquencourt # -# # -# Copyright 1999 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the GNU Library General Public License, with # -# the special exception on linking described in file ../LICENSE. # -# # -######################################################################### - -# $Id$ - -include ../config/Makefile - -CC=$(NATIVECC) -CFLAGS=-I../byterun -DNATIVE_CODE -DTARGET_$(ARCH) -DSYS_$(SYSTEM) $(NATIVECCCOMPOPTS) - -COBJS=startup.$(O) main.$(O) fail.$(O) roots.$(O) signals.$(O) \ - misc.$(O) freelist.$(O) major_gc.$(O) minor_gc.$(O) memory.$(O) alloc.$(O) \ - compare.$(O) ints.$(O) floats.$(O) str.$(O) array.$(O) io.$(O) extern.$(O) \ - intern.$(O) hash.$(O) sys.$(O) parsing.$(O) gc_ctrl.$(O) terminfo.$(O) \ - md5.$(O) obj.$(O) lexing.$(O) win32.$(O) printexc.$(O) callback.$(O) \ - weak.$(O) compact.$(O) finalise.$(O) custom.$(O) globroots.$(O) - -LINKEDFILES=misc.c freelist.c major_gc.c minor_gc.c memory.c alloc.c array.c \ - compare.c ints.c floats.c str.c io.c extern.c intern.c hash.c sys.c \ - parsing.c gc_ctrl.c terminfo.c md5.c obj.c lexing.c printexc.c callback.c \ - weak.c compact.c meta.c finalise.c custom.c main.c globroots.c \ - dynlink.c - -ifeq ($(TOOLCHAIN),mingw) -ASMOBJS=i386.o -else -ASMOBJS=i386nt.obj -endif - -OBJS=$(COBJS) $(ASMOBJS) - -all: libasmrun.$(A) - -libasmrun.$(A): $(OBJS) - $(call MKLIB,libasmrun.$(A), $(OBJS)) - -i386nt.obj: i386nt.asm - ml /nologo /coff /Cp /c /Foi386nt.obj i386nt.asm - -i386.o: i386.S - $(CC) -c -DSYS_$(SYSTEM) i386.S - -install: - cp libasmrun.$(A) $(LIBDIR) - -$(LINKEDFILES): %.c: ../byterun/%.c - cp ../byterun/$*.c $*.c - -# Need special compilation rule so as not to do -I../byterun -win32.$(O): ../byterun/win32.c - $(CC) -c $(NATIVECCCOMPOPTS) -DNATIVE_CODE ../byterun/win32.c - -.SUFFIXES: .c .$(O) - -.c.$(O): - $(CC) $(CFLAGS) -c $< - -clean:: - rm -f $(LINKEDFILES) - -clean:: - rm -f *.$(O) *.$(A) *~ - -.depend.nt: - sed -e 's/\.o/.$(O)/g' .depend > .depend.nt - -include .depend.nt diff --git a/asmrun/alpha.S b/asmrun/alpha.S deleted file mode 100644 index 99c71dd8d6..0000000000 --- a/asmrun/alpha.S +++ /dev/null @@ -1,440 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 1996 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 file ../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -/* Asm part of the runtime system, Alpha processor */ - -/* Allocation */ - - .text - .globl caml_alloc2 - .globl caml_alloc3 - .globl caml_alloc - .globl caml_call_gc - -/* Note: the profiling code sets $27 to the address of the "normal" entrypoint. - So don't pass parameters to those routines in $27. */ - -/* caml_alloc* : all code generator registers preserved, - $gp preserved, $27 not necessarily valid on entry */ - - .globl caml_alloc1 - .ent caml_alloc1 - .align 3 -caml_alloc1: - .prologue 0 - subq $13, 16, $13 - cmpult $13, $14, $25 - bne $25, $100 - ret ($26) -$100: ldiq $25, 16 - br $110 - .end caml_alloc1 - - .globl caml_alloc2 - .ent caml_alloc2 - .align 3 -caml_alloc2: - .prologue 0 - subq $13, 24, $13 - cmpult $13, $14, $25 - bne $25, $101 - ret ($26) -$101: ldiq $25, 24 - br $110 - .end caml_alloc2 - - .globl caml_alloc3 - .ent caml_alloc3 - .align 3 -caml_alloc3: - .prologue 0 - subq $13, 32, $13 - cmpult $13, $14, $25 - bne $25, $102 - ret ($26) -$102: ldiq $25, 32 - br $110 - .end caml_alloc3 - - .globl caml_alloc - .ent caml_alloc - .align 3 -caml_alloc: - .prologue 0 - subq $13, $25, $13 - .set noat - cmpult $13, $14, $at - bne $at, $110 - .set at - ret ($26) - .end caml_alloc - - .globl caml_call_gc - .ent caml_call_gc - .align 3 -caml_call_gc: - .prologue 0 - ldiq $25, 0 -$110: lda $sp, -0x200($sp) - /* 0x200 = 32*8 (ints) + 32*8 (floats) */ - stq $26, 0x1F8($sp) /* return address */ - stq $gp, 0x1F0($sp) /* caller's $gp */ - stq $25, 0x1E8($sp) /* desired size */ - /* Rebuild $gp */ - br $27, $103 -$103: ldgp $gp, 0($27) - /* Record lowest stack address, return address, GC regs */ - stq $26, caml_last_return_address - lda $24, 0x200($sp) - stq $24, caml_bottom_of_stack - lda $24, 0x100($sp) - stq $24, caml_gc_regs - /* Save current allocation pointer for debugging purposes */ -$113: stq $13, young_ptr - /* Save trap pointer in case an exception is raised (e.g. sighandler) */ - stq $15, caml_exception_pointer - /* Save all integer regs used by the code generator in the context */ - stq $0, 0 * 8 ($24) - stq $1, 1 * 8 ($24) - stq $2, 2 * 8 ($24) - stq $3, 3 * 8 ($24) - stq $4, 4 * 8 ($24) - stq $5, 5 * 8 ($24) - stq $6, 6 * 8 ($24) - stq $7, 7 * 8 ($24) - stq $8, 8 * 8 ($24) - stq $9, 9 * 8 ($24) - stq $10, 10 * 8 ($24) - stq $11, 11 * 8 ($24) - stq $12, 12 * 8 ($24) - stq $16, 16 * 8 ($24) - stq $17, 17 * 8 ($24) - stq $18, 18 * 8 ($24) - stq $19, 19 * 8 ($24) - stq $20, 20 * 8 ($24) - stq $21, 21 * 8 ($24) - stq $22, 22 * 8 ($24) - /* Save all float regs that are not callee-save on the stack */ - stt $f0, 0 * 8 ($sp) - stt $f1, 1 * 8 ($sp) - stt $f10, 10 * 8 ($sp) - stt $f11, 11 * 8 ($sp) - stt $f12, 12 * 8 ($sp) - stt $f13, 13 * 8 ($sp) - stt $f14, 14 * 8 ($sp) - stt $f15, 15 * 8 ($sp) - stt $f16, 16 * 8 ($sp) - stt $f17, 17 * 8 ($sp) - stt $f18, 18 * 8 ($sp) - stt $f19, 19 * 8 ($sp) - stt $f20, 20 * 8 ($sp) - stt $f21, 21 * 8 ($sp) - stt $f22, 22 * 8 ($sp) - stt $f23, 23 * 8 ($sp) - stt $f24, 24 * 8 ($sp) - stt $f25, 25 * 8 ($sp) - stt $f26, 26 * 8 ($sp) - stt $f27, 27 * 8 ($sp) - stt $f29, 29 * 8 ($sp) - stt $f30, 30 * 8 ($sp) - /* Call the garbage collector */ - jsr garbage_collection - ldgp $gp, 0($26) - /* Restore all regs used by the code generator */ - lda $24, 0x100($sp) - ldq $0, 0 * 8 ($24) - ldq $1, 1 * 8 ($24) - ldq $2, 2 * 8 ($24) - ldq $3, 3 * 8 ($24) - ldq $4, 4 * 8 ($24) - ldq $5, 5 * 8 ($24) - ldq $6, 6 * 8 ($24) - ldq $7, 7 * 8 ($24) - ldq $8, 8 * 8 ($24) - ldq $9, 9 * 8 ($24) - ldq $10, 10 * 8 ($24) - ldq $11, 11 * 8 ($24) - ldq $12, 12 * 8 ($24) - ldq $16, 16 * 8 ($24) - ldq $17, 17 * 8 ($24) - ldq $18, 18 * 8 ($24) - ldq $19, 19 * 8 ($24) - ldq $20, 20 * 8 ($24) - ldq $21, 21 * 8 ($24) - ldq $22, 22 * 8 ($24) - ldt $f0, 0 * 8 ($sp) - ldt $f1, 1 * 8 ($sp) - ldt $f10, 10 * 8 ($sp) - ldt $f11, 11 * 8 ($sp) - ldt $f12, 12 * 8 ($sp) - ldt $f13, 13 * 8 ($sp) - ldt $f14, 14 * 8 ($sp) - ldt $f15, 15 * 8 ($sp) - ldt $f16, 16 * 8 ($sp) - ldt $f17, 17 * 8 ($sp) - ldt $f18, 18 * 8 ($sp) - ldt $f19, 19 * 8 ($sp) - ldt $f20, 20 * 8 ($sp) - ldt $f21, 21 * 8 ($sp) - ldt $f22, 22 * 8 ($sp) - ldt $f23, 23 * 8 ($sp) - ldt $f24, 24 * 8 ($sp) - ldt $f25, 25 * 8 ($sp) - ldt $f26, 26 * 8 ($sp) - ldt $f27, 27 * 8 ($sp) - ldt $f29, 29 * 8 ($sp) - ldt $f30, 30 * 8 ($sp) - /* Reload new allocation pointer and allocation limit */ - ldq $13, young_ptr - ldq $14, young_limit - /* Allocate space for the block */ - ldq $25, 0x1E8($sp) - subq $13, $25, $13 - cmpult $13, $14, $25 /* Check that we have enough free space */ - bne $25, $113 /* If not, call GC again */ - /* Say that we are back into Caml code */ - stq $31, caml_last_return_address - /* Return to caller */ - ldq $26, 0x1F8($sp) - ldq $gp, 0x1F0($sp) - lda $sp, 0x200($sp) - ret ($26) - - .end caml_call_gc - -/* Call a C function from Caml */ -/* Function to call is in $25 */ - - .globl caml_c_call - .ent caml_c_call - .align 3 -caml_c_call: - .prologue 0 - /* Preserve return address and caller's $gp in callee-save registers */ - mov $26, $9 - mov $gp, $10 - /* Rebuild $gp */ - br $27, $104 -$104: ldgp $gp, 0($27) - /* Record lowest stack address and return address */ - lda $11, caml_last_return_address - stq $26, 0($11) - stq $sp, caml_bottom_of_stack - /* Make the exception handler and alloc ptr available to the C code */ - lda $12, young_ptr - stq $13, 0($12) - lda $14, young_limit - stq $15, caml_exception_pointer - /* Call the function */ - mov $25, $27 - jsr ($25) - /* Reload alloc ptr and alloc limit */ - ldq $13, 0($12) /* $12 still points to young_ptr */ - ldq $14, 0($14) /* $14 still points to young_limit */ - /* Say that we are back into Caml code */ - stq $31, 0($11) /* $11 still points to caml_last_return_address */ - /* Restore $gp */ - mov $10, $gp - /* Return */ - ret ($9) - - .end caml_c_call - -/* Start the Caml program */ - - .globl caml_start_program - .ent caml_start_program - .align 3 -caml_start_program: - ldgp $gp, 0($27) - lda $25, caml_program - -/* Code shared with callback* */ -$107: - /* Save return address */ - lda $sp, -128($sp) - stq $26, 0($sp) - /* Save all callee-save registers */ - stq $9, 8($sp) - stq $10, 16($sp) - stq $11, 24($sp) - stq $12, 32($sp) - stq $13, 40($sp) - stq $14, 48($sp) - stq $15, 56($sp) - stt $f2, 64($sp) - stt $f3, 72($sp) - stt $f4, 80($sp) - stt $f5, 88($sp) - stt $f6, 96($sp) - stt $f7, 104($sp) - stt $f8, 112($sp) - stt $f9, 120($sp) - /* Set up a callback link on the stack. */ - lda $sp, -32($sp) - ldq $0, caml_bottom_of_stack - stq $0, 0($sp) - ldq $1, caml_last_return_address - stq $1, 8($sp) - ldq $1, caml_gc_regs - stq $1, 16($sp) - /* Set up a trap frame to catch exceptions escaping the Caml code */ - lda $sp, -16($sp) - ldq $15, caml_exception_pointer - stq $15, 0($sp) - lda $0, $109 - stq $0, 8($sp) - mov $sp, $15 - /* Reload allocation pointers */ - ldq $13, young_ptr - ldq $14, young_limit - /* We are back into Caml code */ - stq $31, caml_last_return_address - /* Call the Caml code */ - mov $25, $27 -$108: jsr ($25) - /* Reload $gp, masking off low bit in retaddr (might have been marked) */ - bic $26, 1, $26 - ldgp $gp, 4($26) - /* Pop the trap frame, restoring caml_exception_pointer */ - ldq $15, 0($sp) - stq $15, caml_exception_pointer - lda $sp, 16($sp) - /* Pop the callback link, restoring the global variables */ -$112: ldq $24, 0($sp) - stq $24, caml_bottom_of_stack - ldq $25, 8($sp) - stq $25, caml_last_return_address - ldq $24, 16($sp) - stq $24, caml_gc_regs - lda $sp, 32($sp) - /* Update allocation pointer */ - stq $13, young_ptr - /* Reload callee-save registers */ - ldq $9, 8($sp) - ldq $10, 16($sp) - ldq $11, 24($sp) - ldq $12, 32($sp) - ldq $13, 40($sp) - ldq $14, 48($sp) - ldq $15, 56($sp) - ldt $f2, 64($sp) - ldt $f3, 72($sp) - ldt $f4, 80($sp) - ldt $f5, 88($sp) - ldt $f6, 96($sp) - ldt $f7, 104($sp) - ldt $f8, 112($sp) - ldt $f9, 120($sp) - /* Return to caller */ - ldq $26, 0($sp) - lda $sp, 128($sp) - ret ($26) - - /* The trap handler */ -$109: ldgp $gp, 0($26) - /* Save exception pointer */ - stq $15, caml_exception_pointer - /* Encode exception bucket as an exception result */ - or $0, 2, $0 - /* Return it */ - br $112 - - .end caml_start_program - -/* Raise an exception from C */ - - .globl raise_caml_exception - .ent raise_caml_exception - .align 3 -raise_caml_exception: - ldgp $gp, 0($27) - mov $16, $0 /* Move exn bucket */ - ldq $13, young_ptr - ldq $14, young_limit - stq $31, caml_last_return_address /* We're back into Caml */ - ldq $sp, caml_exception_pointer - ldq $15, 0($sp) - ldq $26, 8($sp) - lda $sp, 16($sp) - jmp $25, ($26) /* Keep retaddr in $25 to help debugging */ - .end raise_caml_exception - -/* Callback from C to Caml */ - - .globl callback_exn - .ent callback_exn - .align 3 -callback_exn: - /* Initial shuffling of arguments */ - ldgp $gp, 0($27) - mov $16, $25 - mov $17, $16 /* first arg */ - mov $25, $17 /* environment */ - ldq $25, 0($25) /* code pointer */ - br $107 - .end callback_exn - - .globl callback2_exn - .ent callback2_exn - .align 3 -callback2_exn: - ldgp $gp, 0($27) - mov $16, $25 - mov $17, $16 /* first arg */ - mov $18, $17 /* second arg */ - mov $25, $18 /* environment */ - lda $25, caml_apply2 - br $107 - .end callback2_exn - - .globl callback3_exn - .ent callback3_exn - .align 3 -callback3_exn: - ldgp $gp, 0($27) - mov $16, $25 - mov $17, $16 /* first arg */ - mov $18, $17 /* second arg */ - mov $19, $18 /* third arg */ - mov $25, $19 /* environment */ - lda $25, caml_apply3 - br $107 - .end callback3_exn - -/* Glue code to call array_bound_error */ - - .globl caml_array_bound_error - .ent caml_array_bound_error - .align 3 -caml_array_bound_error: - br $27, $111 -$111: ldgp $gp, 0($27) - lda $25, array_bound_error - br caml_c_call /* never returns */ - .end caml_array_bound_error - -#if defined(SYS_digital) - .rdata -#else - .section .rodata -#endif - .globl system__frametable -system__frametable: - .quad 1 /* one descriptor */ - .quad $108 + 4 /* return address into callback */ - .word -1 /* negative frame size => use callback link */ - .word 0 /* no roots here */ - .align 3 diff --git a/asmrun/amd64.S b/asmrun/amd64.S deleted file mode 100644 index 8168ee7dfa..0000000000 --- a/asmrun/amd64.S +++ /dev/null @@ -1,335 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 2003 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 file ../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -/* Asm part of the runtime system, AMD64 processor */ -/* Must be preprocessed by cpp */ - -#define FUNCTION_ALIGN 4 - -#define FUNCTION(name) \ - .globl name; \ - .type name,@function; \ - .align FUNCTION_ALIGN; \ - name: - - .text - -/* Allocation */ - -FUNCTION(caml_call_gc) - /* Record lowest stack address and return address */ - movq 0(%rsp), %rax - movq %rax, caml_last_return_address(%rip) - leaq 8(%rsp), %rax - movq %rax, caml_bottom_of_stack(%rip) - /* Save young_ptr, caml_exception_pointer */ - movq %r15, young_ptr(%rip) - movq %r14, caml_exception_pointer(%rip) - /* Build array of registers, save it into caml_gc_regs */ -.L105: - pushq %r13 - pushq %r12 - pushq %rbp - pushq %r11 - pushq %r10 - pushq %r9 - pushq %r8 - pushq %rcx - pushq %rdx - pushq %rsi - pushq %rdi - pushq %rbx - pushq %rax - movq %rsp, caml_gc_regs - /* Save floating-point registers */ - subq $(16*8), %rsp - movlpd %xmm0, 0*8(%rsp) - movlpd %xmm1, 1*8(%rsp) - movlpd %xmm2, 2*8(%rsp) - movlpd %xmm3, 3*8(%rsp) - movlpd %xmm4, 4*8(%rsp) - movlpd %xmm5, 5*8(%rsp) - movlpd %xmm6, 6*8(%rsp) - movlpd %xmm7, 7*8(%rsp) - movlpd %xmm8, 8*8(%rsp) - movlpd %xmm9, 9*8(%rsp) - movlpd %xmm10, 10*8(%rsp) - movlpd %xmm11, 11*8(%rsp) - movlpd %xmm12, 12*8(%rsp) - movlpd %xmm13, 13*8(%rsp) - movlpd %xmm14, 14*8(%rsp) - movlpd %xmm15, 15*8(%rsp) - /* Call the garbage collector */ - call garbage_collection - /* Restore all regs used by the code generator */ - movlpd 0*8(%rsp), %xmm0 - movlpd 1*8(%rsp), %xmm1 - movlpd 2*8(%rsp), %xmm2 - movlpd 3*8(%rsp), %xmm3 - movlpd 4*8(%rsp), %xmm4 - movlpd 5*8(%rsp), %xmm5 - movlpd 6*8(%rsp), %xmm6 - movlpd 7*8(%rsp), %xmm7 - movlpd 8*8(%rsp), %xmm8 - movlpd 9*8(%rsp), %xmm9 - movlpd 10*8(%rsp), %xmm10 - movlpd 11*8(%rsp), %xmm11 - movlpd 12*8(%rsp), %xmm12 - movlpd 13*8(%rsp), %xmm13 - movlpd 14*8(%rsp), %xmm14 - movlpd 15*8(%rsp), %xmm15 - addq $(16*8), %rsp - popq %rax - popq %rbx - popq %rdi - popq %rsi - popq %rdx - popq %rcx - popq %r8 - popq %r9 - popq %r10 - popq %r11 - popq %rbp - popq %r12 - popq %r13 - /* Restore young_ptr, caml_exception_pointer */ - movq young_ptr(%rip), %r15 - movq caml_exception_pointer(%rip), %r14 - /* Return to caller */ - ret - -FUNCTION(caml_alloc1) - subq $16, %r15 - cmpq young_limit(%rip), %r15 - jb .L100 - ret -.L100: - movq 0(%rsp), %rax - movq %rax, caml_last_return_address(%rip) - leaq 8(%rsp), %rax - movq %rax, caml_bottom_of_stack(%rip) - subq $8, %rsp - call .L105 - addq $8, %rsp - jmp caml_alloc1 - -FUNCTION(caml_alloc2) - subq $24, %r15 - cmpq young_limit(%rip), %r15 - jb .L101 - ret -.L101: - movq 0(%rsp), %rax - movq %rax, caml_last_return_address(%rip) - leaq 8(%rsp), %rax - movq %rax, caml_bottom_of_stack(%rip) - subq $8, %rsp - call .L105 - addq $8, %rsp - jmp caml_alloc2 - -FUNCTION(caml_alloc3) - subq $32, %r15 - cmpq young_limit(%rip), %r15 - jb .L102 - ret -.L102: - movq 0(%rsp), %rax - movq %rax, caml_last_return_address(%rip) - leaq 8(%rsp), %rax - movq %rax, caml_bottom_of_stack(%rip) - subq $8, %rsp - call .L105 - addq $8, %rsp - jmp caml_alloc3 - -FUNCTION(caml_alloc) - subq %rax, %r15 - cmpq young_limit(%rip), %r15 - jb .L103 - ret -.L103: - pushq %rax /* save desired size */ - movq 8(%rsp), %rax - movq %rax, caml_last_return_address(%rip) - leaq 16(%rsp), %rax - movq %rax, caml_bottom_of_stack(%rip) - call .L105 - popq %rax /* recover desired size */ - jmp caml_alloc - -/* Call a C function from Caml */ - -FUNCTION(caml_c_call) - /* Record lowest stack address and return address */ - popq %r12 - movq %r12, caml_last_return_address(%rip) - movq %rsp, caml_bottom_of_stack(%rip) - /* Make the exception handler and alloc ptr available to the C code */ - movq %r15, young_ptr(%rip) - movq %r14, caml_exception_pointer(%rip) - /* Call the function (address in %rax) */ - call *%rax - /* Reload alloc ptr */ - movq young_ptr(%rip), %r15 - /* Return to caller */ - pushq %r12 - ret - -/* Start the Caml program */ - -FUNCTION(caml_start_program) - /* Save callee-save registers */ - pushq %rbx - pushq %rbp - pushq %r12 - pushq %r13 - pushq %r14 - pushq %r15 - subq $8, %rsp /* stack 16-aligned */ - /* Initial entry point is caml_program */ - leaq caml_program(%rip), %r12 - /* Common code for caml_start_program and callback* */ -.L106: - /* Build a callback link */ - subq $8, %rsp /* stack 16-aligned */ - pushq caml_gc_regs(%rip) - pushq caml_last_return_address(%rip) - pushq caml_bottom_of_stack(%rip) - /* Setup alloc ptr and exception ptr */ - movq young_ptr(%rip), %r15 - movq caml_exception_pointer(%rip), %r14 - /* Build an exception handler */ - lea .L108(%rip), %r13 - pushq %r13 - pushq %r14 - movq %rsp, %r14 - /* Call the Caml code */ - call *%r12 -.L107: - /* Pop the exception handler */ - popq %r14 - popq %r12 /* dummy register */ -.L109: - /* Update alloc ptr and exception ptr */ - movq %r15, young_ptr(%rip) - movq %r14, caml_exception_pointer(%rip) - /* Pop the callback link, restoring the global variables */ - popq caml_bottom_of_stack(%rip) - popq caml_last_return_address(%rip) - popq caml_gc_regs(%rip) - addq $8, %rsp - /* Restore callee-save registers. */ - addq $8, %rsp - popq %r15 - popq %r14 - popq %r13 - popq %r12 - popq %rbp - popq %rbx - /* Return to caller. */ - ret -.L108: - /* Exception handler*/ - /* Mark the bucket as an exception result and return it */ - orq $2, %rax - jmp .L109 - -/* Raise an exception from C */ - -FUNCTION(raise_caml_exception) - movq %rdi, %rax - movq caml_exception_pointer(%rip), %rsp - popq caml_exception_pointer(%rip) - ret - -/* Callback from C to Caml */ - -FUNCTION(callback_exn) - /* Save callee-save registers */ - pushq %rbx - pushq %rbp - pushq %r12 - pushq %r13 - pushq %r14 - pushq %r15 - subq $8, %rsp /* stack 16-aligned */ - /* Initial loading of arguments */ - movq %rdi, %rbx /* closure */ - movq %rsi, %rax /* argument */ - movq 0(%rbx), %r12 /* code pointer */ - jmp .L106 - -FUNCTION(callback2_exn) - /* Save callee-save registers */ - pushq %rbx - pushq %rbp - pushq %r12 - pushq %r13 - pushq %r14 - pushq %r15 - subq $8, %rsp /* stack 16-aligned */ - /* Initial loading of arguments */ - /* closure stays in %rdi */ - movq %rsi, %rax /* first argument */ - movq %rdx, %rbx /* second argument */ - leaq caml_apply2(%rip), %r12 /* code pointer */ - jmp .L106 - -FUNCTION(callback3_exn) - /* Save callee-save registers */ - pushq %rbx - pushq %rbp - pushq %r12 - pushq %r13 - pushq %r14 - pushq %r15 - subq $8, %rsp /* stack 16-aligned */ - /* Initial loading of arguments */ - movq %rsi, %rax /* first argument */ - movq %rdx, %rbx /* second argument */ - movq %rdi, %rsi /* closure */ - movq %rcx, %rdi /* third argument */ - leaq caml_apply3(%rip), %r12 /* code pointer */ - jmp .L106 - -FUNCTION(caml_array_bound_error) - /* Make the exception handler and alloc ptr available to the C code */ - movq %r15, young_ptr(%rip) - movq %r14, caml_exception_pointer(%rip) - jmp array_bound_error - - .data - .globl system__frametable - .type system__frametable,@object - .align 8 -system__frametable: - .quad 1 /* one descriptor */ - .quad .L107 /* return address into callback */ - .value -1 /* negative frame size => use callback link */ - .value 0 /* no roots here */ - .align 8 - - .section .rodata.cst8,"aM",@progbits,8 - .globl caml_negf_mask - .type caml_negf_mask,@object - .align 16 -caml_negf_mask: - .quad 0x8000000000000000, 0 - .globl caml_absf_mask - .type caml_absf_mask,@object - .align 16 -caml_absf_mask: - .quad 0x7FFFFFFFFFFFFFFF, 0xFFFFFFFFFFFFFFFF diff --git a/asmrun/arm.S b/asmrun/arm.S deleted file mode 100644 index c465636b5d..0000000000 --- a/asmrun/arm.S +++ /dev/null @@ -1,339 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 1998 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 file ../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -/* Asm part of the runtime system, ARM processor */ - -trap_ptr .req r11 -alloc_ptr .req r8 -alloc_limit .req r9 -sp .req r13 -lr .req r14 -pc .req r15 - - .text - -/* Allocation functions and GC interface */ - - .global caml_call_gc -caml_call_gc: - /* Record return address */ - /* We can use r10 as a temp reg since it's not live here */ - ldr r10, .Lcaml_last_return_address - str lr, [r10, #0] - /* Branch to shared GC code */ - bl .Linvoke_gc - /* Restart allocation sequence (4 instructions before) */ - sub lr, lr, #16 - mov pc, lr - - .global caml_alloc1 -caml_alloc1: - ldr r10, [alloc_limit, #0] - sub alloc_ptr, alloc_ptr, #8 - cmp alloc_ptr, r10 - movcs pc, lr /* Return if alloc_ptr >= alloc_limit */ - /* Record return address */ - ldr r10, .Lcaml_last_return_address - str lr, [r10, #0] - /* Invoke GC */ - bl .Linvoke_gc - /* Try again */ - b caml_alloc1 - - .global caml_alloc2 -caml_alloc2: - ldr r10, [alloc_limit, #0] - sub alloc_ptr, alloc_ptr, #12 - cmp alloc_ptr, r10 - movcs pc, lr /* Return if alloc_ptr >= alloc_limit */ - /* Record return address */ - ldr r10, .Lcaml_last_return_address - str lr, [r10, #0] - /* Invoke GC */ - bl .Linvoke_gc - /* Try again */ - b caml_alloc2 - - .global caml_alloc3 -caml_alloc3: - ldr r10, [alloc_limit, #0] - sub alloc_ptr, alloc_ptr, #16 - cmp alloc_ptr, r10 - movcs pc, lr /* Return if alloc_ptr >= alloc_limit */ - /* Record return address */ - ldr r10, .Lcaml_last_return_address - str lr, [r10, #0] - /* Invoke GC */ - bl .Linvoke_gc - /* Try again */ - b caml_alloc3 - - .global caml_alloc -caml_alloc: - str r12, [sp, #-4]! - ldr r12, [alloc_limit, #0] - sub alloc_ptr, alloc_ptr, r10 - cmp alloc_ptr, r12 - ldr r12, [sp], #4 - movcs pc, lr /* Return if alloc_ptr >= alloc_limit */ - /* Record return address and desired size */ - ldr alloc_limit, .Lcaml_last_return_address - str lr, [alloc_limit, #0] - str r10, .Lcaml_requested_size - /* Invoke GC */ - bl .Linvoke_gc - /* Try again */ - ldr r10, .Lcaml_requested_size - b caml_alloc - -/* Shared code to invoke the GC */ -.Linvoke_gc: - /* Record lowest stack address */ - ldr r10, .Lcaml_bottom_of_stack - str sp, [r10, #0] - /* Save integer registers and return address on stack */ - stmfd sp!, {r0,r1,r2,r3,r4,r5,r6,r7,r10,r12,lr} - /* Store pointer to saved integer registers in caml_gc_regs */ - ldr r10, .Lcaml_gc_regs - str sp, [r10, #0] - /* Save non-callee-save float registers */ - stfd f0, [sp, #-8]! - stfd f1, [sp, #-8]! - stfd f2, [sp, #-8]! - stfd f3, [sp, #-8]! - /* Save current allocation pointer for debugging purposes */ - ldr r10, .Lyoung_ptr - str alloc_ptr, [r10, #0] - /* Save trap pointer in case an exception is raised during GC */ - ldr r10, .Lcaml_exception_pointer - str trap_ptr, [r10, #0] - /* Call the garbage collector */ - bl garbage_collection - /* Restore the registers from the stack */ - ldfd f4, [sp], #8 - ldfd f5, [sp], #8 - ldfd f6, [sp], #8 - ldfd f7, [sp], #8 - ldmfd sp!, {r0,r1,r2,r3,r4,r5,r6,r7,r10,r12} - /* Reload return address */ - ldr r10, .Lcaml_last_return_address - ldr lr, [r10, #0] - /* Say that we are back into Caml code */ - mov alloc_ptr, #0 - str alloc_ptr, [r10, #0] - /* Reload new allocation pointer and allocation limit */ - ldr r10, .Lyoung_ptr - ldr alloc_ptr, [r10, #0] - ldr alloc_limit, .Lyoung_limit - /* Return to caller */ - ldmfd sp!, {pc} - -/* Call a C function from Caml */ -/* Function to call is in r10 */ - - .global caml_c_call -caml_c_call: - /* Preserve return address in callee-save register r4 */ - mov r4, lr - /* Record lowest stack address and return address */ - ldr r5, .Lcaml_last_return_address - ldr r6, .Lcaml_bottom_of_stack - str lr, [r5, #0] - str sp, [r6, #0] - /* Make the exception handler and alloc ptr available to the C code */ - ldr r6, .Lyoung_ptr - ldr r7, .Lcaml_exception_pointer - str alloc_ptr, [r6, #0] - str trap_ptr, [r7, #0] - /* Call the function */ - mov lr, pc - mov pc, r10 - /* Reload alloc ptr */ - ldr alloc_ptr, [r6, #0] /* r6 still points to young_ptr */ - /* Say that we are back into Caml code */ - mov r6, #0 - str r6, [r5, #0] /* r5 still points to caml_last_return_address */ - /* Return */ - mov pc, r4 - -/* Start the Caml program */ - - .global caml_start_program -caml_start_program: - ldr r10, .Lcaml_program - -/* Code shared with callback* */ -/* Address of Caml code to call is in r10 */ -/* Arguments to the Caml code are in r0...r3 */ - -.Ljump_to_caml: - /* Save return address and callee-save registers */ - stmfd sp!, {r4,r5,r6,r7,r8,r9,r11,lr} - stfd f7, [sp, #-8]! - stfd f6, [sp, #-8]! - stfd f5, [sp, #-8]! - stfd f4, [sp, #-8]! - /* Setup a callback link on the stack */ - sub sp, sp, #4*3 - ldr r4, .Lcaml_bottom_of_stack - ldr r4, [r4, #0] - str r4, [sp, #0] - ldr r4, .Lcaml_last_return_address - ldr r4, [r4, #0] - str r4, [sp, #4] - ldr r4, .Lcaml_gc_regs - ldr r4, [r4, #0] - str r4, [sp, #8] - /* Setup a trap frame to catch exceptions escaping the Caml code */ - sub sp, sp, #4*2 - ldr r4, .Lcaml_exception_pointer - ldr r4, [r4, #0] - str r4, [sp, #0] - ldr r4, .LLtrap_handler - str r4, [sp, #4] - mov trap_ptr, sp - /* Reload allocation pointers */ - ldr r4, .Lyoung_ptr - ldr alloc_ptr, [r4, #0] - ldr alloc_limit, .Lyoung_limit - /* We are back into Caml code */ - ldr r4, .Lcaml_last_return_address - mov r5, #0 - str r5, [r4, #0] - /* Call the Caml code */ - mov lr, pc - mov pc, r10 -.Lcaml_retaddr: - /* Pop the trap frame, restoring caml_exception_pointer */ - ldr r4, .Lcaml_exception_pointer - ldr r5, [sp, #0] - str r5, [r4, #0] - add sp, sp, #2 * 4 - /* Pop the callback link, restoring the global variables */ -.Lreturn_result: - ldr r4, .Lcaml_bottom_of_stack - ldr r5, [sp, #0] - str r5, [r4, #0] - ldr r4, .Lcaml_last_return_address - ldr r5, [sp, #4] - str r5, [r4, #0] - ldr r4, .Lcaml_gc_regs - ldr r5, [sp, #8] - str r5, [r4, #0] - add sp, sp, #4*3 - /* Update allocation pointer */ - ldr r4, .Lyoung_ptr - str alloc_ptr, [r4, #0] - /* Reload callee-save registers and return */ - ldfd f4, [sp], #8 - ldfd f5, [sp], #8 - ldfd f6, [sp], #8 - ldfd f7, [sp], #8 - ldmfd sp!, {r4,r5,r6,r7,r8,r9,r11,pc} - - /* The trap handler */ -.Ltrap_handler: - /* Save exception pointer */ - ldr r4, .Lcaml_exception_pointer - str trap_ptr, [r4, #0] - /* Encode exception bucket as an exception result */ - orr r0, r0, #2 - /* Return it */ - b .Lreturn_result - -/* Raise an exception from C */ - - .global raise_caml_exception -raise_caml_exception: - /* Reload Caml allocation pointers */ - ldr r1, .Lyoung_ptr - ldr alloc_ptr, [r1, #0] - ldr alloc_limit, .Lyoung_limit - /* Say we're back into Caml */ - ldr r1, .Lcaml_last_return_address - mov r2, #0 - str r2, [r1, #0] - /* Cut stack at current trap handler */ - ldr r1, .Lcaml_exception_pointer - ldr sp, [r1, #0] - /* Pop previous handler and addr of trap, and jump to it */ - ldmfd sp!, {trap_ptr, pc} - -/* Callback from C to Caml */ - - .global callback_exn -callback_exn: - /* Initial shuffling of arguments (r0 = closure, r1 = first arg) */ - mov r10, r0 - mov r0, r1 /* r0 = first arg */ - mov r1, r10 /* r1 = closure environment */ - ldr r10, [r10, #0] /* code pointer */ - b .Ljump_to_caml - - .global callback2_exn -callback2_exn: - /* Initial shuffling of arguments (r0 = closure, r1 = arg1, r2 = arg2) */ - mov r10, r0 - mov r0, r1 /* r0 = first arg */ - mov r1, r2 /* r1 = second arg */ - mov r2, r10 /* r2 = closure environment */ - ldr r10, .Lcaml_apply2 - b .Ljump_to_caml - - .global callback3_exn -callback3_exn: - /* Initial shuffling of arguments */ - /* (r0 = closure, r1 = arg1, r2 = arg2, r3 = arg3) */ - mov r10, r0 - mov r0, r1 /* r0 = first arg */ - mov r1, r2 /* r1 = second arg */ - mov r2, r3 /* r2 = third arg */ - mov r3, r10 /* r3 = closure environment */ - ldr r10, .Lcaml_apply3 - b .Ljump_to_caml - - .global caml_array_bound_error -caml_array_bound_error: - /* Load address of array_bound_error in r10 */ - ldr r10, .Larray_bound_error - /* Call that function */ - b caml_c_call - -/* Global references */ - -.Lcaml_last_return_address: .word caml_last_return_address -.Lcaml_bottom_of_stack: .word caml_bottom_of_stack -.Lcaml_gc_regs: .word caml_gc_regs -.Lyoung_ptr: .word young_ptr -.Lyoung_limit: .word young_limit -.Lcaml_exception_pointer: .word caml_exception_pointer -.Lcaml_program: .word caml_program -.LLtrap_handler: .word .Ltrap_handler -.Lcaml_apply2: .word caml_apply2 -.Lcaml_apply3: .word caml_apply3 -.Lcaml_requested_size: .word 0 -.Larray_bound_error: .word array_bound_error - -/* GC roots for callback */ - - .data - - .global system__frametable -system__frametable: - .word 1 /* one descriptor */ - .word .Lcaml_retaddr /* return address into callback */ - .short -1 /* negative frame size => use callback link */ - .short 0 /* no roots */ - .align 2 diff --git a/asmrun/fail.c b/asmrun/fail.c deleted file mode 100644 index 0c79b7f157..0000000000 --- a/asmrun/fail.c +++ /dev/null @@ -1,172 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 1996 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 file ../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -/* Raising exceptions from C. */ - -#include -#include "alloc.h" -#include "fail.h" -#include "io.h" -#include "gc.h" -#include "memory.h" -#include "mlvalues.h" -#include "printexc.h" -#include "signals.h" -#include "stack.h" -#include "roots.h" - -/* The globals holding predefined exceptions */ - -typedef value caml_generated_constant[1]; - -extern caml_generated_constant Out_of_memory, Sys_error, Failure, - Invalid_argument, End_of_file, Division_by_zero, Not_found, - Match_failure, Sys_blocked_io, Stack_overflow; -extern caml_generated_constant - bucket_Out_of_memory, bucket_Stack_overflow; - -/* Exception raising */ - -extern void raise_caml_exception (value bucket) Noreturn; - -char * caml_exception_pointer = NULL; - -void mlraise(value v) -{ - Unlock_exn(); - if (caml_exception_pointer == NULL) fatal_uncaught_exception(v); - -#ifndef Stack_grows_upwards -#define PUSHED_AFTER < -#else -#define PUSHED_AFTER > -#endif - while (local_roots != NULL && - (char *) local_roots PUSHED_AFTER caml_exception_pointer) { - local_roots = local_roots->next; - } -#undef PUSHED_AFTER - - raise_caml_exception(v); -} - -void raise_constant(value tag) -{ - value bucket; - Begin_root (tag); - bucket = alloc_small (1, 0); - Field(bucket, 0) = tag; - End_roots (); - mlraise(bucket); -} - -void raise_with_arg(value tag, value arg) -{ - value bucket; - Begin_roots2 (tag, arg); - bucket = alloc_small (2, 0); - Field(bucket, 0) = tag; - Field(bucket, 1) = arg; - End_roots (); - mlraise(bucket); -} - -void raise_with_string(value tag, char *msg) -{ - raise_with_arg(tag, copy_string(msg)); -} - -void failwith (char *msg) -{ - raise_with_string((value) Failure, msg); -} - -void invalid_argument (char *msg) -{ - raise_with_string((value) Invalid_argument, msg); -} - -/* To raise Out_of_memory, we can't use raise_constant, - because it allocates and we're out of memory... - We therefore use a statically-allocated bucket constructed - by the ocamlopt linker. - This works OK because the exception value for Out_of_memory is also - statically allocated out of the heap. - The same applies to Stack_overflow. */ - -void raise_out_of_memory(void) -{ - mlraise((value) &bucket_Out_of_memory); -} - -void raise_stack_overflow(void) -{ - mlraise((value) &bucket_Stack_overflow); -} - -void raise_sys_error(value msg) -{ - raise_with_arg((value) Sys_error, msg); -} - -void raise_end_of_file(void) -{ - raise_constant((value) End_of_file); -} - -void raise_zero_divide(void) -{ - raise_constant((value) Division_by_zero); -} - -void raise_not_found(void) -{ - raise_constant((value) Not_found); -} - -void raise_sys_blocked_io(void) -{ - raise_constant((value) Sys_blocked_io); -} - -/* We allocate statically the bucket for the exception because we can't - do a GC before the exception is raised (lack of stack descriptors - for the ccall to array_bound_error */ - -#define BOUND_MSG "index out of bounds" -#define BOUND_MSG_LEN (sizeof(BOUND_MSG) - 1) - -static struct { - header_t hdr; - value exn; - value arg; -} array_bound_error_bucket; - -static struct { - header_t hdr; - char data[BOUND_MSG_LEN + sizeof(value)]; -} array_bound_error_msg = { 0, BOUND_MSG }; - -void array_bound_error(void) -{ - mlsize_t wosize = (BOUND_MSG_LEN + sizeof(value)) / sizeof(value); - mlsize_t offset_index = Bsize_wsize(wosize) - 1; - array_bound_error_msg.hdr = Make_header(wosize, String_tag, Caml_white); - array_bound_error_msg.data[offset_index] = offset_index - BOUND_MSG_LEN; - array_bound_error_bucket.hdr = Make_header(2, 0, Caml_white); - array_bound_error_bucket.exn = (value) Invalid_argument; - array_bound_error_bucket.arg = (value) array_bound_error_msg.data; - mlraise((value) &array_bound_error_bucket.exn); -} diff --git a/asmrun/hppa.S b/asmrun/hppa.S deleted file mode 100644 index 59daa91c73..0000000000 --- a/asmrun/hppa.S +++ /dev/null @@ -1,550 +0,0 @@ -;********************************************************************* -;* * -;* Objective Caml * -;* * -;* Xavier Leroy, projet Cristal, INRIA Rocquencourt * -;* * -;* Copyright 1996 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 file ../LICENSE. * -;* * -;********************************************************************* - -; $Id$ - -; Asm part of the runtime system for the HP PA-RISC processor. -; Must be preprocessed by cpp - -#ifdef SYS_hpux -#define G(x) x -#define CODESPACE .code -#define CODE_ALIGN 4 -#define EXPORT_CODE(x) .export x, entry, priv_lev=3 -#define EXPORT_DATA(x) .export x, data -#define STARTPROC .proc ! .callinfo frame=0, no_calls ! .entry -#define ENDPROC .exit ! .procend -#define LOADHIGH(x) addil LR%x-$global$, %r27 -#define LOW(x) RR%x-$global$ -#define LOADHIGHLABEL(x) ldil LR%x, %r1 -#define LOWLABEL(x) RR%x -#endif - -#ifdef SYS_nextstep -#define G(x) _##x -#define CODESPACE .text -#define CODE_ALIGN 2 -#define EXPORT_CODE(x) .globl x -#define EXPORT_DATA(x) .globl x -#define STARTPROC -#define ENDPROC -#define LOADHIGH(x) ldil L`x, %r1 -#define LOW(x) R`x -#define LOADHIGHLABEL(x) ldil L`x, %r1 -#define LOWLABEL(x) R`x -#endif - -#ifdef SYS_hpux - .space $PRIVATE$ - .subspa $DATA$,quad=1,align=8,access=31 - .subspa $BSS$,quad=1,align=8,access=31,zero,sort=82 - .space $TEXT$ - .subspa $LIT$,quad=0,align=8,access=44 - .subspa $CODE$,quad=0,align=8,access=44,code_only - .import $global$, data - .import $$dyncall, millicode - .import garbage_collection, code - .import caml_program, code - .import mlraise, code - .import caml_apply2, code - .import caml_apply3, code - .import array_bound_error, code - -young_limit .comm 8 -young_ptr .comm 8 -caml_bottom_of_stack .comm 8 -caml_last_return_address .comm 8 -caml_gc_regs .comm 8 -caml_exception_pointer .comm 8 -caml_required_size .comm 8 -#endif - -#ifdef SYS_nextstep - .comm G(young_limit), 8 - .comm G(young_ptr), 8 - .comm G(caml_bottom_of_stack), 8 - .comm G(caml_last_return_address), 8 - .comm G(caml_gc_regs), 8 - .comm G(caml_exception_pointer), 8 - .comm G(caml_required_size), 8 -#endif - -; Allocation functions - - CODESPACE - .align CODE_ALIGN - EXPORT_CODE(G(caml_alloc)) -G(caml_alloc): - STARTPROC -; Required size in %r29 - ldw 0(%r4), %r1 - sub %r3, %r29, %r3 - comb,<<,n %r3, %r1, G(caml_call_gc) ; nullify if taken (forward br.) - bv 0(%r2) - nop - ENDPROC - - EXPORT_CODE(G(caml_call_gc)) -G(caml_call_gc): - STARTPROC -; Save required size (%r29) - LOADHIGH(G(caml_required_size)) - stw %r29, LOW(G(caml_required_size))(%r1) -; Save current allocation pointer for debugging purposes - LOADHIGH(G(young_ptr)) - stw %r3, LOW(G(young_ptr))(%r1) -; Record lowest stack address - LOADHIGH(G(caml_bottom_of_stack)) - stw %r30, LOW(G(caml_bottom_of_stack))(%r1) -; Record return address - LOADHIGH(G(caml_last_return_address)) - stw %r2, LOW(G(caml_last_return_address))(%r1) -; Save the exception handler (if e.g. a sighandler raises) - LOADHIGH(G(caml_exception_pointer)) - stw %r5, LOW(G(caml_exception_pointer))(%r1) -; Reserve stack space -; 0x1C0 = 4 * 32 (int regs) + 8 * 32 (float regs) + 64 (for calling C) - ldo 0x1C0(%r30), %r30 -; Save caml_gc_regs -L100: ldo -(64 + 4*32)(%r30), %r31 - LOADHIGH(G(caml_gc_regs)) - stw %r31, LOW(G(caml_gc_regs))(%r1) -; Save all regs used by the code generator - copy %r31, %r1 - stws,ma %r6, 4(%r1) - stws,ma %r7, 4(%r1) - stws,ma %r8, 4(%r1) - stws,ma %r9, 4(%r1) - stws,ma %r10, 4(%r1) - stws,ma %r11, 4(%r1) - stws,ma %r12, 4(%r1) - stws,ma %r13, 4(%r1) - stws,ma %r14, 4(%r1) - stws,ma %r15, 4(%r1) - stws,ma %r16, 4(%r1) - stws,ma %r17, 4(%r1) - stws,ma %r18, 4(%r1) - stws,ma %r19, 4(%r1) - stws,ma %r20, 4(%r1) - stws,ma %r21, 4(%r1) - stws,ma %r22, 4(%r1) - stws,ma %r23, 4(%r1) - stws,ma %r24, 4(%r1) - stws,ma %r25, 4(%r1) - stws,ma %r26, 4(%r1) - stws,ma %r28, 4(%r1) - ldo -0x1C0(%r30), %r1 - fstds,ma %fr4, 8(%r1) - fstds,ma %fr5, 8(%r1) - fstds,ma %fr6, 8(%r1) - fstds,ma %fr7, 8(%r1) - fstds,ma %fr8, 8(%r1) - fstds,ma %fr9, 8(%r1) - fstds,ma %fr10, 8(%r1) - fstds,ma %fr11, 8(%r1) - fstds,ma %fr12, 8(%r1) - fstds,ma %fr13, 8(%r1) - fstds,ma %fr14, 8(%r1) - fstds,ma %fr15, 8(%r1) - fstds,ma %fr16, 8(%r1) - fstds,ma %fr17, 8(%r1) - fstds,ma %fr18, 8(%r1) - fstds,ma %fr19, 8(%r1) - fstds,ma %fr20, 8(%r1) - fstds,ma %fr21, 8(%r1) - fstds,ma %fr22, 8(%r1) - fstds,ma %fr23, 8(%r1) - fstds,ma %fr24, 8(%r1) - fstds,ma %fr25, 8(%r1) - fstds,ma %fr26, 8(%r1) - fstds,ma %fr27, 8(%r1) - fstds,ma %fr28, 8(%r1) - fstds,ma %fr29, 8(%r1) - fstds,ma %fr30, 8(%r1) - -; Call the garbage collector -#ifdef SYS_nextstep - ldil L`G(garbage_collection), %r1 - ble R`G(garbage_collection)(4, %r1) - copy %r31, %r2 -#else - bl G(garbage_collection), %r2 - nop -#endif - -; Restore all regs used by the code generator - ldo -(64 + 4*32)(%r30), %r1 - ldws,ma 4(%r1), %r6 - ldws,ma 4(%r1), %r7 - ldws,ma 4(%r1), %r8 - ldws,ma 4(%r1), %r9 - ldws,ma 4(%r1), %r10 - ldws,ma 4(%r1), %r11 - ldws,ma 4(%r1), %r12 - ldws,ma 4(%r1), %r13 - ldws,ma 4(%r1), %r14 - ldws,ma 4(%r1), %r15 - ldws,ma 4(%r1), %r16 - ldws,ma 4(%r1), %r17 - ldws,ma 4(%r1), %r18 - ldws,ma 4(%r1), %r19 - ldws,ma 4(%r1), %r20 - ldws,ma 4(%r1), %r21 - ldws,ma 4(%r1), %r22 - ldws,ma 4(%r1), %r23 - ldws,ma 4(%r1), %r24 - ldws,ma 4(%r1), %r25 - ldws,ma 4(%r1), %r26 - ldws,ma 4(%r1), %r28 - ldo -0x1C0(%r30), %r1 - fldds,ma 8(%r1), %fr4 - fldds,ma 8(%r1), %fr5 - fldds,ma 8(%r1), %fr6 - fldds,ma 8(%r1), %fr7 - fldds,ma 8(%r1), %fr8 - fldds,ma 8(%r1), %fr9 - fldds,ma 8(%r1), %fr10 - fldds,ma 8(%r1), %fr11 - fldds,ma 8(%r1), %fr12 - fldds,ma 8(%r1), %fr13 - fldds,ma 8(%r1), %fr14 - fldds,ma 8(%r1), %fr15 - fldds,ma 8(%r1), %fr16 - fldds,ma 8(%r1), %fr17 - fldds,ma 8(%r1), %fr18 - fldds,ma 8(%r1), %fr19 - fldds,ma 8(%r1), %fr20 - fldds,ma 8(%r1), %fr21 - fldds,ma 8(%r1), %fr22 - fldds,ma 8(%r1), %fr23 - fldds,ma 8(%r1), %fr24 - fldds,ma 8(%r1), %fr25 - fldds,ma 8(%r1), %fr26 - fldds,ma 8(%r1), %fr27 - fldds,ma 8(%r1), %fr28 - fldds,ma 8(%r1), %fr29 - fldds,ma 8(%r1), %fr30 - -; Reload the allocation pointer - LOADHIGH(G(young_ptr)) - ldw LOW(G(young_ptr))(%r1), %r3 -; Allocate space for block - LOADHIGH(G(caml_required_size)) - ldw LOW(G(caml_required_size))(%r1), %r29 - ldw 0(%r4), %r1 - sub %r3, %r29, %r3 - comb,<< %r3, %r1, L100 - nop -; Return to caller - LOADHIGH(G(caml_last_return_address)) - ldw LOW(G(caml_last_return_address))(%r1), %r2 - bv 0(%r2) - ldo -0x1C0(%r30), %r30 - ENDPROC - -; Call a C function from Caml -; Function to call is in %r22 - - .align CODE_ALIGN -#ifdef SYS_hpux - .export G(caml_c_call), ENTRY, ARGW0=GR, ARGW1=GR, ARGW2=GR, ARGW3=GR -#else - EXPORT_CODE(G(caml_c_call)) -#endif -G(caml_c_call): - STARTPROC -; Record lowest stack address - LOADHIGH(G(caml_bottom_of_stack)) - stw %r30, LOW(G(caml_bottom_of_stack))(%r1) -; Record return address - LOADHIGH(G(caml_last_return_address)) - stw %r2, LOW(G(caml_last_return_address))(%r1) -; Save the exception handler - LOADHIGH(G(caml_exception_pointer)) - stw %r5, LOW(G(caml_exception_pointer))(%r1) -; Save the allocation pointer - LOADHIGH(G(young_ptr)) - stw %r3, LOW(G(young_ptr))(%r1) -; Call the C function -#ifdef SYS_hpux - bl $$dyncall, %r31 -#else - ble 0(4, %r22) -#endif - copy %r31, %r2 ; in delay slot -; Reload return address - LOADHIGH(G(caml_last_return_address)) - ldw LOW(G(caml_last_return_address))(%r1), %r2 -; Reload allocation pointer - LOADHIGH(G(young_ptr)) -; Return to caller - bv 0(%r2) - ldw LOW(G(young_ptr))(%r1), %r3 ; in delay slot - ENDPROC - -; Start the Caml program - - .align CODE_ALIGN - EXPORT_CODE(G(caml_start_program)) -G(caml_start_program): - STARTPROC - LOADHIGH(G(caml_program)) - ldo LOW(G(caml_program))(%r1), %r22 - -; Code shared with callback* -L102: -; Save return address - stw %r2,-20(%r30) - ldo 256(%r30), %r30 -; Save the callee-save registers - ldo -32(%r30), %r1 - stws,ma %r3, -4(%r1) - stws,ma %r4, -4(%r1) - stws,ma %r5, -4(%r1) - stws,ma %r6, -4(%r1) - stws,ma %r7, -4(%r1) - stws,ma %r8, -4(%r1) - stws,ma %r9, -4(%r1) - stws,ma %r10, -4(%r1) - stws,ma %r11, -4(%r1) - stws,ma %r12, -4(%r1) - stws,ma %r13, -4(%r1) - stws,ma %r14, -4(%r1) - stws,ma %r15, -4(%r1) - stws,ma %r16, -4(%r1) - stws,ma %r17, -4(%r1) - stws,ma %r18, -4(%r1) - fstds,ma %fr12, -8(%r1) - fstds,ma %fr13, -8(%r1) - fstds,ma %fr14, -8(%r1) - fstds,ma %fr15, -8(%r1) - fstds,ma %fr16, -8(%r1) - fstds,ma %fr17, -8(%r1) - fstds,ma %fr18, -8(%r1) - fstds,ma %fr19, -8(%r1) - fstds,ma %fr20, -8(%r1) - fstds,ma %fr21, -8(%r1) - fstds,ma %fr22, -8(%r1) - fstds,ma %fr23, -8(%r1) - fstds,ma %fr24, -8(%r1) - fstds,ma %fr25, -8(%r1) - fstds,ma %fr26, -8(%r1) - fstds,ma %fr27, -8(%r1) - fstds,ma %fr28, -8(%r1) - fstds,ma %fr29, -8(%r1) - fstds,ma %fr30, -8(%r1) - fstds,ma %fr31, -8(%r1) -; Set up a callback link - ldo 16(%r30), %r30 - LOADHIGH(G(caml_bottom_of_stack)) - ldw LOW(G(caml_bottom_of_stack))(%r1), %r1 - stw %r1, -16(%r30) - LOADHIGH(G(caml_last_return_address)) - ldw LOW(G(caml_last_return_address))(%r1), %r1 - stw %r1, -12(%r30) - LOADHIGH(G(caml_gc_regs)) - ldw LOW(G(caml_gc_regs))(%r1), %r1 - stw %r1, -8(%r30) -; Set up a trap frame to catch exceptions escaping the Caml code - ldo 8(%r30), %r30 - LOADHIGH(G(caml_exception_pointer)) - ldw LOW(G(caml_exception_pointer))(%r1), %r1 - stw %r1, -8(%r30) - LOADHIGHLABEL(L103) - ldo LOWLABEL(L103)(%r1), %r1 - stw %r1, -4(%r30) - copy %r30, %r5 -; Reload allocation pointers - LOADHIGH(G(young_ptr)) - ldw LOW(G(young_ptr))(%r1), %r3 - LOADHIGH(G(young_limit)) - ldo LOW(G(young_limit))(%r1), %r4 -; Call the Caml code - ble 0(4, %r22) - copy %r31, %r2 -L104: -; Pop the trap frame - ldw -8(%r30), %r31 - LOADHIGH(G(caml_exception_pointer)) - stw %r31, LOW(G(caml_exception_pointer))(%r1) - ldo -8(%r30), %r30 -; Pop the callback link -L105: - ldw -16(%r30), %r31 - LOADHIGH(G(caml_bottom_of_stack)) - stw %r31, LOW(G(caml_bottom_of_stack))(%r1) - ldw -12(%r30), %r31 - LOADHIGH(G(caml_last_return_address)) - stw %r31, LOW(G(caml_last_return_address))(%r1) - ldw -8(%r30), %r31 - LOADHIGH(G(caml_gc_regs)) - stw %r31, LOW(G(caml_gc_regs))(%r1) - ldo -16(%r30), %r30 -; Save allocation pointer - LOADHIGH(G(young_ptr)) - stw %r3, LOW(G(young_ptr))(%r1) -; Move result where C function expects it - copy %r26, %r28 -; Reload callee-save registers - ldo -32(%r30), %r1 - ldws,ma -4(%r1), %r3 - ldws,ma -4(%r1), %r4 - ldws,ma -4(%r1), %r5 - ldws,ma -4(%r1), %r6 - ldws,ma -4(%r1), %r7 - ldws,ma -4(%r1), %r8 - ldws,ma -4(%r1), %r9 - ldws,ma -4(%r1), %r10 - ldws,ma -4(%r1), %r11 - ldws,ma -4(%r1), %r12 - ldws,ma -4(%r1), %r13 - ldws,ma -4(%r1), %r14 - ldws,ma -4(%r1), %r15 - ldws,ma -4(%r1), %r16 - ldws,ma -4(%r1), %r17 - ldws,ma -4(%r1), %r18 - fldds,ma -8(%r1), %fr12 - fldds,ma -8(%r1), %fr13 - fldds,ma -8(%r1), %fr14 - fldds,ma -8(%r1), %fr15 - fldds,ma -8(%r1), %fr16 - fldds,ma -8(%r1), %fr17 - fldds,ma -8(%r1), %fr18 - fldds,ma -8(%r1), %fr19 - fldds,ma -8(%r1), %fr20 - fldds,ma -8(%r1), %fr21 - fldds,ma -8(%r1), %fr22 - fldds,ma -8(%r1), %fr23 - fldds,ma -8(%r1), %fr24 - fldds,ma -8(%r1), %fr25 - fldds,ma -8(%r1), %fr26 - fldds,ma -8(%r1), %fr27 - fldds,ma -8(%r1), %fr28 - fldds,ma -8(%r1), %fr29 - fldds,ma -8(%r1), %fr30 - fldds,ma -8(%r1), %fr31 -; Return to C - ldo -256(%r30), %r30 - ldw -20(%r30), %r2 - bv 0(%r2) - nop -; The trap handler -L103: -; Save exception pointer - LOADHIGH(G(caml_exception_pointer)) - stw %r5, LOW(G(caml_exception_pointer))(%r1) -; Encode exception bucket as an exception result and return it - ldi 2, %r1 - or %r26, %r1, %r26 -; Return it - b L105 - nop - -; Re-raise the exception through mlraise, to clean up local C roots - ldo 64(%r30), %r30 -#ifdef SYS_nextstep - ldil L`G(mlraise), %r1 - ble R`G(mlraise)(4, %r1) - copy %r31, %r2 -#else - bl G(mlraise), %r2 - nop -#endif - ENDPROC - -; Raise an exception from C - - .align CODE_ALIGN - EXPORT_CODE(G(raise_caml_exception)) -G(raise_caml_exception): - STARTPROC -; Cut the stack - LOADHIGH(G(caml_exception_pointer)) - ldw LOW(G(caml_exception_pointer))(%r1), %r30 -; Reload allocation registers - LOADHIGH(G(young_ptr)) - ldw LOW(G(young_ptr))(%r1), %r3 - LOADHIGH(G(young_limit)) - ldo LOW(G(young_limit))(%r1), %r4 -; Raise the exception - ldw -4(%r30), %r1 - ldw -8(%r30), %r5 - bv 0(%r1) - ldo -8(%r30), %r30 ; in delay slot - ENDPROC - -; Callbacks C -> ML - - .align CODE_ALIGN - EXPORT_CODE(G(callback_exn)) -G(callback_exn): - STARTPROC -; Initial shuffling of arguments - copy %r26, %r1 ; Closure - copy %r25, %r26 ; Argument - copy %r1, %r25 - b L102 - ldw 0(%r1), %r22 ; Code to call (in delay slot) - ENDPROC - - .align CODE_ALIGN - EXPORT_CODE(G(callback2_exn)) -G(callback2_exn): - STARTPROC - copy %r26, %r1 ; Closure - copy %r25, %r26 ; First argument - copy %r24, %r25 ; Second argument - copy %r1, %r24 - LOADHIGH(G(caml_apply2)) - b L102 - ldo LOW(G(caml_apply2))(%r1), %r22 - ENDPROC - - .align CODE_ALIGN - EXPORT_CODE(G(callback3_exn)) -G(callback3_exn): - STARTPROC - copy %r26, %r1 ; Closure - copy %r25, %r26 ; First argument - copy %r24, %r25 ; Second argument - copy %r23, %r24 ; Third argument - copy %r1, %r23 - LOADHIGH(G(caml_apply3)) - b L102 - ldo LOW(G(caml_apply3))(%r1), %r22 - ENDPROC - - .align CODE_ALIGN - EXPORT_CODE(G(caml_array_bound_error)) -G(caml_array_bound_error): - STARTPROC -; Load address of array_bound_error in %r22 -#ifdef SYS_hpux - ldil LR%array_bound_error, %r22 - ldo RR%array_bound_error(%r22), %r22 -#else - ldil L`_array_bound_error, %r22 - ldo R`_array_bound_error(%r22), %r22 -#endif -; Reserve 48 bytes of stack space and jump to caml_c_call - b G(caml_c_call) - ldo 48(%r30), %r30 /* in delay slot */ - ENDPROC - - .data - EXPORT_DATA(G(system__frametable)) -G(system__frametable): - .long 1 /* one descriptor */ - .long L104 + 3 /* return address into callback */ - .short -1 /* negative frame size => use callback link */ - .short 0 /* no roots */ diff --git a/asmrun/i386.S b/asmrun/i386.S deleted file mode 100644 index f89ed37425..0000000000 --- a/asmrun/i386.S +++ /dev/null @@ -1,326 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 1996 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 file ../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -/* Asm part of the runtime system, Intel 386 processor */ -/* Must be preprocessed by cpp */ - -/* Linux/BSD with ELF binaries and Solaris do not prefix identifiers with _. - Linux/BSD with a.out binaries and NextStep do. */ - -#if defined(SYS_solaris) -#define CONCAT(a,b) a/**/b -#else -#define CONCAT(a,b) a##b -#endif - -#if defined(SYS_linux_elf) || defined(SYS_bsd_elf) \ - || defined(SYS_solaris) || defined(SYS_beos) -#define G(x) x -#define LBL(x) CONCAT(.L,x) -#else -#define G(x) CONCAT(_,x) -#define LBL(x) CONCAT(L,x) -#endif - -#if defined(SYS_linux_elf) || defined(SYS_bsd_elf) \ - || defined(SYS_solaris) || defined(SYS_beos) || defined(SYS_cygwin) \ - || defined(SYS_mingw) -#define FUNCTION_ALIGN 4 -#else -#define FUNCTION_ALIGN 2 -#endif - -#if defined(PROFILING) -#if defined(SYS_linux_elf) -#define PROFILE_CAML \ - pushl %ebp; movl %esp, %ebp; pushl %eax; pushl %ecx; pushl %edx; \ - call mcount; \ - popl %edx; popl %ecx; popl %eax; popl %ebp -#define PROFILE_C \ - pushl %ebp; movl %esp, %ebp; call mcount; popl %ebp -#elif defined(SYS_bsd_elf) -#define PROFILE_CAML \ - pushl %ebp; movl %esp, %ebp; pushl %eax; pushl %ecx; pushl %edx; \ - call .mcount; \ - popl %edx; popl %ecx; popl %eax; popl %ebp -#define PROFILE_C \ - pushl %ebp; movl %esp, %ebp; call .mcount; popl %ebp -#endif -#else -#define PROFILE_CAML -#define PROFILE_C -#endif - -/* Allocation */ - - .text - .globl G(caml_call_gc) - .globl G(caml_alloc1) - .globl G(caml_alloc2) - .globl G(caml_alloc3) - .globl G(caml_alloc) - -G(caml_call_gc): - PROFILE_CAML - /* Record lowest stack address and return address */ - movl 0(%esp), %eax - movl %eax, G(caml_last_return_address) - leal 4(%esp), %eax - movl %eax, G(caml_bottom_of_stack) - /* Build array of registers, save it into caml_gc_regs */ -LBL(105): - pushl %ebp - pushl %edi - pushl %esi - pushl %edx - pushl %ecx - pushl %ebx - pushl %eax - movl %esp, G(caml_gc_regs) - /* Call the garbage collector */ - call G(garbage_collection) - /* Restore all regs used by the code generator */ - popl %eax - popl %ebx - popl %ecx - popl %edx - popl %esi - popl %edi - popl %ebp - /* Return to caller */ - ret - - .align FUNCTION_ALIGN -G(caml_alloc1): - PROFILE_CAML - movl G(young_ptr), %eax - subl $8, %eax - movl %eax, G(young_ptr) - cmpl G(young_limit), %eax - jb LBL(100) - ret -LBL(100): - movl 0(%esp), %eax - movl %eax, G(caml_last_return_address) - leal 4(%esp), %eax - movl %eax, G(caml_bottom_of_stack) - call LBL(105) - jmp G(caml_alloc1) - - .align FUNCTION_ALIGN -G(caml_alloc2): - PROFILE_CAML - movl G(young_ptr), %eax - subl $12, %eax - movl %eax, G(young_ptr) - cmpl G(young_limit), %eax - jb LBL(101) - ret -LBL(101): - movl 0(%esp), %eax - movl %eax, G(caml_last_return_address) - leal 4(%esp), %eax - movl %eax, G(caml_bottom_of_stack) - call LBL(105) - jmp G(caml_alloc2) - - .align FUNCTION_ALIGN -G(caml_alloc3): - PROFILE_CAML - movl G(young_ptr), %eax - subl $16, %eax - movl %eax, G(young_ptr) - cmpl G(young_limit), %eax - jb LBL(102) - ret -LBL(102): - movl 0(%esp), %eax - movl %eax, G(caml_last_return_address) - leal 4(%esp), %eax - movl %eax, G(caml_bottom_of_stack) - call LBL(105) - jmp G(caml_alloc3) - - .align FUNCTION_ALIGN -G(caml_alloc): - PROFILE_CAML - subl G(young_ptr), %eax /* eax = size - young_ptr */ - negl %eax /* eax = young_ptr - size */ - cmpl G(young_limit), %eax - jb LBL(103) - movl %eax, G(young_ptr) - ret -LBL(103): - subl G(young_ptr), %eax /* eax = - size */ - negl %eax /* eax = size */ - pushl %eax /* save desired size */ - subl %eax, G(young_ptr) /* must update young_ptr */ - movl 4(%esp), %eax - movl %eax, G(caml_last_return_address) - leal 8(%esp), %eax - movl %eax, G(caml_bottom_of_stack) - call LBL(105) - popl %eax /* recover desired size */ - jmp G(caml_alloc) - -/* Call a C function from Caml */ - - .globl G(caml_c_call) - .align FUNCTION_ALIGN -G(caml_c_call): - PROFILE_CAML - /* Record lowest stack address and return address */ - movl (%esp), %edx - movl %edx, G(caml_last_return_address) - leal 4(%esp), %edx - movl %edx, G(caml_bottom_of_stack) - /* Call the function (address in %eax) */ - jmp *%eax - -/* Start the Caml program */ - - .globl G(caml_start_program) - .align FUNCTION_ALIGN -G(caml_start_program): - PROFILE_C - /* Save callee-save registers */ - pushl %ebx - pushl %esi - pushl %edi - pushl %ebp - /* Initial entry point is caml_program */ - movl $ G(caml_program), %esi - /* Common code for caml_start_program and callback* */ -LBL(106): - /* Build a callback link */ - pushl G(caml_gc_regs) - pushl G(caml_last_return_address) - pushl G(caml_bottom_of_stack) - /* Build an exception handler */ - pushl $ LBL(108) - pushl G(caml_exception_pointer) - movl %esp, G(caml_exception_pointer) - /* Call the Caml code */ - call *%esi -LBL(107): - /* Pop the exception handler */ - popl G(caml_exception_pointer) - popl %esi /* dummy register */ -LBL(109): - /* Pop the callback link, restoring the global variables */ - popl G(caml_bottom_of_stack) - popl G(caml_last_return_address) - popl G(caml_gc_regs) - /* Restore callee-save registers. */ - popl %ebp - popl %edi - popl %esi - popl %ebx - /* Return to caller. */ - ret -LBL(108): - /* Exception handler*/ - /* Mark the bucket as an exception result and return it */ - orl $2, %eax - jmp LBL(109) - -/* Raise an exception from C */ - - .globl G(raise_caml_exception) - .align FUNCTION_ALIGN -G(raise_caml_exception): - PROFILE_C - movl 4(%esp), %eax - movl G(caml_exception_pointer), %esp - popl G(caml_exception_pointer) - ret - -/* Callback from C to Caml */ - - .globl G(callback_exn) - .align FUNCTION_ALIGN -G(callback_exn): - PROFILE_C - /* Save callee-save registers */ - pushl %ebx - pushl %esi - pushl %edi - pushl %ebp - /* Initial loading of arguments */ - movl 20(%esp), %ebx /* closure */ - movl 24(%esp), %eax /* argument */ - movl 0(%ebx), %esi /* code pointer */ - jmp LBL(106) - - .globl G(callback2_exn) - .align FUNCTION_ALIGN -G(callback2_exn): - PROFILE_C - /* Save callee-save registers */ - pushl %ebx - pushl %esi - pushl %edi - pushl %ebp - /* Initial loading of arguments */ - movl 20(%esp), %ecx /* closure */ - movl 24(%esp), %eax /* first argument */ - movl 28(%esp), %ebx /* second argument */ - movl $ G(caml_apply2), %esi /* code pointer */ - jmp LBL(106) - - .globl G(callback3_exn) - .align FUNCTION_ALIGN -G(callback3_exn): - PROFILE_C - /* Save callee-save registers */ - pushl %ebx - pushl %esi - pushl %edi - pushl %ebp - /* Initial loading of arguments */ - movl 20(%esp), %edx /* closure */ - movl 24(%esp), %eax /* first argument */ - movl 28(%esp), %ebx /* second argument */ - movl 32(%esp), %ecx /* third argument */ - movl $ G(caml_apply3), %esi /* code pointer */ - jmp LBL(106) - - .globl G(caml_array_bound_error) - .align FUNCTION_ALIGN -G(caml_array_bound_error): - /* Empty the floating-point stack */ - ffree %st(0) - ffree %st(1) - ffree %st(2) - ffree %st(3) - ffree %st(4) - ffree %st(5) - ffree %st(6) - ffree %st(7) - /* Branch to array_bound_error */ - jmp G(array_bound_error) - - .data - .globl G(system__frametable) -G(system__frametable): - .long 1 /* one descriptor */ - .long LBL(107) /* return address into callback */ -#ifndef SYS_solaris - .word -1 /* negative frame size => use callback link */ - .word 0 /* no roots here */ -#else - .value -1 /* negative frame size => use callback link */ - .value 0 /* no roots here */ -#endif diff --git a/asmrun/i386nt.asm b/asmrun/i386nt.asm deleted file mode 100644 index 9ef28aeffc..0000000000 --- a/asmrun/i386nt.asm +++ /dev/null @@ -1,278 +0,0 @@ -;********************************************************************* -; -; Objective Caml -; -; Xavier Leroy, projet Cristal, INRIA Rocquencourt -; -; Copyright 1996 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 file ../LICENSE. -; -;********************************************************************* - -; $Id$ - -; Asm part of the runtime system, Intel 386 processor, Intel syntax - - .386 - .MODEL FLAT - - EXTERN _garbage_collection: PROC - EXTERN _mlraise: PROC - EXTERN _caml_apply2: PROC - EXTERN _caml_apply3: PROC - EXTERN _caml_program: PROC - EXTERN _array_bound_error: PROC - EXTERN _young_limit: DWORD - EXTERN _young_ptr: DWORD - EXTERN _caml_bottom_of_stack: DWORD - EXTERN _caml_last_return_address: DWORD - EXTERN _caml_gc_regs: DWORD - EXTERN _caml_exception_pointer: DWORD - -; Allocation - - .CODE - PUBLIC _caml_alloc1 - PUBLIC _caml_alloc2 - PUBLIC _caml_alloc3 - PUBLIC _caml_alloc - PUBLIC _caml_call_gc - -_caml_call_gc: - ; Record lowest stack address and return address - mov eax, [esp] - mov _caml_last_return_address, eax - lea eax, [esp+4] - mov _caml_bottom_of_stack, eax - ; Save all regs used by the code generator -L105: push ebp - push edi - push esi - push edx - push ecx - push ebx - push eax - mov _caml_gc_regs, esp - ; Call the garbage collector - call _garbage_collection - ; Restore all regs used by the code generator - pop eax - pop ebx - pop ecx - pop edx - pop esi - pop edi - pop ebp - ; Return to caller - ret - - ALIGN 4 -_caml_alloc1: - mov eax, _young_ptr - sub eax, 8 - mov _young_ptr, eax - cmp eax, _young_limit - jb L100 - ret -L100: mov eax, [esp] - mov _caml_last_return_address, eax - lea eax, [esp+4] - mov _caml_bottom_of_stack, eax - call L105 - jmp _caml_alloc1 - - ALIGN 4 -_caml_alloc2: - mov eax, _young_ptr - sub eax, 12 - mov _young_ptr, eax - cmp eax, _young_limit - jb L101 - ret -L101: mov eax, [esp] - mov _caml_last_return_address, eax - lea eax, [esp+4] - mov _caml_bottom_of_stack, eax - call L105 - jmp _caml_alloc2 - - ALIGN 4 -_caml_alloc3: - mov eax, _young_ptr - sub eax, 16 - mov _young_ptr, eax - cmp eax, _young_limit - jb L102 - ret -L102: mov eax, [esp] - mov _caml_last_return_address, eax - lea eax, [esp+4] - mov _caml_bottom_of_stack, eax - call L105 - jmp _caml_alloc3 - - ALIGN 4 -_caml_alloc: - sub eax, _young_ptr ; eax = size - young_ptr - neg eax ; eax = young_ptr - size - cmp eax, _young_limit - jb L103 - mov _young_ptr, eax - ret -L103: sub eax, _young_ptr ; eax = - size - neg eax ; eax = size - push eax ; save desired size - sub _young_ptr, eax ; must update young_ptr - mov eax, [esp+4] - mov _caml_last_return_address, eax - lea eax, [esp+8] - mov _caml_bottom_of_stack, eax - call L105 - pop eax ; recover desired size - jmp _caml_alloc - -; Call a C function from Caml - - PUBLIC _caml_c_call - ALIGN 4 -_caml_c_call: - ; Record lowest stack address and return address - mov edx, [esp] - mov _caml_last_return_address, edx - lea edx, [esp+4] - mov _caml_bottom_of_stack, edx - ; Call the function (address in %eax) - jmp eax - -; Start the Caml program - - PUBLIC _caml_start_program - ALIGN 4 -_caml_start_program: - ; Save callee-save registers - push ebx - push esi - push edi - push ebp - ; Initial code pointer is caml_program - mov esi, offset _caml_program - -; Code shared between caml_start_program and callback* - -L106: - ; Build a callback link - push _caml_gc_regs - push _caml_last_return_address - push _caml_bottom_of_stack - ; Build an exception handler - push L108 - push _caml_exception_pointer - mov _caml_exception_pointer, esp - ; Call the Caml code - call esi -L107: - ; Pop the exception handler - pop _caml_exception_pointer - pop esi ; dummy register -L109: - ; Pop the callback link, restoring the global variables - ; used by caml_c_call - pop _caml_bottom_of_stack - pop _caml_last_return_address - pop _caml_gc_regs - ; Restore callee-save registers. - pop ebp - pop edi - pop esi - pop ebx - ; Return to caller. - ret -L108: - ; Exception handler - ; Mark the bucket as an exception result and return it - or eax, 2 - jmp L109 - -; Raise an exception from C - - PUBLIC _raise_caml_exception - ALIGN 4 -_raise_caml_exception: - mov eax, [esp+4] - mov esp, _caml_exception_pointer - pop _caml_exception_pointer - ret - -; Callback from C to Caml - - PUBLIC _callback_exn - ALIGN 4 -_callback_exn: - ; Save callee-save registers - push ebx - push esi - push edi - push ebp - ; Initial loading of arguments - mov ebx, [esp+20] ; closure - mov eax, [esp+24] ; argument - mov esi, [ebx] ; code pointer - jmp L106 - - PUBLIC _callback2_exn - ALIGN 4 -_callback2_exn: - ; Save callee-save registers - push ebx - push esi - push edi - push ebp - ; Initial loading of arguments - mov ecx, [esp+20] ; closure - mov eax, [esp+24] ; first argument - mov ebx, [esp+28] ; second argument - mov esi, offset _caml_apply2 ; code pointer - jmp L106 - - PUBLIC _callback3_exn - ALIGN 4 -_callback3_exn: - ; Save callee-save registers - push ebx - push esi - push edi - push ebp - ; Initial loading of arguments - mov edx, [esp+20] ; closure - mov eax, [esp+24] ; first argument - mov ebx, [esp+28] ; second argument - mov ecx, [esp+32] ; third argument - mov esi, offset _caml_apply3 ; code pointer - jmp L106 - - PUBLIC _caml_array_bound_error - ALIGN 4 -_caml_array_bound_error: - ; Empty the floating-point stack - ffree st(0) - ffree st(1) - ffree st(2) - ffree st(3) - ffree st(4) - ffree st(5) - ffree st(6) - ffree st(7) - ; Branch to array_bound_error - jmp _array_bound_error - - .DATA - PUBLIC _system__frametable -_system__frametable LABEL DWORD - DWORD 1 ; one descriptor - DWORD L107 ; return address into callback - WORD -1 ; negative frame size => use callback link - WORD 0 ; no roots here - - END diff --git a/asmrun/ia64.S b/asmrun/ia64.S deleted file mode 100644 index 66e1620a92..0000000000 --- a/asmrun/ia64.S +++ /dev/null @@ -1,530 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 1996 Institut National de Recherche en Informatique et */ -/* en Automatique. All rights reserved. This file is distributed */ -/* under the terms of the Q Public License version 1.0. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -/* Asm part of the runtime system, Alpha processor */ - -#undef BROKEN_POSTINCREMENT - -#define ADDRGLOBAL(reg,symb) \ - add reg = @ltoff(symb), gp;; ld8 reg = [reg] -#define LOADGLOBAL(reg,symb) \ - add r3 = @ltoff(symb), gp;; ld8 r3 = [r3];; ld8 reg = [r3] -#define STOREGLOBAL(reg,symb) \ - add r3 = @ltoff(symb), gp;; ld8 r3 = [r3];; st8 [r3] = reg - -#define ST8OFF(a,b,d) st8 [a] = b, d -#define LD8OFF(a,b,d) ld8 a = [b], d -#define STFDOFF(a,b,d) stfd [a] = b, d -#define LDFDOFF(a,b,d) ldfd a = [b], d -#define STFSPILLOFF(a,b,d) stf.spill [a] = b, d -#define LDFFILLOFF(a,b,d) ldf.fill a = [b], d - -#define SAVE2(a,b) ST8OFF(r2, a, 16); ST8OFF(r3, b, 16) -#define SAVE4(a,b,c,d) SAVE2(a,b);; SAVE2(c,d) -#define SAVE8(a,b,c,d,e,f,g,h) SAVE4(a,b,c,d);; SAVE4(e,f,g,h) - -#define LOAD2(a,b) LD8OFF(a, r2, 16); LD8OFF(b, r3, 16) -#define LOAD4(a,b,c,d) LOAD2(a,b);; LOAD2(c,d) -#define LOAD8(a,b,c,d,e,f,g,h) LOAD4(a,b,c,d);; LOAD4(e,f,g,h) - -#define FSAVE2(a,b) STFDOFF(r2, a, 16); STFDOFF(r3, b, 16) -#define FSAVE4(a,b,c,d) FSAVE2(a,b);; FSAVE2(c,d) -#define FSAVE8(a,b,c,d,e,f,g,h) FSAVE4(a,b,c,d);; FSAVE4(e,f,g,h) - -#define FLOAD2(a,b) LDFDOFF(a, r2, 16); LDFDOFF(b, r3, 16) -#define FLOAD4(a,b,c,d) FLOAD2(a,b);; FLOAD2(c,d) -#define FLOAD8(a,b,c,d,e,f,g,h) FLOAD4(a,b,c,d);; FLOAD4(e,f,g,h) - -#define FSPILL2(a,b) STFSPILLOFF(r2, a, 32); STFSPILLOFF(r3, b, 32) -#define FSPILL4(a,b,c,d) FSPILL2(a,b);; FSPILL2(c,d) -#define FSPILL8(a,b,c,d,e,f,g,h) FSPILL4(a,b,c,d);; FSPILL4(e,f,g,h) - -#define FFILL2(a,b) LDFFILLOFF(a, r2, 32); LDFFILLOFF(b, r3, 32) -#define FFILL4(a,b,c,d) FFILL2(a,b);; FFILL2(c,d) -#define FFILL8(a,b,c,d,e,f,g,h) FFILL4(a,b,c,d);; FFILL4(e,f,g,h) - -/* Allocation */ - .text - - .global caml_alloc# - .proc caml_alloc# - .align 16 - -/* caml_alloc: all code generator registers preserved, - gp preserved, r2 = requested size */ - -caml_alloc: - sub r4 = r4, r2 ;; - cmp.ltu p0, p6 = r4, r5 - (p6) br.ret.sptk b0 ;; - /* Stash return address at sp (in stack scratch area) */ - mov r3 = b0 ;; - st8 [sp] = r3 - /* Call GC */ - br.call.sptk b0 = caml_call_gc# ;; - /* Return to caller */ - ld8 r3 = [sp] ;; - mov b0 = r3 ;; - br.ret.sptk b0 - - .endp caml_alloc# - -/* caml_call_gc: all code generator registers preserved, - gp preserved, r2 = requested size */ - - .global caml_call_gc# - .proc caml_call_gc# - .align 16 -caml_call_gc: - /* Allocate stack frame */ - add sp = -(16 + 16 + 80*8 + 42*8), sp ;; - - /* Save requested size and GP on stack */ - add r3 = 16, sp ;; - ST8OFF(r3, r2, 8) ;; - st8 [r3] = gp - - /* Record lowest stack address, return address, GC regs */ - mov r2 = b0 ;; - STOREGLOBAL(r2, caml_last_return_address#) - add r2 = (16 + 16 + 80*8 + 42*8), sp ;; - STOREGLOBAL(r2, caml_bottom_of_stack#) - add r2 = (16 + 16), sp ;; - STOREGLOBAL(r2, caml_gc_regs#) - - /* Save all integer regs used by the code generator in the context */ -.L100: add r3 = 8, r2 ;; - SAVE4(r8,r9,r10,r11) ;; - SAVE8(r16,r17,r18,r19,r20,r21,r22,r23) ;; - SAVE8(r24,r25,r26,r27,r28,r29,r30,r31) ;; - SAVE8(r32,r33,r34,r35,r36,r37,r38,r39) ;; - SAVE8(r40,r41,r42,r43,r44,r45,r46,r47) ;; - SAVE8(r48,r49,r50,r51,r52,r53,r54,r55) ;; - SAVE8(r56,r57,r58,r59,r60,r61,r62,r63) ;; - SAVE8(r64,r65,r66,r67,r68,r69,r70,r71) ;; - SAVE8(r72,r73,r74,r75,r76,r77,r78,r79) ;; - SAVE8(r80,r81,r82,r83,r84,r85,r86,r87) ;; - SAVE4(r88,r89,r90,r91) ;; - - /* Save all floating-point registers not preserved by C */ - FSAVE2(f6,f7) ;; - FSAVE8(f8,f9,f10,f11,f12,f13,f14,f15) ;; - FSAVE8(f32,f33,f34,f35,f36,f37,f38,f39) ;; - FSAVE8(f40,f41,f42,f43,f44,f45,f46,f47) ;; - FSAVE8(f48,f49,f50,f51,f52,f53,f54,f55) ;; - FSAVE8(f56,f57,f58,f59,f60,f61,f62,f63) ;; - - /* Save current allocation pointer for debugging purposes */ - STOREGLOBAL(r4, young_ptr#) - - /* Save trap pointer in case an exception is raised */ - STOREGLOBAL(r6, caml_exception_pointer#) - - /* Call the garbage collector */ - br.call.sptk b0 = garbage_collection# ;; - - /* Restore gp */ - add r3 = 24, sp ;; - ld8 gp = [r3] - - /* Restore all integer regs from GC context */ - add r2 = (16 + 16), sp ;; - add r3 = 8, r2 ;; - LOAD4(r8,r9,r10,r11) ;; - LOAD8(r16,r17,r18,r19,r20,r21,r22,r23) ;; - LOAD8(r24,r25,r26,r27,r28,r29,r30,r31) ;; - LOAD8(r32,r33,r34,r35,r36,r37,r38,r39) ;; - LOAD8(r40,r41,r42,r43,r44,r45,r46,r47) ;; - LOAD8(r48,r49,r50,r51,r52,r53,r54,r55) ;; - LOAD8(r56,r57,r58,r59,r60,r61,r62,r63) ;; - LOAD8(r64,r65,r66,r67,r68,r69,r70,r71) ;; - LOAD8(r72,r73,r74,r75,r76,r77,r78,r79) ;; - LOAD8(r80,r81,r82,r83,r84,r85,r86,r87) ;; - LOAD4(r88,r89,r90,r91) ;; - - /* Restore all floating-point registers not preserved by C */ - FLOAD2(f6,f7) ;; - FLOAD8(f8,f9,f10,f11,f12,f13,f14,f15) ;; - FLOAD8(f32,f33,f34,f35,f36,f37,f38,f39) ;; - FLOAD8(f40,f41,f42,f43,f44,f45,f46,f47) ;; - FLOAD8(f48,f49,f50,f51,f52,f53,f54,f55) ;; - FLOAD8(f56,f57,f58,f59,f60,f61,f62,f63) ;; - - /* Reload new allocation pointer and allocation limit */ - LOADGLOBAL(r4, young_ptr#) - LOADGLOBAL(r5, young_limit#) - - /* Allocate space for the block */ - add r3 = 16, sp ;; - ld8 r2 = [r3] ;; - sub r4 = r4, r2 ;; - cmp.ltu p6, p0 = r4, r5 /* enough space? */ - (p6) br.cond.spnt .L100 ;; /* no: call GC again */ - - /* Reload return address and say that we are back into Caml code */ - ADDRGLOBAL(r3, caml_last_return_address#) ;; - ld8 r2 = [r3] - st8 [r3] = r0 ;; - - /* Return to caller */ - mov b0 = r2 - add sp = (16 + 16 + 80*8 + 42*8), sp ;; - br.ret.sptk b0 - - .endp caml_call_gc# - -/* Call a C function from Caml */ -/* Function to call is in r2 */ - - .global caml_c_call# - .proc caml_c_call# - .align 16 - -caml_c_call: - /* The Caml code that called us does not expect any - code-generator registers to be preserved */ - - /* Recover entry point from the function pointer in r2 */ - LD8OFF(r3, r2, 8) ;; - mov b6 = r3 - - /* Preserve gp in r7 */ - mov r7 = gp - - /* Record lowest stack address and return address */ - mov r14 = b0 - STOREGLOBAL(sp, caml_bottom_of_stack#) ;; - STOREGLOBAL(r14, caml_last_return_address#) - - /* Make the exception handler and alloc ptr available to the C code */ - STOREGLOBAL(r4, young_ptr#) - STOREGLOBAL(r6, caml_exception_pointer#) - - /* Recover gp from the function pointer in r2 */ - ld8 gp = [r2] - - /* Call the function */ - br.call.sptk b0 = b6 ;; - - /* Restore gp */ - mov gp = r7 ;; - - /* Reload alloc ptr and alloc limit */ - LOADGLOBAL(r4, young_ptr#) - LOADGLOBAL(r5, young_limit#) - - /* Reload return address and say that we are back into Caml code */ - ADDRGLOBAL(r3, caml_last_return_address#) ;; - ld8 r2 = [r3] - st8 [r3] = r0 ;; - - /* Return to caller */ - mov b0 = r2 ;; - br.ret.sptk b0 - - .endp caml_c_call# - -/* Start the Caml program */ - - .global caml_start_program# - .proc caml_start_program# - .align 16 - -caml_start_program: - ADDRGLOBAL(r2, caml_program#) ;; - mov b6 = r2 - - /* Code shared with callback* */ -.L103: - /* Allocate 64 "out" registers (for the Caml code) and no locals */ - alloc r3 = ar.pfs, 0, 0, 64, 0 - add sp = -(56 * 8), sp ;; - - /* Save all callee-save registers on stack */ - add r2 = 16, sp ;; - ST8OFF(r2, r3, 8) /* 0 : ar.pfs */ - mov r3 = b0 ;; - ST8OFF(r2, r3, 8) ;; /* 1 : return address */ - ST8OFF(r2, gp, 8) /* 2 : gp */ - mov r3 = pr ;; - ST8OFF(r2, r3, 8) /* 3 : predicates */ - mov r3 = ar.fpsr ;; - ST8OFF(r2, r3, 8) /* 4 : ar.fpsr */ - mov r3 = ar.unat ;; - ST8OFF(r2, r3, 8) /* 5 : ar.unat */ - mov r3 = ar.lc ;; - ST8OFF(r2, r3, 8) /* 6 : ar.lc */ - mov r3 = b1 ;; - ST8OFF(r2, r3, 8) /* 7 - 11 : b1 - b5 */ - mov r3 = b2 ;; - ST8OFF(r2, r3, 8) - mov r3 = b3 ;; - ST8OFF(r2, r3, 8) - mov r3 = b4 ;; - ST8OFF(r2, r3, 8) - mov r3 = b5 ;; - ST8OFF(r2, r3, 8) ;; - - add r3 = 8, r2 ;; - SAVE4(r4,r5,r6,r7) ;; /* 12 - 15 : r4 - r7 */ - - add r3 = 16, r2 ;; /* 16 - 55 : f2 - f5, f16 - f31 */ - FSPILL4(f2,f3,f4,f5) ;; - FSPILL8(f16,f17,f18,f19,f20,f21,f22,f23) ;; - FSPILL8(f24,f25,f26,f27,f28,f29,f30,f31) ;; - - /* Set up a callback link on the stack. In addition to - the normal callback link contents (saved values of - caml_bottom_of_stack, caml_last_return_address and - caml_gc_regs), we also save there caml_saved_bsp - and caml_saved_rnat */ - add sp = -48, sp - LOADGLOBAL(r3, caml_bottom_of_stack#) - add r2 = 16, sp ;; - ST8OFF(r2, r3, 8) - LOADGLOBAL(r3, caml_last_return_address#) ;; - ST8OFF(r2, r3, 8) - LOADGLOBAL(r3, caml_gc_regs#) ;; - ST8OFF(r2, r3, 8) - LOADGLOBAL(r3, caml_saved_bsp#) ;; - ST8OFF(r2, r3, 8) - LOADGLOBAL(r3, caml_saved_rnat#) ;; - ST8OFF(r2, r3, 8) - - /* Set up a trap frame to catch exceptions escaping the Caml code */ - mov r6 = sp - add sp = -16, sp ;; - LOADGLOBAL(r3, caml_exception_pointer#) - add r2 = 16, sp ;; - ST8OFF(r2, r3, 8) -.L110: mov r3 = ip ;; - add r3 = .L101 - .L110, r3 ;; - ST8OFF(r2, r3, 8) ;; - - /* Save ar.bsp, flush register window, and save ar.rnat */ - mov r2 = ar.bsp ;; - STOREGLOBAL(r2, caml_saved_bsp#) ;; - mov r14 = ar.rsc ;; - and r2 = ~0x3, r14;; /* set rsc.mode = 0 */ - mov ar.rsc = r2 ;; /* RSE is in enforced lazy mode */ - flushrs ;; /* must be first instr in group */ - mov r2 = ar.rnat ;; - STOREGLOBAL(r2, caml_saved_rnat#) - mov ar.rsc = r14 /* restore original RSE mode */ - - /* Reload allocation pointers */ - LOADGLOBAL(r4, young_ptr#) - LOADGLOBAL(r5, young_limit#) - - /* We are back into Caml code */ - STOREGLOBAL(r0, caml_last_return_address#) - - /* Call the Caml code */ - br.call.sptk b0 = b6 ;; -.L102: - - /* Pop the trap frame, restoring caml_exception_pointer */ - add sp = 16, sp ;; - ld8 r2 = [sp] ;; - STOREGLOBAL(r2, caml_exception_pointer#) - -.L104: - /* Pop the callback link, restoring the global variables */ - add r14 = 16, sp ;; - LD8OFF(r2, r14, 8) ;; - STOREGLOBAL(r2, caml_bottom_of_stack#) - LD8OFF(r2, r14, 8) ;; - STOREGLOBAL(r2, caml_last_return_address#) - LD8OFF(r2, r14, 8) ;; - STOREGLOBAL(r2, caml_gc_regs#) - LD8OFF(r2, r14, 8) ;; - STOREGLOBAL(r2, caml_saved_bsp#) - LD8OFF(r2, r14, 8) ;; - STOREGLOBAL(r2, caml_saved_rnat#) - add sp = 48, sp - - /* Update allocation pointer */ - STOREGLOBAL(r4, young_ptr#) - - /* Restore all callee-save registers from stack */ - add r2 = 16, sp ;; - LD8OFF(r3, r2, 8) ;; /* 0 : ar.pfs */ - mov ar.pfs = r3 - LD8OFF(r3, r2, 8) ;; /* 1 : return address */ - mov b0 = r3 - LD8OFF(gp, r2, 8) ;; /* 2 : gp */ - LD8OFF(r3, r2, 8) ;; /* 3 : predicates */ - mov pr = r3, -1 - LD8OFF(r3, r2, 8) ;; /* 4 : ar.fpsr */ - mov ar.fpsr = r3 - LD8OFF(r3, r2, 8) ;; /* 5 : ar.unat */ - mov ar.unat = r3 - LD8OFF(r3, r2, 8) ;; /* 6 : ar.lc */ - mov ar.lc = r3 - LD8OFF(r3, r2, 8) ;; /* 7 - 11 : b1 - b5 */ - mov b1 = r3 - LD8OFF(r3, r2, 8) ;; - mov b2 = r3 - LD8OFF(r3, r2, 8) ;; - mov b3 = r3 - LD8OFF(r3, r2, 8) ;; - mov b4 = r3 - LD8OFF(r3, r2, 8) ;; - mov b5 = r3 - - add r3 = 8, r2 ;; - LOAD4(r4,r5,r6,r7) ;; /* 12 - 15 : r4 - r7 */ - - add r3 = 16, r2 ;; /* 16 - 55 : f2 - f5, f16 - f31 */ - FFILL4(f2,f3,f4,f5) ;; - FFILL8(f16,f17,f18,f19,f20,f21,f22,f23) ;; - FFILL8(f24,f25,f26,f27,f28,f29,f30,f31) ;; - - /* Pop stack frame and return */ - add sp = (56 * 8), sp - br.ret.sptk.many b0 ;; - - /* The trap handler */ -.L101: - /* Save exception pointer */ - STOREGLOBAL(r6, caml_exception_pointer#) - - /* Encode exception bucket as exception result */ - or r8 = 2, r8 - - /* Return it */ - br.sptk .L104 ;; - - .endp caml_start_program# - -/* Raise an exception from C */ - - .global raise_caml_exception# - .proc raise_caml_exception# - .align 16 -raise_caml_exception: - /* Allocate 64 "out" registers (for the Caml code) and no locals */ - /* Since we don't return, don't bother saving the PFS */ - alloc r2 = ar.pfs, 0, 0, 64, 0 - - /* Move exn bucket where Caml expects it */ - mov r8 = r32 ;; - - /* Perform "context switch" as per the Software Conventions Guide, - chapter 10 */ - flushrs ;; /* flush dirty registers to stack */ - mov r14 = ar.rsc ;; - and r2 = ~0x3, r14;; /* set rsc.mode = 0 */ - dep r2 = r0, r2, 16, 4 ;; /* clear rsc.loadrs */ - mov ar.rsc = r2 ;; /* RSE is in enforced lazy mode */ - invala ;; /* Invalidate ALAT */ - LOADGLOBAL(r2, caml_saved_bsp#) ;; - mov ar.bspstore = r2 /* Restore ar.bspstore */ - LOADGLOBAL(r2, caml_saved_rnat#) ;; - mov ar.rnat = r2 /* Restore ar.rnat */ - mov ar.rsc = r14 ;; /* Restore original RSE mode */ - - /* Reload allocation pointers and exception pointer */ - LOADGLOBAL(r4, young_ptr#) - LOADGLOBAL(r5, young_limit#) - LOADGLOBAL(r6, caml_exception_pointer#) - - /* Say that we're back into Caml */ - STOREGLOBAL(r0, caml_last_return_address#) - - /* Raise the exception proper */ - mov sp = r6 - add r2 = 8, r6 ;; - ld8 r6 = [r6] - ld8 r2 = [r2] ;; - mov b6 = r2 ;; - - /* Branch to handler. Must use a call so as to set up the - CFM and PFS correctly. */ - br.call.sptk.many b0 = b6 - - .endp raise_caml_exception - -/* Callbacks from C to Caml */ - - .global callback_exn# - .proc callback_exn# - .align 16 -callback_exn: - /* Initial shuffling of arguments */ - ld8 r3 = [r32] /* code pointer */ - mov r2 = r32 - mov r32 = r33 ;; /* first arg */ - mov r33 = r2 /* environment */ - mov b6 = r3 - br.sptk .L103 ;; - - .endp callback_exn# - - .global callback2_exn# - .proc callback2_exn# - .align 16 -callback2_exn: - /* Initial shuffling of arguments */ - ADDRGLOBAL(r3, caml_apply2) /* code pointer */ - mov r2 = r32 - mov r32 = r33 /* first arg */ - mov r33 = r34 ;; /* second arg */ - mov r34 = r2 /* environment */ - mov b6 = r3 - br.sptk .L103 ;; - - .endp callback2_exn# - - .global callback3_exn# - .proc callback3_exn# - .align 16 -callback3_exn: - /* Initial shuffling of arguments */ - ADDRGLOBAL(r3, caml_apply3) /* code pointer */ - mov r2 = r32 - mov r32 = r33 /* first arg */ - mov r33 = r34 /* second arg */ - mov r34 = r35 ;; /* third arg */ - mov r35 = r2 /* environment */ - mov b6 = r3 - br.sptk .L103 ;; - - .endp callback3_exn# - -/* Glue code to call array_bound_error */ - - .global caml_array_bound_error# - .proc caml_array_bound_error# - .align 16 -caml_array_bound_error: - ADDRGLOBAL(r2, @fptr(array_bound_error#)) - br.sptk caml_c_call /* never returns */ - - .rodata - - .global system__frametable# - .type system__frametable#, @object - .size system__frametable#, 8 -system__frametable: - data8 1 /* one descriptor */ - data8 .L102 /* return address into callback */ - data2 -1 /* negative frame size => use callback link */ - data2 0 /* no roots here */ - .align 8 - -/* Global variables used by raise_caml_exception */ - - .common caml_saved_bsp#, 8, 8 - .common caml_saved_rnat#, 8, 8 diff --git a/asmrun/m68k.S b/asmrun/m68k.S deleted file mode 100644 index 85de3fb3dc..0000000000 --- a/asmrun/m68k.S +++ /dev/null @@ -1,244 +0,0 @@ -|*********************************************************************** -|* * -|* Objective Caml * -|* * -|* Xavier Leroy, projet Cristal, INRIA Rocquencourt * -|* * -|* Copyright 1996 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 file ../LICENSE. * -|* * -|*********************************************************************** - -| $Id$ - -| Asm part of the runtime system, Motorola 68k processor - - .comm _caml_requested_size, 4 - -| Allocation - - .text - .globl _caml_call_gc - .globl _caml_alloc1 - .globl _caml_alloc2 - .globl _caml_alloc3 - .globl _caml_alloc - -_caml_call_gc: - | Save desired size - movel d5, _caml_requested_size - | Record lowest stack address and return address - movel a7@, _caml_last_return_address - movel a7, d5 - addql #4, d5 - movel d5, _caml_bottom_of_stack - | Record current allocation pointer (for debugging) - movel d6, _young_ptr - | Save all regs used by the code generator - movel d4, a7@- - movel d3, a7@- - movel d2, a7@- - movel d1, a7@- - movel d0, a7@- - movel a6, a7@- - movel a5, a7@- - movel a4, a7@- - movel a3, a7@- - movel a2, a7@- - movel a1, a7@- - movel a0, a7@- - movel a7, _caml_gc_regs - fmovem fp0-fp7, a7@- - | Call the garbage collector - jbsr _garbage_collection - | Restore all regs used by the code generator - fmovem a7@+, fp0-fp7 - movel a7@+, a0 - movel a7@+, a1 - movel a7@+, a2 - movel a7@+, a3 - movel a7@+, a4 - movel a7@+, a5 - movel a7@+, a6 - movel a7@+, d0 - movel a7@+, d1 - movel a7@+, d2 - movel a7@+, d3 - movel a7@+, d4 - | Reload allocation pointer and allocate block - movel _young_ptr, d6 - subl _caml_requested_size, d6 - | Return to caller - rts - -_caml_alloc1: - subql #8, d6 - cmpl _young_limit, d6 - bcs L100 - rts -L100: moveq #8, d5 - bra _caml_call_gc - -_caml_alloc2: - subl #12, d6 - cmpl _young_limit, d6 - bcs L101 - rts -L101: moveq #12, d5 - bra _caml_call_gc - -_caml_alloc3: - subl #16, d6 - cmpl _young_limit, d6 - bcs L102 - rts -L102: moveq #16, d5 - bra _caml_call_gc - -_caml_alloc: - subl d5, d6 - cmpl _young_limit, d6 - bcs _caml_call_gc - rts - -| Call a C function from Caml - - .globl _caml_c_call - -_caml_c_call: - | Record lowest stack address and return address - movel a7@+, _caml_last_return_address - movel a7, _caml_bottom_of_stack - | Save allocation pointer and exception pointer - movel d6, _young_ptr - movel d7, _caml_exception_pointer - | Call the function (address in a0) - jbsr a0@ - | Reload allocation pointer - movel _young_ptr, d6 - | Return to caller - movel _caml_last_return_address, a1 - jmp a1@ - -| Start the Caml program - - .globl _caml_start_program - -_caml_start_program: - | Save callee-save registers - moveml a2-a6/d2-d7, a7@- - fmovem fp2-fp7, a7@- - | Initial code point is caml_program - lea _caml_program, a5 - -| Code shared between caml_start_program and callback* - -L106: - | Build a callback link - movel _caml_gc_regs, a7@- - movel _caml_last_return_address, a7@- - movel _caml_bottom_of_stack, a7@- - | Build an exception handler - pea L108 - movel _caml_exception_pointer, a7@- - movel a7, d7 - | Load allocation pointer - movel _young_ptr, d6 - | Call the Caml code - jbsr a5@ -L107: - | Move result where C code expects it - movel a0, d0 - | Save allocation pointer - movel d6, _young_ptr - | Pop the exception handler - movel a7@+, _caml_exception_pointer - addql #4, a7 -L109: - | Pop the callback link, restoring the global variables - | used by caml_c_call - movel a7@+, _caml_bottom_of_stack - movel a7@+, _caml_last_return_address - movel a7@+, _caml_gc_regs - | Restore callee-save registers and return - fmovem a7@+, fp2-fp7 - moveml a7@+, a2-a6/d2-d7 - unlk a6 - rts -L108: - | Exception handler - | Save allocation pointer and exception pointer - movel d6, _young_ptr - movel d7, _caml_exception_pointer - | Encode exception bucket as an exception result - movel a0, d0 - orl #2, d0 - | Return it - bra L109 - -| Raise an exception from C - - .globl _raise_caml_exception -_raise_caml_exception: - movel a7@(4), a0 | exception bucket - movel _young_ptr, d6 - movel _caml_exception_pointer, a7 - movel a7@+, d7 - rts - -| Callback from C to Caml - - .globl _callback_exn -_callback_exn: - link a6, #0 - | Save callee-save registers - moveml a2-a6/d2-d7, a7@- - fmovem fp2-fp7, a7@- - | Initial loading of arguments - movel a6@(8), a1 | closure - movel a6@(12), a0 | argument - movel a1@(0), a5 | code pointer - bra L106 - - .globl _callback2_exn -_callback2_exn: - link a6, #0 - | Save callee-save registers - moveml a2-a6/d2-d7, a7@- - fmovem fp2-fp7, a7@- - | Initial loading of arguments - movel a6@(8), a2 | closure - movel a6@(12), a0 | first argument - movel a6@(16), a1 | second argument - lea _caml_apply2, a5 | code pointer - bra L106 - - .globl _callback3_exn -_callback3_exn: - link a6, #0 - | Save callee-save registers - moveml a2-a6/d2-d7, a7@- - fmovem fp2-fp7, a7@- - | Initial loading of arguments - movel a6@(8), a3 | closure - movel a6@(12), a0 | first argument - movel a6@(16), a1 | second argument - movel a6@(20), a2 | third argument - lea _caml_apply3, a5 | code pointer - bra L106 - - .globl _caml_array_bound_error -_caml_array_bound_error: - | Load address of array_bound_error in a0 and call it - lea _array_bound_error, a0 - bra _caml_c_call - - .data - .globl _system__frametable -_system__frametable: - .long 1 | one descriptor - .long L107 | return address into callback - .word -1 | negative frame size => use callback link - .word 0 | no roots here diff --git a/asmrun/mips.s b/asmrun/mips.s deleted file mode 100644 index 26853c0d8d..0000000000 --- a/asmrun/mips.s +++ /dev/null @@ -1,386 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 1996 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 file ../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -/* Asm part of the runtime system, Mips processor, IRIX n32 conventions */ - -/* Allocation */ - - .text - - .globl caml_call_gc - .ent caml_call_gc - -caml_call_gc: - /* Reserve stack space for registers and saved $gp */ - /* 32 * 8 = 0x100 for float regs - 22 * 4 = 0x58 for integer regs - 8 = 0x8 for saved $gp ====> 0x160 total */ - subu $sp, $sp, 0x160 - /* Reinit $gp */ - .cpsetup $25, 0x158, caml_call_gc - /* Record return address */ - sw $31, caml_last_return_address - /* Record lowest stack address */ - addu $24, $sp, 0x160 - sw $24, caml_bottom_of_stack - /* Save pointer to register array */ - addu $24, $sp, 0x100 - sw $24, caml_gc_regs - /* Save current allocation pointer for debugging purposes */ - sw $22, young_ptr - /* Save the exception handler (if e.g. a sighandler raises) */ - sw $30, caml_exception_pointer - /* Save all regs used by the code generator on the stack */ - sw $2, 2 * 4($24) - sw $3, 3 * 4($24) - sw $4, 4 * 4($24) - sw $5, 5 * 4($24) - sw $6, 6 * 4($24) - sw $7, 7 * 4($24) - sw $8, 8 * 4($24) - sw $9, 9 * 4($24) - sw $10, 10 * 4($24) - sw $11, 11 * 4($24) - sw $12, 12 * 4($24) - sw $13, 13 * 4($24) - sw $14, 14 * 4($24) - sw $15, 15 * 4($24) - sw $16, 16 * 4($24) - sw $17, 17 * 4($24) - sw $18, 18 * 4($24) - sw $19, 19 * 4($24) - sw $20, 20 * 4($24) - sw $21, 21 * 4($24) - s.d $f0, 0 * 8($sp) - s.d $f1, 1 * 8($sp) - s.d $f2, 2 * 8($sp) - s.d $f3, 3 * 8($sp) - s.d $f4, 4 * 8($sp) - s.d $f5, 5 * 8($sp) - s.d $f6, 6 * 8($sp) - s.d $f7, 7 * 8($sp) - s.d $f8, 8 * 8($sp) - s.d $f9, 9 * 8($sp) - s.d $f10, 10 * 8($sp) - s.d $f11, 11 * 8($sp) - s.d $f12, 12 * 8($sp) - s.d $f13, 13 * 8($sp) - s.d $f14, 14 * 8($sp) - s.d $f15, 15 * 8($sp) - s.d $f16, 16 * 8($sp) - s.d $f17, 17 * 8($sp) - s.d $f18, 18 * 8($sp) - s.d $f19, 19 * 8($sp) - s.d $f20, 20 * 8($sp) - s.d $f21, 21 * 8($sp) - s.d $f22, 22 * 8($sp) - s.d $f23, 23 * 8($sp) - s.d $f24, 24 * 8($sp) - s.d $f25, 25 * 8($sp) - s.d $f26, 26 * 8($sp) - s.d $f27, 27 * 8($sp) - s.d $f28, 28 * 8($sp) - s.d $f29, 29 * 8($sp) - s.d $f30, 30 * 8($sp) - s.d $f31, 31 * 8($sp) - /* Call the garbage collector */ - jal garbage_collection - /* Restore all regs used by the code generator */ - addu $24, $sp, 0x100 - lw $2, 2 * 4($24) - lw $3, 3 * 4($24) - lw $4, 4 * 4($24) - lw $5, 5 * 4($24) - lw $6, 6 * 4($24) - lw $7, 7 * 4($24) - lw $8, 8 * 4($24) - lw $9, 9 * 4($24) - lw $10, 10 * 4($24) - lw $11, 11 * 4($24) - lw $12, 12 * 4($24) - lw $13, 13 * 4($24) - lw $14, 14 * 4($24) - lw $15, 15 * 4($24) - lw $16, 16 * 4($24) - lw $17, 17 * 4($24) - lw $18, 18 * 4($24) - lw $19, 19 * 4($24) - lw $20, 20 * 4($24) - lw $21, 21 * 4($24) - l.d $f0, 0 * 8($sp) - l.d $f1, 1 * 8($sp) - l.d $f2, 2 * 8($sp) - l.d $f3, 3 * 8($sp) - l.d $f4, 4 * 8($sp) - l.d $f5, 5 * 8($sp) - l.d $f6, 6 * 8($sp) - l.d $f7, 7 * 8($sp) - l.d $f8, 8 * 8($sp) - l.d $f9, 9 * 8($sp) - l.d $f10, 10 * 8($sp) - l.d $f11, 11 * 8($sp) - l.d $f12, 12 * 8($sp) - l.d $f13, 13 * 8($sp) - l.d $f14, 14 * 8($sp) - l.d $f15, 15 * 8($sp) - l.d $f16, 16 * 8($sp) - l.d $f17, 17 * 8($sp) - l.d $f18, 18 * 8($sp) - l.d $f19, 19 * 8($sp) - l.d $f20, 20 * 8($sp) - l.d $f21, 21 * 8($sp) - l.d $f22, 22 * 8($sp) - l.d $f23, 23 * 8($sp) - l.d $f24, 24 * 8($sp) - l.d $f25, 25 * 8($sp) - l.d $f26, 26 * 8($sp) - l.d $f27, 27 * 8($sp) - l.d $f28, 28 * 8($sp) - l.d $f29, 29 * 8($sp) - l.d $f30, 30 * 8($sp) - l.d $f31, 31 * 8($sp) - /* Reload new allocation pointer and allocation limit */ - lw $22, young_ptr - lw $23, young_limit - /* Reload return address */ - lw $31, caml_last_return_address - /* Say that we are back into Caml code */ - sw $0, caml_last_return_address - /* Adjust return address to restart the allocation sequence */ - subu $31, $31, 16 - /* Return */ - .cpreturn - addu $sp, $sp, 0x160 - j $31 - - .end caml_call_gc - -/* Call a C function from Caml */ - - .globl caml_c_call - .ent caml_c_call - -caml_c_call: - /* Function to call is in $24 */ - /* Set up $gp, saving caller's $gp in callee-save register $19 */ - .cpsetup $25, $19, caml_c_call - /* Preload addresses of interesting global variables - in callee-save registers */ - la $16, caml_last_return_address - la $17, young_ptr - /* Save return address, bottom of stack, alloc ptr, exn ptr */ - sw $31, 0($16) /* caml_last_return_address */ - sw $sp, caml_bottom_of_stack - sw $22, 0($17) /* young_ptr */ - sw $30, caml_exception_pointer - /* Call C function */ - move $25, $24 - jal $24 - /* Reload return address, alloc ptr, alloc limit */ - lw $31, 0($16) /* caml_last_return_address */ - lw $22, 0($17) /* young_ptr */ - lw $23, young_limit /* young_limit */ - /* Zero caml_last_return_address, indicating we're back in Caml code */ - sw $0, 0($16) /* caml_last_return_address */ - /* Restore $gp and return */ - move $gp, $19 - j $31 - .end caml_c_call - -/* Start the Caml program */ - - .globl caml_start_program - .globl stray_exn_handler - .ent caml_start_program -caml_start_program: - /* Reserve space for callee-save registers */ - subu $sp, $sp, 0x90 - /* Setup $gp */ - .cpsetup $25, 0x80, caml_start_program - /* Load in $24 the code address to call */ - la $24, caml_program - /* Code shared with callback* */ -$103: - /* Save return address */ - sd $31, 0x88($sp) - /* Save all callee-save registers */ - sd $16, 0x0($sp) - sd $17, 0x8($sp) - sd $18, 0x10($sp) - sd $19, 0x18($sp) - sd $20, 0x20($sp) - sd $21, 0x28($sp) - sd $22, 0x30($sp) - sd $23, 0x38($sp) - sd $30, 0x40($sp) - s.d $f20, 0x48($sp) - s.d $f22, 0x50($sp) - s.d $f24, 0x58($sp) - s.d $f26, 0x60($sp) - s.d $f28, 0x68($sp) - s.d $f30, 0x70($sp) - /* Set up a callback link on the stack. */ - subu $sp, $sp, 16 - lw $2, caml_bottom_of_stack - sw $2, 0($sp) - lw $3, caml_last_return_address - sw $3, 4($sp) - lw $4, caml_gc_regs - sw $4, 8($sp) - /* Set up a trap frame to catch exceptions escaping the Caml code */ - subu $sp, $sp, 16 - lw $30, caml_exception_pointer - sw $30, 0($sp) - la $2, $105 - sw $2, 4($sp) - sw $gp, 8($sp) - move $30, $sp - /* Reload allocation pointers */ - lw $22, young_ptr - lw $23, young_limit - /* Say that we are back into Caml code */ - sw $0, caml_last_return_address - /* Call the Caml code */ - move $25, $24 - jal $24 -$104: - /* Pop the trap frame, restoring caml_exception_pointer */ - lw $24, 0($sp) - sw $24, caml_exception_pointer - addu $sp, $sp, 16 -$106: - /* Pop the callback link, restoring the global variables */ - lw $24, 0($sp) - sw $24, caml_bottom_of_stack - lw $25, 4($sp) - sw $25, caml_last_return_address - lw $24, 8($sp) - sw $24, caml_gc_regs - addu $sp, $sp, 16 - /* Update allocation pointer */ - sw $22, young_ptr - /* Reload callee-save registers and return */ - ld $31, 0x88($sp) - ld $16, 0x0($sp) - ld $17, 0x8($sp) - ld $18, 0x10($sp) - ld $19, 0x18($sp) - ld $20, 0x20($sp) - ld $21, 0x28($sp) - ld $22, 0x30($sp) - ld $23, 0x38($sp) - ld $30, 0x40($sp) - l.d $f20, 0x48($sp) - l.d $f22, 0x50($sp) - l.d $f24, 0x58($sp) - l.d $f26, 0x60($sp) - l.d $f28, 0x68($sp) - l.d $f30, 0x70($sp) - .cpreturn - addu $sp, $sp, 0x90 - j $31 - - /* The trap handler: encode exception bucket as an exception result - and return it */ -$105: - sw $30, caml_exception_pointer - or $2, $2, 2 - b $106 - - .end caml_start_program - -/* Raise an exception from C */ - - .globl raise_caml_exception - .ent raise_caml_exception -raise_caml_exception: - /* Setup $gp, discarding caller's $gp (we won't return) */ - .cpsetup $25, $24, raise_caml_exception - /* Branch to exn handler */ - move $2, $4 - lw $22, young_ptr - lw $23, young_limit - lw $sp, caml_exception_pointer - lw $30, 0($sp) - lw $24, 4($sp) - lw $gp, 8($sp) - addu $sp, $sp, 16 - j $24 - - .end raise_caml_exception - -/* Callback from C to Caml */ - - .globl callback_exn - .ent callback_exn -callback_exn: - subu $sp, $sp, 0x90 - .cpsetup $25, 0x80, callback_exn - /* Initial shuffling of arguments */ - move $9, $4 /* closure */ - move $8, $5 /* argument */ - lw $24, 0($4) /* code pointer */ - b $103 - .end callback_exn - - .globl callback2_exn - .ent callback2_exn -callback2_exn: - subu $sp, $sp, 0x90 - .cpsetup $25, 0x80, callback2_exn - /* Initial shuffling of arguments */ - move $10, $4 /* closure */ - move $8, $5 /* first argument */ - move $9, $6 /* second argument */ - la $24, caml_apply2 /* code pointer */ - b $103 - - .end callback2_exn - - .globl callback3_exn - .ent callback3_exn -callback3_exn: - subu $sp, $sp, 0x90 - .cpsetup $25, 0x80, callback3_exn - /* Initial shuffling of arguments */ - move $11, $4 /* closure */ - move $8, $5 /* first argument */ - move $9, $6 /* second argument */ - move $10, $7 /* third argument */ - la $24, caml_apply3 /* code pointer */ - b $103 - - .end callback3_exn - -/* Glue code to call array_bound_error */ - - .globl caml_array_bound_error - .ent caml_array_bound_error - -caml_array_bound_error: - /* Setup $gp, discarding caller's $gp (we won't return) */ - .cpsetup $25, $24, caml_array_bound_error - la $24, array_bound_error - jal caml_c_call /* never returns */ - - .end caml_array_bound_error - - .rdata - .globl system__frametable -system__frametable: - .word 1 /* one descriptor */ - .word $104 /* return address into callback */ - .half -1 /* negative frame size => use callback link */ - .half 0 /* no roots here */ diff --git a/asmrun/power-aix.S b/asmrun/power-aix.S deleted file mode 100644 index 3baa5f9665..0000000000 --- a/asmrun/power-aix.S +++ /dev/null @@ -1,513 +0,0 @@ -#********************************************************************* -#* * -#* Objective Caml * -#* * -#* Xavier Leroy, projet Cristal, INRIA Rocquencourt * -#* * -#* Copyright 1996 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 file ../LICENSE. * -#* * -#********************************************************************* - -# $Id$ - - .csect .text[PR] - -#### Invoke the garbage collector. r0 contains the return address - - .globl .caml_call_gc -.caml_call_gc: - # Set up stack frame - stwu 1, -0x1C0(1) - # 0x1C0 = 4*32 (int regs) + 8*32 (float regs) + 64 (space for C call) - # Record last return address into Caml code - lwz 11, L..caml_last_return_address(2) - stw 0, 0(11) - # Record return address into call_gc stub code - mflr 0 - stw 0, 0x1C0+8(1) - # Record lowest stack address - lwz 11, L..caml_bottom_of_stack(2) - addi 0, 1, 0x1C0 - stw 0, 0(11) - # Record pointer to register array - lwz 11, L..caml_gc_regs(2) - addi 0, 1, 8*32 + 64 - stw 0, 0(11) - # Save current allocation pointer for debugging purposes - lwz 11, L..young_ptr(2) - stw 31, 0(11) - # Save exception pointer (if e.g. a sighandler raises) - lwz 11, L..caml_exception_pointer(2) - stw 29, 0(11) - # Save all registers used by the code generator - addi 11, 1, 8*32 + 64 - 4 - stwu 3, 4(11) - stwu 4, 4(11) - stwu 5, 4(11) - stwu 6, 4(11) - stwu 7, 4(11) - stwu 8, 4(11) - stwu 9, 4(11) - stwu 10, 4(11) - stwu 14, 4(11) - stwu 15, 4(11) - stwu 16, 4(11) - stwu 17, 4(11) - stwu 18, 4(11) - stwu 19, 4(11) - stwu 20, 4(11) - stwu 21, 4(11) - stwu 22, 4(11) - stwu 23, 4(11) - stwu 24, 4(11) - stwu 25, 4(11) - stwu 26, 4(11) - stwu 27, 4(11) - stwu 28, 4(11) - addi 11, 1, 64 - 8 - stfdu 1, 8(11) - stfdu 2, 8(11) - stfdu 3, 8(11) - stfdu 4, 8(11) - stfdu 5, 8(11) - stfdu 6, 8(11) - stfdu 7, 8(11) - stfdu 8, 8(11) - stfdu 9, 8(11) - stfdu 10, 8(11) - stfdu 11, 8(11) - stfdu 12, 8(11) - stfdu 13, 8(11) - stfdu 14, 8(11) - stfdu 15, 8(11) - stfdu 16, 8(11) - stfdu 17, 8(11) - stfdu 18, 8(11) - stfdu 19, 8(11) - stfdu 20, 8(11) - stfdu 21, 8(11) - stfdu 22, 8(11) - stfdu 23, 8(11) - stfdu 24, 8(11) - stfdu 25, 8(11) - stfdu 26, 8(11) - stfdu 27, 8(11) - stfdu 28, 8(11) - stfdu 29, 8(11) - stfdu 30, 8(11) - stfdu 31, 8(11) - # Call the GC - bl .garbage_collection - or 0, 0, 0 - # Reload new allocation pointer and allocation limit - lwz 11, L..young_ptr(2) - lwz 31, 0(11) - lwz 11, L..young_limit(2) - lwz 30, 0(11) - # Restore all regs used by the code generator - addi 11, 1, 8*32 + 64 - 4 - lwzu 3, 4(11) - lwzu 4, 4(11) - lwzu 5, 4(11) - lwzu 6, 4(11) - lwzu 7, 4(11) - lwzu 8, 4(11) - lwzu 9, 4(11) - lwzu 10, 4(11) - lwzu 14, 4(11) - lwzu 15, 4(11) - lwzu 16, 4(11) - lwzu 17, 4(11) - lwzu 18, 4(11) - lwzu 19, 4(11) - lwzu 20, 4(11) - lwzu 21, 4(11) - lwzu 22, 4(11) - lwzu 23, 4(11) - lwzu 24, 4(11) - lwzu 25, 4(11) - lwzu 26, 4(11) - lwzu 27, 4(11) - lwzu 28, 4(11) - addi 11, 1, 64 - 8 - lfdu 1, 8(11) - lfdu 2, 8(11) - lfdu 3, 8(11) - lfdu 4, 8(11) - lfdu 5, 8(11) - lfdu 6, 8(11) - lfdu 7, 8(11) - lfdu 8, 8(11) - lfdu 9, 8(11) - lfdu 10, 8(11) - lfdu 11, 8(11) - lfdu 12, 8(11) - lfdu 13, 8(11) - lfdu 14, 8(11) - lfdu 15, 8(11) - lfdu 16, 8(11) - lfdu 17, 8(11) - lfdu 18, 8(11) - lfdu 19, 8(11) - lfdu 20, 8(11) - lfdu 21, 8(11) - lfdu 22, 8(11) - lfdu 23, 8(11) - lfdu 24, 8(11) - lfdu 25, 8(11) - lfdu 26, 8(11) - lfdu 27, 8(11) - lfdu 28, 8(11) - lfdu 29, 8(11) - lfdu 30, 8(11) - lfdu 31, 8(11) - # Return to caller (the stub code), leaving return address into - # Caml code in the link register - lwz 0, 0x1C0+8(1) - mtctr 0 - lwz 11, L..caml_last_return_address(2) - lwz 0, 0(11) - addic 0, 0, -16 # Restart the allocation (4 instructions) - mtlr 0 - # Say we are back into Caml code - li 12, 0 - stw 12, 0(11) # 11 still points to caml_last_return_address - # Deallocate stack frame - addi 1, 1, 0x1C0 - # Return - bctr - -#### Call a C function from Caml - - .globl .caml_c_call -.caml_c_call: - # Save return address in 25 - mflr 25 - # Record lowest stack address and return address - lwz 27, L..caml_bottom_of_stack(2) - lwz 24, L..caml_last_return_address(2) - stw 1, 0(27) - stw 25, 0(24) - # Make the exception handler and alloc ptr available to the C code - lwz 27, L..young_ptr(2) - lwz 26, L..caml_exception_pointer(2) - stw 31, 0(27) - stw 29, 0(26) - # Preserve RTOC and return address in callee-save registers - # The C function will preserve them, and the Caml code does not - # expect them to be preserved - # Return address is in 25, RTOC is in 26, pointer to young_ptr in 27, - # pointer to caml_last_return_address is in 24 - # Call the function (descriptor in 11) - lwz 0, 0(11) - mr 26, 2 - mtlr 0 - lwz 2, 4(11) - lwz 11, 8(11) - blrl - # Restore return address - mtlr 25 - # Restore RTOC - mr 2, 26 - # Reload allocation pointer - lwz 31, 0(27) # 27 still points to young_ptr - # Say we are back into Caml code - li 12, 0 - stw 12, 0(24) # 24 still points to caml_last_return_address - # Return to caller - blr - -#### Raise an exception from C - - .globl .raise_caml_exception -.raise_caml_exception: - # Reload Caml global registers - lwz 4, L..caml_exception_pointer(2) - lwz 5, L..young_ptr(2) - lwz 6, L..young_limit(2) - lwz 1, 0(4) - lwz 31, 0(5) - lwz 30, 0(6) - # Say we are back into Caml code - lwz 4, L..caml_last_return_address(2) - li 0, 0 - stw 0, 0(4) - # Pop trap frame - lwz 0, 0(1) - lwz 29, 4(1) - mtlr 0 - lwz 2, 20(1) - addi 1, 1, 32 - # Branch to handler - blr - -#### Start the Caml program - - .globl .caml_start_program -.caml_start_program: - lwz 11, L..caml_program(2) - -#### Code shared between caml_start_program and callback* - -L..102: - mflr 0 - # Save return address - stw 0, 8(1) - # Save all callee-save registers - stw 13, -76(1) - stw 14, -72(1) - stw 15, -68(1) - stw 16, -64(1) - stw 17, -60(1) - stw 18, -56(1) - stw 19, -52(1) - stw 20, -48(1) - stw 21, -44(1) - stw 22, -40(1) - stw 23, -36(1) - stw 24, -32(1) - stw 25, -28(1) - stw 26, -24(1) - stw 27, -20(1) - stw 28, -16(1) - stw 29, -12(1) - stw 30, -8(1) - stw 31, -4(1) - stfd 14, -224(1) - stfd 15, -216(1) - stfd 16, -208(1) - stfd 17, -200(1) - stfd 18, -192(1) - stfd 19, -184(1) - stfd 20, -176(1) - stfd 21, -168(1) - stfd 22, -160(1) - stfd 23, -152(1) - stfd 24, -144(1) - stfd 25, -136(1) - stfd 26, -128(1) - stfd 27, -120(1) - stfd 28, -112(1) - stfd 29, -104(1) - stfd 30, -96(1) - stfd 31, -88(1) - # Allocate and link stack frame - stwu 1, -288(1) - # Set up a callback link - addi 1, 1, -32 - lwz 9, L..caml_bottom_of_stack(2) - lwz 10, L..caml_last_return_address(2) - lwz 12, L..caml_gc_regs(2) - lwz 9, 0(9) - lwz 10, 0(10) - lwz 12, 0(12) - stw 9, 0(1) - stw 10, 4(1) - stw 12, 8(1) - # Build an exception handler to catch exceptions escaping out of Caml - bl L..103 - b L..104 -L..103: - addi 1, 1, -32 - lwz 9, L..caml_exception_pointer(2) - mflr 0 - lwz 29, 0(9) - stw 0, 0(1) - stw 29, 4(1) - stw 2, 20(1) - mr 29, 1 - # Reload allocation pointers - lwz 9, L..young_ptr(2) - lwz 10, L..young_limit(2) - lwz 31, 0(9) - lwz 30, 0(10) - # Say we are back into Caml code - lwz 9, L..caml_last_return_address(2) - li 0, 0 - stw 0, 0(9) - # Call the Caml code - lwz 0, 0(11) - stw 2, 20(1) - mtlr 0 - lwz 2, 4(11) -L..105: - blrl - lwz 2, 20(1) - # Pop the trap frame, restoring caml_exception_pointer - lwz 9, 4(1) - lwz 10, L..caml_exception_pointer(2) - addi 1, 1, 32 - stw 9, 0(10) - # Pop the callback link, restoring the global variables -L..106: - lwz 7, 0(1) - lwz 8, 4(1) - lwz 9, 8(1) - lwz 10, L..caml_bottom_of_stack(2) - lwz 11, L..caml_last_return_address(2) - lwz 12, L..caml_gc_regs(2) - stw 7, 0(10) - stw 8, 0(11) - stw 9, 0(12) - addi 1, 1, 32 - # Update allocation pointer - lwz 11, L..young_ptr(2) - stw 31, 0(11) - # Deallocate stack frame - addi 1, 1, 288 - # Restore callee-save registers - lwz 13, -76(1) - lwz 14, -72(1) - lwz 15, -68(1) - lwz 16, -64(1) - lwz 17, -60(1) - lwz 18, -56(1) - lwz 19, -52(1) - lwz 20, -48(1) - lwz 21, -44(1) - lwz 22, -40(1) - lwz 23, -36(1) - lwz 24, -32(1) - lwz 25, -28(1) - lwz 26, -24(1) - lwz 27, -20(1) - lwz 28, -16(1) - lwz 29, -12(1) - lwz 30, -8(1) - lwz 31, -4(1) - lfd 14, -224(1) - lfd 15, -216(1) - lfd 16, -208(1) - lfd 17, -200(1) - lfd 18, -192(1) - lfd 19, -184(1) - lfd 20, -176(1) - lfd 21, -168(1) - lfd 22, -160(1) - lfd 23, -152(1) - lfd 24, -144(1) - lfd 25, -136(1) - lfd 26, -128(1) - lfd 27, -120(1) - lfd 28, -112(1) - lfd 29, -104(1) - lfd 30, -96(1) - lfd 31, -88(1) - # Reload return address - lwz 0, 8(1) - mtlr 0 - # Return - blr - # The trap handler: -L..104: - # Update caml_exception_pointer - lwz 9, L..caml_exception_pointer(2) - stw 29, 0(9) - # Encode exception bucket as an exception result and return it - ori 3, 3, 2 - b L..106 - -#### Callback from C to Caml - - .globl .callback_exn -.callback_exn: - # Initial shuffling of arguments - mr 0, 3 # Closure - mr 3, 4 # Argument - mr 4, 0 - lwz 11, 0(4) # Code pointer - b L..102 - - .globl .callback2_exn -.callback2_exn: - mr 0, 3 # Closure - mr 3, 4 # First argument - mr 4, 5 # Second argument - mr 5, 0 - lwz 11, L..caml_apply2(2) - b L..102 - - .globl .callback3_exn -.callback3_exn: - mr 0, 3 # Closure - mr 3, 4 # First argument - mr 4, 5 # Second argument - mr 5, 6 # Third argument - mr 6, 0 - lwz 11, L..caml_apply3(2) - b L..102 - -#### Frame table - - .csect .data[RW] - .globl system__frametable -system__frametable: - .long 1 # one descriptor - .long L..105 + 4 # return address into callback - .short -1 # negative size count => use callback link - .short 0 # no roots here - -#### TOC entries - - .toc -L..young_limit: - .tc young_limit[TC], young_limit -L..young_ptr: - .tc young_ptr[TC], young_ptr -L..caml_bottom_of_stack: - .tc caml_bottom_of_stack[TC], caml_bottom_of_stack -L..caml_last_return_address: - .tc caml_last_return_address[TC], caml_last_return_address -L..caml_gc_regs: - .tc caml_gc_regs[TC], caml_gc_regs -L..caml_exception_pointer: - .tc caml_exception_pointer[TC], caml_exception_pointer -L..gc_entry_regs: - .tc gc_entry_regs[TC], gc_entry_regs -L..gc_entry_float_regs: - .tc gc_entry_float_regs[TC], gc_entry_float_regs -L..caml_program: - .tc caml_program[TC], caml_program -L..caml_apply2: - .tc caml_apply2[TC], caml_apply2 -L..caml_apply3: - .tc caml_apply3[TC], caml_apply3 - -#### Function closures - - .csect caml_call_gc[DS] -caml_call_gc: - .long .caml_call_gc, TOC[tc0], 0 - - .globl caml_c_call - .csect caml_c_call[DS] -caml_c_call: - .long .caml_c_call, TOC[tc0], 0 - - .globl raise_caml_exception - .csect raise_caml_exception[DS] -raise_caml_exception: - .long .raise_caml_exception, TOC[tc0], 0 - - .globl caml_start_program - .csect caml_start_program[DS] -caml_start_program: - .long .caml_start_program, TOC[tc0], 0 - - .globl callback_exn - .csect callback_exn[DS] -callback_exn: - .long .callback_exn, TOC[tc0], 0 - - .globl callback2_exn - .csect callback2_exn[DS] -callback2_exn: - .long .callback2_exn, TOC[tc0], 0 - - .globl callback3_exn - .csect callback3_exn[DS] -callback3_exn: - .long .callback3_exn, TOC[tc0], 0 diff --git a/asmrun/power-elf.S b/asmrun/power-elf.S deleted file mode 100644 index 52f3441cdb..0000000000 --- a/asmrun/power-elf.S +++ /dev/null @@ -1,421 +0,0 @@ -/*********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 1996 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 file ../LICENSE. */ -/* */ -/*********************************************************************/ - -/* $Id$ */ - -#define Addrglobal(reg,glob) \ - addis reg, 0, glob@ha; \ - addi reg, reg, glob@l -#define Loadglobal(reg,glob,tmp) \ - addis tmp, 0, glob@ha; \ - lwz reg, glob@l(tmp) -#define Storeglobal(reg,glob,tmp) \ - addis tmp, 0, glob@ha; \ - stw reg, glob@l(tmp) - - .section ".text" - -/* Invoke the garbage collector. */ - - .globl caml_call_gc - .type caml_call_gc, @function -caml_call_gc: - /* Set up stack frame */ - stwu 1, -0x1A0(1) - /* 0x1A0 = 4*32 (int regs) + 8*32 (float regs) + 32 (space for C call) */ - /* Record return address into Caml code */ - mflr 0 - Storeglobal(0, caml_last_return_address, 11) - /* Record lowest stack address */ - addi 0, 1, 0x1A0 - Storeglobal(0, caml_bottom_of_stack, 11) - /* Record pointer to register array */ - addi 0, 1, 8*32 + 32 - Storeglobal(0, caml_gc_regs, 11) - /* Save current allocation pointer for debugging purposes */ - Storeglobal(31, young_ptr, 11) - /* Save exception pointer (if e.g. a sighandler raises) */ - Storeglobal(29, caml_exception_pointer, 11) - /* Save all registers used by the code generator */ - addi 11, 1, 8*32 + 32 - 4 - stwu 3, 4(11) - stwu 4, 4(11) - stwu 5, 4(11) - stwu 6, 4(11) - stwu 7, 4(11) - stwu 8, 4(11) - stwu 9, 4(11) - stwu 10, 4(11) - stwu 14, 4(11) - stwu 15, 4(11) - stwu 16, 4(11) - stwu 17, 4(11) - stwu 18, 4(11) - stwu 19, 4(11) - stwu 20, 4(11) - stwu 21, 4(11) - stwu 22, 4(11) - stwu 23, 4(11) - stwu 24, 4(11) - stwu 25, 4(11) - stwu 26, 4(11) - stwu 27, 4(11) - stwu 28, 4(11) - addi 11, 1, 32 - 8 - stfdu 1, 8(11) - stfdu 2, 8(11) - stfdu 3, 8(11) - stfdu 4, 8(11) - stfdu 5, 8(11) - stfdu 6, 8(11) - stfdu 7, 8(11) - stfdu 8, 8(11) - stfdu 9, 8(11) - stfdu 10, 8(11) - stfdu 11, 8(11) - stfdu 12, 8(11) - stfdu 13, 8(11) - stfdu 14, 8(11) - stfdu 15, 8(11) - stfdu 16, 8(11) - stfdu 17, 8(11) - stfdu 18, 8(11) - stfdu 19, 8(11) - stfdu 20, 8(11) - stfdu 21, 8(11) - stfdu 22, 8(11) - stfdu 23, 8(11) - stfdu 24, 8(11) - stfdu 25, 8(11) - stfdu 26, 8(11) - stfdu 27, 8(11) - stfdu 28, 8(11) - stfdu 29, 8(11) - stfdu 30, 8(11) - stfdu 31, 8(11) - /* Call the GC */ - bl garbage_collection - /* Reload new allocation pointer and allocation limit */ - Loadglobal(31, young_ptr, 11) - Loadglobal(30, young_limit, 11) - /* Restore all regs used by the code generator */ - addi 11, 1, 8*32 + 32 - 4 - lwzu 3, 4(11) - lwzu 4, 4(11) - lwzu 5, 4(11) - lwzu 6, 4(11) - lwzu 7, 4(11) - lwzu 8, 4(11) - lwzu 9, 4(11) - lwzu 10, 4(11) - lwzu 14, 4(11) - lwzu 15, 4(11) - lwzu 16, 4(11) - lwzu 17, 4(11) - lwzu 18, 4(11) - lwzu 19, 4(11) - lwzu 20, 4(11) - lwzu 21, 4(11) - lwzu 22, 4(11) - lwzu 23, 4(11) - lwzu 24, 4(11) - lwzu 25, 4(11) - lwzu 26, 4(11) - lwzu 27, 4(11) - lwzu 28, 4(11) - addi 11, 1, 32 - 8 - lfdu 1, 8(11) - lfdu 2, 8(11) - lfdu 3, 8(11) - lfdu 4, 8(11) - lfdu 5, 8(11) - lfdu 6, 8(11) - lfdu 7, 8(11) - lfdu 8, 8(11) - lfdu 9, 8(11) - lfdu 10, 8(11) - lfdu 11, 8(11) - lfdu 12, 8(11) - lfdu 13, 8(11) - lfdu 14, 8(11) - lfdu 15, 8(11) - lfdu 16, 8(11) - lfdu 17, 8(11) - lfdu 18, 8(11) - lfdu 19, 8(11) - lfdu 20, 8(11) - lfdu 21, 8(11) - lfdu 22, 8(11) - lfdu 23, 8(11) - lfdu 24, 8(11) - lfdu 25, 8(11) - lfdu 26, 8(11) - lfdu 27, 8(11) - lfdu 28, 8(11) - lfdu 29, 8(11) - lfdu 30, 8(11) - lfdu 31, 8(11) - /* Return to caller, restarting the allocation */ - Loadglobal(0, caml_last_return_address, 11) - addic 0, 0, -16 /* Restart the allocation (4 instructions) */ - mtlr 0 - /* Say we are back into Caml code */ - li 12, 0 - Storeglobal(12, caml_last_return_address, 11) - /* Deallocate stack frame */ - addi 1, 1, 0x1A0 - /* Return */ - blr - -/* Call a C function from Caml */ - - .globl caml_c_call - .type caml_c_call, @function -caml_c_call: - /* Save return address */ - mflr 25 - /* Get ready to call C function (address in 11) */ - mtlr 11 - /* Record lowest stack address and return address */ - Storeglobal(1, caml_bottom_of_stack, 12) - Storeglobal(25, caml_last_return_address, 12) - /* Make the exception handler and alloc ptr available to the C code */ - Storeglobal(31, young_ptr, 11) - Storeglobal(29, caml_exception_pointer, 11) - /* Call the function (address in link register) */ - blrl - /* Restore return address (in 25, preserved by the C function) */ - mtlr 25 - /* Reload allocation pointer and allocation limit*/ - Loadglobal(31, young_ptr, 11) - Loadglobal(30, young_limit, 11) - /* Say we are back into Caml code */ - li 12, 0 - Storeglobal(12, caml_last_return_address, 11) - /* Return to caller */ - blr - -/* Raise an exception from C */ - - .globl raise_caml_exception - .type raise_caml_exception, @function -raise_caml_exception: - /* Reload Caml global registers */ - Loadglobal(1, caml_exception_pointer, 11) - Loadglobal(31, young_ptr, 11) - Loadglobal(30, young_limit, 11) - /* Say we are back into Caml code */ - li 0, 0 - Storeglobal(0, caml_last_return_address, 11) - /* Pop trap frame */ - lwz 0, 0(1) - lwz 29, 4(1) - mtlr 0 - addi 1, 1, 16 - /* Branch to handler */ - blr - -/* Start the Caml program */ - - .globl caml_start_program - .type caml_start_program, @function -caml_start_program: - Addrglobal(12, caml_program) - -/* Code shared between caml_start_program and callback */ -.L102: - /* Allocate and link stack frame */ - stwu 1, -256(1) - /* Save return address */ - mflr 0 - stw 0, 256+4(1) - /* Save all callee-save registers */ - /* GPR 14 at sp+16 ... GPR 31 at sp+84 - FPR 14 at sp+92 ... FPR 31 at sp+228 */ - addi 11, 1, 16-4 - stwu 14, 4(11) - stwu 15, 4(11) - stwu 16, 4(11) - stwu 17, 4(11) - stwu 18, 4(11) - stwu 19, 4(11) - stwu 20, 4(11) - stwu 21, 4(11) - stwu 22, 4(11) - stwu 23, 4(11) - stwu 24, 4(11) - stwu 25, 4(11) - stwu 26, 4(11) - stwu 27, 4(11) - stwu 28, 4(11) - stwu 29, 4(11) - stwu 30, 4(11) - stwu 31, 4(11) - stfdu 14, 8(11) - stfdu 15, 8(11) - stfdu 16, 8(11) - stfdu 17, 8(11) - stfdu 18, 8(11) - stfdu 19, 8(11) - stfdu 20, 8(11) - stfdu 21, 8(11) - stfdu 22, 8(11) - stfdu 23, 8(11) - stfdu 24, 8(11) - stfdu 25, 8(11) - stfdu 26, 8(11) - stfdu 27, 8(11) - stfdu 28, 8(11) - stfdu 29, 8(11) - stfdu 30, 8(11) - stfdu 31, 8(11) - /* Set up a callback link */ - addi 1, 1, -16 - Loadglobal(9, caml_bottom_of_stack, 11) - Loadglobal(10, caml_last_return_address, 11) - Loadglobal(11, caml_gc_regs, 11) - stw 9, 0(1) - stw 10, 4(1) - stw 11, 8(1) - /* Build an exception handler to catch exceptions escaping out of Caml */ - bl .L103 - b .L104 -.L103: - addi 1, 1, -16 - mflr 0 - stw 0, 0(1) - Loadglobal(11, caml_exception_pointer, 11) - stw 11, 4(1) - mr 29, 1 - /* Reload allocation pointers */ - Loadglobal(31, young_ptr, 11) - Loadglobal(30, young_limit, 11) - /* Say we are back into Caml code */ - li 0, 0 - Storeglobal(0, caml_last_return_address, 11) - /* Call the Caml code */ - mtlr 12 -.L105: - blrl - /* Pop the trap frame, restoring caml_exception_pointer */ - lwz 9, 4(1) - Storeglobal(9, caml_exception_pointer, 11) - addi 1, 1, 16 - /* Pop the callback link, restoring the global variables */ -.L106: - lwz 9, 0(1) - lwz 10, 4(1) - lwz 11, 8(1) - Storeglobal(9, caml_bottom_of_stack, 12) - Storeglobal(10, caml_last_return_address, 12) - Storeglobal(11, caml_gc_regs, 12) - addi 1, 1, 16 - /* Update allocation pointer */ - Storeglobal(31, young_ptr, 11) - /* Restore callee-save registers */ - addi 11, 1, 16-4 - lwzu 14, 4(11) - lwzu 15, 4(11) - lwzu 16, 4(11) - lwzu 17, 4(11) - lwzu 18, 4(11) - lwzu 19, 4(11) - lwzu 20, 4(11) - lwzu 21, 4(11) - lwzu 22, 4(11) - lwzu 23, 4(11) - lwzu 24, 4(11) - lwzu 25, 4(11) - lwzu 26, 4(11) - lwzu 27, 4(11) - lwzu 28, 4(11) - lwzu 29, 4(11) - lwzu 30, 4(11) - lwzu 31, 4(11) - lfdu 14, 8(11) - lfdu 15, 8(11) - lfdu 16, 8(11) - lfdu 17, 8(11) - lfdu 18, 8(11) - lfdu 19, 8(11) - lfdu 20, 8(11) - lfdu 21, 8(11) - lfdu 22, 8(11) - lfdu 23, 8(11) - lfdu 24, 8(11) - lfdu 25, 8(11) - lfdu 26, 8(11) - lfdu 27, 8(11) - lfdu 28, 8(11) - lfdu 29, 8(11) - lfdu 30, 8(11) - lfdu 31, 8(11) - /* Reload return address */ - lwz 0, 256+4(1) - mtlr 0 - /* Return */ - addi 1, 1, 256 - blr - - /* The trap handler: */ -.L104: - /* Update caml_exception_pointer */ - Storeglobal(29, caml_exception_pointer, 11) - /* Encode exception bucket as an exception result and return it */ - ori 3, 3, 2 - b .L106 - -/* Callback from C to Caml */ - - .globl callback_exn - .type callback_exn, @function -callback_exn: - /* Initial shuffling of arguments */ - mr 0, 3 /* Closure */ - mr 3, 4 /* Argument */ - mr 4, 0 - lwz 12, 0(4) /* Code pointer */ - b .L102 - - .globl callback2_exn - .type callback2_exn, @function -callback2_exn: - mr 0, 3 /* Closure */ - mr 3, 4 /* First argument */ - mr 4, 5 /* Second argument */ - mr 5, 0 - Addrglobal(12, caml_apply2) - b .L102 - - .globl callback3_exn - .type callback3_exn, @function -callback3_exn: - mr 0, 3 /* Closure */ - mr 3, 4 /* First argument */ - mr 4, 5 /* Second argument */ - mr 5, 6 /* Third argument */ - mr 6, 0 - Addrglobal(12, caml_apply3) - b .L102 - -/* Frame table */ - - .section ".data" - .globl system__frametable - .type system__frametable, @object -system__frametable: - .long 1 /* one descriptor */ - .long .L105 + 4 /* return address into callback */ - .short -1 /* negative size count => use callback link */ - .short 0 /* no roots here */ - diff --git a/asmrun/power-rhapsody.S b/asmrun/power-rhapsody.S deleted file mode 100644 index 0d56983df5..0000000000 --- a/asmrun/power-rhapsody.S +++ /dev/null @@ -1,416 +0,0 @@ -/*********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 1996 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 file ../LICENSE. */ -/* */ -/*********************************************************************/ - -/* $Id$ */ - -.macro Addrglobal /* reg, glob */ - addis $0, 0, ha16($1) - addi $0, $0, lo16($1) -.endmacro -.macro Loadglobal /* reg,glob,tmp */ - addis $2, 0, ha16($1) - lwz $0, lo16($1)($2) -.endmacro -.macro Storeglobal /* reg,glob,tmp */ - addis $2, 0, ha16($1) - stw $0, lo16($1)($2) -.endmacro - - .text - -/* Invoke the garbage collector. */ - - .globl _caml_call_gc -_caml_call_gc: - /* Set up stack frame */ - stwu r1, -0x1A0(r1) - /* 0x1A0 = 4*32 (int regs) + 8*32 (float regs) + 32 (space for C call) */ - /* Record return address into Caml code */ - mflr r0 - Storeglobal r0, _caml_last_return_address, r11 - /* Record lowest stack address */ - addi r0, r1, 0x1A0 - Storeglobal r0, _caml_bottom_of_stack, r11 - /* Record pointer to register array */ - addi r0, r1, 8*32 + 32 - Storeglobal r0, _caml_gc_regs, r11 - /* Save current allocation pointer for debugging purposes */ - Storeglobal r31, _young_ptr, r11 - /* Save exception pointer (if e.g. a sighandler raises) */ - Storeglobal r29, _caml_exception_pointer, r11 - /* Save all registers used by the code generator */ - addi r11, r1, 8*32 + 32 - 4 - stwu r3, 4(r11) - stwu r4, 4(r11) - stwu r5, 4(r11) - stwu r6, 4(r11) - stwu r7, 4(r11) - stwu r8, 4(r11) - stwu r9, 4(r11) - stwu r10, 4(r11) - stwu r14, 4(r11) - stwu r15, 4(r11) - stwu r16, 4(r11) - stwu r17, 4(r11) - stwu r18, 4(r11) - stwu r19, 4(r11) - stwu r20, 4(r11) - stwu r21, 4(r11) - stwu r22, 4(r11) - stwu r23, 4(r11) - stwu r24, 4(r11) - stwu r25, 4(r11) - stwu r26, 4(r11) - stwu r27, 4(r11) - stwu r28, 4(r11) - addi r11, r1, 32 - 8 - stfdu f1, 8(r11) - stfdu f2, 8(r11) - stfdu f3, 8(r11) - stfdu f4, 8(r11) - stfdu f5, 8(r11) - stfdu f6, 8(r11) - stfdu f7, 8(r11) - stfdu f8, 8(r11) - stfdu f9, 8(r11) - stfdu f10, 8(r11) - stfdu f11, 8(r11) - stfdu f12, 8(r11) - stfdu f13, 8(r11) - stfdu f14, 8(r11) - stfdu f15, 8(r11) - stfdu f16, 8(r11) - stfdu f17, 8(r11) - stfdu f18, 8(r11) - stfdu f19, 8(r11) - stfdu f20, 8(r11) - stfdu f21, 8(r11) - stfdu f22, 8(r11) - stfdu f23, 8(r11) - stfdu f24, 8(r11) - stfdu f25, 8(r11) - stfdu f26, 8(r11) - stfdu f27, 8(r11) - stfdu f28, 8(r11) - stfdu f29, 8(r11) - stfdu f30, 8(r11) - stfdu f31, 8(r11) - /* Call the GC */ - bl _garbage_collection - /* Reload new allocation pointer and allocation limit */ - Loadglobal r31, _young_ptr, r11 - Loadglobal r30, _young_limit, r11 - /* Restore all regs used by the code generator */ - addi r11, r1, 8*32 + 32 - 4 - lwzu r3, 4(r11) - lwzu r4, 4(r11) - lwzu r5, 4(r11) - lwzu r6, 4(r11) - lwzu r7, 4(r11) - lwzu r8, 4(r11) - lwzu r9, 4(r11) - lwzu r10, 4(r11) - lwzu r14, 4(r11) - lwzu r15, 4(r11) - lwzu r16, 4(r11) - lwzu r17, 4(r11) - lwzu r18, 4(r11) - lwzu r19, 4(r11) - lwzu r20, 4(r11) - lwzu r21, 4(r11) - lwzu r22, 4(r11) - lwzu r23, 4(r11) - lwzu r24, 4(r11) - lwzu r25, 4(r11) - lwzu r26, 4(r11) - lwzu r27, 4(r11) - lwzu r28, 4(r11) - addi r11, r1, 32 - 8 - lfdu f1, 8(r11) - lfdu f2, 8(r11) - lfdu f3, 8(r11) - lfdu f4, 8(r11) - lfdu f5, 8(r11) - lfdu f6, 8(r11) - lfdu f7, 8(r11) - lfdu f8, 8(r11) - lfdu f9, 8(r11) - lfdu f10, 8(r11) - lfdu f11, 8(r11) - lfdu f12, 8(r11) - lfdu f13, 8(r11) - lfdu f14, 8(r11) - lfdu f15, 8(r11) - lfdu f16, 8(r11) - lfdu f17, 8(r11) - lfdu f18, 8(r11) - lfdu f19, 8(r11) - lfdu f20, 8(r11) - lfdu f21, 8(r11) - lfdu f22, 8(r11) - lfdu f23, 8(r11) - lfdu f24, 8(r11) - lfdu f25, 8(r11) - lfdu f26, 8(r11) - lfdu f27, 8(r11) - lfdu f28, 8(r11) - lfdu f29, 8(r11) - lfdu f30, 8(r11) - lfdu f31, 8(r11) - /* Return to caller, restarting the allocation */ - Loadglobal r0, _caml_last_return_address, r11 - addic r0, r0, -16 /* Restart the allocation (4 instructions) */ - mtlr r0 - /* Say we are back into Caml code */ - li r12, 0 - Storeglobal r12, _caml_last_return_address, r11 - /* Deallocate stack frame */ - addi r1, r1, 0x1A0 - /* Return */ - blr - -/* Call a C function from Caml */ - - .globl _caml_c_call -_caml_c_call: - /* Save return address */ - mflr r25 - /* Get ready to call C function (address in 11) */ - mtlr r11 - /* Record lowest stack address and return address */ - Storeglobal r1, _caml_bottom_of_stack, r12 - Storeglobal r25, _caml_last_return_address, r12 - /* Make the exception handler and alloc ptr available to the C code */ - Storeglobal r31, _young_ptr, r11 - Storeglobal r29, _caml_exception_pointer, r11 - /* Call the function (address in link register) */ - blrl - /* Restore return address (in 25, preserved by the C function) */ - mtlr r25 - /* Reload allocation pointer and allocation limit*/ - Loadglobal r31, _young_ptr, r11 - Loadglobal r30, _young_limit, r11 - /* Say we are back into Caml code */ - li r12, 0 - Storeglobal r12, _caml_last_return_address, r11 - /* Return to caller */ - blr - -/* Raise an exception from C */ - - .globl _raise_caml_exception -_raise_caml_exception: - /* Reload Caml global registers */ - Loadglobal r1, _caml_exception_pointer, r11 - Loadglobal r31, _young_ptr, r11 - Loadglobal r30, _young_limit, r11 - /* Say we are back into Caml code */ - li r0, 0 - Storeglobal r0, _caml_last_return_address, r11 - /* Pop trap frame */ - lwz r0, 0(r1) - lwz r29, 4(r1) - mtlr r0 - addi r1, r1, 16 - /* Branch to handler */ - blr - -/* Start the Caml program */ - - .globl _caml_start_program -_caml_start_program: - Addrglobal r12, _caml_program - -/* Code shared between caml_start_program and callback */ -L102: - /* Allocate and link stack frame */ - stwu r1, -256(r1) - /* Save return address */ - mflr r0 - stw r0, 256+4(r1) - /* Save all callee-save registers */ - /* GPR 14 at sp+16 ... GPR 31 at sp+84 - FPR 14 at sp+92 ... FPR 31 at sp+228 */ - addi r11, r1, 16-4 - stwu r14, 4(r11) - stwu r15, 4(r11) - stwu r16, 4(r11) - stwu r17, 4(r11) - stwu r18, 4(r11) - stwu r19, 4(r11) - stwu r20, 4(r11) - stwu r21, 4(r11) - stwu r22, 4(r11) - stwu r23, 4(r11) - stwu r24, 4(r11) - stwu r25, 4(r11) - stwu r26, 4(r11) - stwu r27, 4(r11) - stwu r28, 4(r11) - stwu r29, 4(r11) - stwu r30, 4(r11) - stwu r31, 4(r11) - stfdu f14, 8(r11) - stfdu f15, 8(r11) - stfdu f16, 8(r11) - stfdu f17, 8(r11) - stfdu f18, 8(r11) - stfdu f19, 8(r11) - stfdu f20, 8(r11) - stfdu f21, 8(r11) - stfdu f22, 8(r11) - stfdu f23, 8(r11) - stfdu f24, 8(r11) - stfdu f25, 8(r11) - stfdu f26, 8(r11) - stfdu f27, 8(r11) - stfdu f28, 8(r11) - stfdu f29, 8(r11) - stfdu f30, 8(r11) - stfdu f31, 8(r11) - /* Set up a callback link */ - addi r1, r1, -16 - Loadglobal r9, _caml_bottom_of_stack, r11 - Loadglobal r10, _caml_last_return_address, r11 - Loadglobal r11, _caml_gc_regs, r11 - stw r9, 0(r1) - stw r10, 4(r1) - stw r11, 8(r1) - /* Build an exception handler to catch exceptions escaping out of Caml */ - bl L103 - b L104 -L103: - addi r1, r1, -16 - mflr r0 - stw r0, 0(r1) - Loadglobal r11, _caml_exception_pointer, r11 - stw r11, 4(r1) - mr r29, r1 - /* Reload allocation pointers */ - Loadglobal r31, _young_ptr, r11 - Loadglobal r30, _young_limit, r11 - /* Say we are back into Caml code */ - li r0, 0 - Storeglobal r0, _caml_last_return_address, r11 - /* Call the Caml code */ - mtlr r12 -L105: - blrl - /* Pop the trap frame, restoring caml_exception_pointer */ - lwz r9, 4(r1) - Storeglobal r9, _caml_exception_pointer, r11 - addi r1, r1, 16 - /* Pop the callback link, restoring the global variables */ -L106: - lwz r9, 0(r1) - lwz r10, 4(r1) - lwz r11, 8(r1) - Storeglobal r9, _caml_bottom_of_stack, r12 - Storeglobal r10, _caml_last_return_address, r12 - Storeglobal r11, _caml_gc_regs, r12 - addi r1, r1, 16 - /* Update allocation pointer */ - Storeglobal r31, _young_ptr, r11 - /* Restore callee-save registers */ - addi r11, r1, 16-4 - lwzu r14, 4(r11) - lwzu r15, 4(r11) - lwzu r16, 4(r11) - lwzu r17, 4(r11) - lwzu r18, 4(r11) - lwzu r19, 4(r11) - lwzu r20, 4(r11) - lwzu r21, 4(r11) - lwzu r22, 4(r11) - lwzu r23, 4(r11) - lwzu r24, 4(r11) - lwzu r25, 4(r11) - lwzu r26, 4(r11) - lwzu r27, 4(r11) - lwzu r28, 4(r11) - lwzu r29, 4(r11) - lwzu r30, 4(r11) - lwzu r31, 4(r11) - lfdu f14, 8(r11) - lfdu f15, 8(r11) - lfdu f16, 8(r11) - lfdu f17, 8(r11) - lfdu f18, 8(r11) - lfdu f19, 8(r11) - lfdu f20, 8(r11) - lfdu f21, 8(r11) - lfdu f22, 8(r11) - lfdu f23, 8(r11) - lfdu f24, 8(r11) - lfdu f25, 8(r11) - lfdu f26, 8(r11) - lfdu f27, 8(r11) - lfdu f28, 8(r11) - lfdu f29, 8(r11) - lfdu f30, 8(r11) - lfdu f31, 8(r11) - /* Reload return address */ - lwz r0, 256+4(r1) - mtlr r0 - /* Return */ - addi r1, r1, 256 - blr - - /* The trap handler: */ -L104: - /* Update caml_exception_pointer */ - Storeglobal r29, _caml_exception_pointer, r11 - /* Encode exception bucket as an exception result and return it */ - ori r3, r3, 2 - b L106 - -/* Callback from C to Caml */ - - .globl _callback_exn -_callback_exn: - /* Initial shuffling of arguments */ - mr r0, r3 /* Closure */ - mr r3, r4 /* Argument */ - mr r4, r0 - lwz r12, 0(r4) /* Code pointer */ - b L102 - - .globl _callback2_exn -_callback2_exn: - mr r0, r3 /* Closure */ - mr r3, r4 /* First argument */ - mr r4, r5 /* Second argument */ - mr r5, r0 - Addrglobal r12, _caml_apply2 - b L102 - - .globl _callback3_exn -_callback3_exn: - mr r0, r3 /* Closure */ - mr r3, r4 /* First argument */ - mr r4, r5 /* Second argument */ - mr r5, r6 /* Third argument */ - mr r6, r0 - Addrglobal r12, _caml_apply3 - b L102 - -/* Frame table */ - - .const - .globl _system__frametable -_system__frametable: - .long 1 /* one descriptor */ - .long L105 + 4 /* return address into callback */ - .short -1 /* negative size count => use callback link */ - .short 0 /* no roots here */ - diff --git a/asmrun/roots.c b/asmrun/roots.c deleted file mode 100644 index f56ebf150b..0000000000 --- a/asmrun/roots.c +++ /dev/null @@ -1,297 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 1996 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 file ../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -/* To walk the memory roots for garbage collection */ - -#include "finalise.h" -#include "globroots.h" -#include "memory.h" -#include "major_gc.h" -#include "minor_gc.h" -#include "misc.h" -#include "mlvalues.h" -#include "stack.h" -#include "roots.h" - -/* Roots registered from C functions */ - -struct caml__roots_block *local_roots = NULL; - -void (*scan_roots_hook) (scanning_action) = NULL; - -/* The hashtable of frame descriptors */ - -typedef struct { - unsigned long retaddr; - short frame_size; - short num_live; - short live_ofs[1]; -} frame_descr; - -static frame_descr ** frame_descriptors = NULL; -static int frame_descriptors_mask; - -#define Hash_retaddr(addr) \ - (((unsigned long)(addr) >> 3) & frame_descriptors_mask) - -static void init_frame_descriptors(void) -{ - long num_descr, tblsize, i, j, len; - long * tbl; - frame_descr * d; - unsigned long h; - - /* Count the frame descriptors */ - num_descr = 0; - for (i = 0; caml_frametable[i] != 0; i++) - num_descr += *(caml_frametable[i]); - - /* The size of the hashtable is a power of 2 greater or equal to - 2 times the number of descriptors */ - tblsize = 4; - while (tblsize < 2 * num_descr) tblsize *= 2; - - /* Allocate the hash table */ - frame_descriptors = - (frame_descr **) stat_alloc(tblsize * sizeof(frame_descr *)); - for (i = 0; i < tblsize; i++) frame_descriptors[i] = NULL; - frame_descriptors_mask = tblsize - 1; - - /* Fill the hash table */ - for (i = 0; caml_frametable[i] != 0; i++) { - tbl = caml_frametable[i]; - len = *tbl; - d = (frame_descr *)(tbl + 1); - for (j = 0; j < len; j++) { - h = Hash_retaddr(d->retaddr); - while (frame_descriptors[h] != NULL) { - h = (h+1) & frame_descriptors_mask; - } - frame_descriptors[h] = d; - d = (frame_descr *) - (((unsigned long)d + - sizeof(char *) + sizeof(short) + sizeof(short) + - sizeof(short) * d->num_live + sizeof(frame_descr *) - 1) - & -sizeof(frame_descr *)); - } - } -} - -/* Communication with [caml_start_program] and [caml_call_gc]. */ - -char * caml_bottom_of_stack = NULL; /* no stack initially */ -unsigned long caml_last_return_address = 1; /* not in Caml code initially */ -value * caml_gc_regs; -long caml_globals_inited = 0; -static long caml_globals_scanned = 0; - -/* Call [oldify_one] on (at least) all the roots that point to the minor - heap. */ -void oldify_local_roots (void) -{ - char * sp; - unsigned long retaddr; - value * regs; - frame_descr * d; - unsigned long h; - int i, j, n, ofs; - short * p; - value glob; - value * root; - struct global_root * gr; - struct caml__roots_block *lr; - - /* The global roots */ - for (i = caml_globals_scanned; - i <= caml_globals_inited && caml_globals[i] != 0; - i++) { - glob = caml_globals[i]; - for (j = 0; j < Wosize_val(glob); j++){ - Oldify (&Field (glob, j)); - } - } - caml_globals_scanned = caml_globals_inited; - - /* The stack and local roots */ - if (frame_descriptors == NULL) init_frame_descriptors(); - sp = caml_bottom_of_stack; - retaddr = caml_last_return_address; - regs = caml_gc_regs; - if (sp != NULL) { - while (1) { - /* Find the descriptor corresponding to the return address */ - h = Hash_retaddr(retaddr); - while(1) { - d = frame_descriptors[h]; - if (d->retaddr == retaddr) break; - h = (h+1) & frame_descriptors_mask; - } - if (d->frame_size >= 0) { - /* Scan the roots in this frame */ - for (p = d->live_ofs, n = d->num_live; n > 0; n--, p++) { - ofs = *p; - if (ofs & 1) { - root = regs + (ofs >> 1); - } else { - root = (value *)(sp + ofs); - } - Oldify (root); - } - /* Move to next frame */ -#ifndef Stack_grows_upwards - sp += d->frame_size; -#else - sp -= d->frame_size; -#endif - retaddr = Saved_return_address(sp); -#ifdef Already_scanned - /* Stop here if the frame has been scanned during earlier GCs */ - if (Already_scanned(sp, retaddr)) break; - /* Mark frame as already scanned */ - Mark_scanned(sp, retaddr); -#endif - } else { - /* This marks the top of a stack chunk for an ML callback. - Skip C portion of stack and continue with next ML stack chunk. */ - struct caml_context * next_context = Callback_link(sp); - sp = next_context->bottom_of_stack; - retaddr = next_context->last_retaddr; - regs = next_context->gc_regs; - /* A null sp means no more ML stack chunks; stop here. */ - if (sp == NULL) break; - } - } - } - /* Local C roots */ - for (lr = local_roots; lr != NULL; lr = lr->next) { - for (i = 0; i < lr->ntables; i++){ - for (j = 0; j < lr->nitems; j++){ - root = &(lr->tables[i][j]); - Oldify (root); - } - } - } - /* Global C roots */ - for (gr = caml_global_roots.forward[0]; gr != NULL; gr = gr->forward[0]) { - Oldify (gr->root); - } - /* Finalised values */ - final_do_young_roots (&oldify_one); - /* Hook */ - if (scan_roots_hook != NULL) (*scan_roots_hook)(oldify_one); -} - -/* Call [darken] on all roots */ - -void darken_all_roots (void) -{ - do_roots (darken); -} - -void do_roots (scanning_action f) -{ - int i, j; - value glob; - struct global_root * gr; - - /* The global roots */ - for (i = 0; caml_globals[i] != 0; i++) { - glob = caml_globals[i]; - for (j = 0; j < Wosize_val(glob); j++) - f (Field (glob, j), &Field (glob, j)); - } - /* The stack and local roots */ - if (frame_descriptors == NULL) init_frame_descriptors(); - do_local_roots(f, caml_bottom_of_stack, caml_last_return_address, - caml_gc_regs, local_roots); - /* Global C roots */ - for (gr = caml_global_roots.forward[0]; gr != NULL; gr = gr->forward[0]) { - f(*(gr->root), gr->root); - } - /* Finalised values */ - final_do_strong_roots (f); - /* Hook */ - if (scan_roots_hook != NULL) (*scan_roots_hook)(f); -} - -void do_local_roots(scanning_action f, char * bottom_of_stack, - unsigned long last_retaddr, value * gc_regs, - struct caml__roots_block * local_roots) -{ - char * sp; - unsigned long retaddr; - value * regs; - frame_descr * d; - unsigned long h; - int i, j, n, ofs; - short * p; - value * root; - struct caml__roots_block *lr; - - sp = bottom_of_stack; - retaddr = last_retaddr; - regs = gc_regs; - if (sp != NULL) { - while (1) { - /* Find the descriptor corresponding to the return address */ - h = Hash_retaddr(retaddr); - while(1) { - d = frame_descriptors[h]; - if (d->retaddr == retaddr) break; - h = (h+1) & frame_descriptors_mask; - } - if (d->frame_size >= 0) { - /* Scan the roots in this frame */ - for (p = d->live_ofs, n = d->num_live; n > 0; n--, p++) { - ofs = *p; - if (ofs & 1) { - root = regs + (ofs >> 1); - } else { - root = (value *)(sp + ofs); - } - f (*root, root); - } - /* Move to next frame */ -#ifndef Stack_grows_upwards - sp += d->frame_size; -#else - sp -= d->frame_size; -#endif - retaddr = Saved_return_address(sp); -#ifdef Mask_already_scanned - retaddr = Mask_already_scanned(retaddr); -#endif - } else { - /* This marks the top of a stack chunk for an ML callback. - Skip C portion of stack and continue with next ML stack chunk. */ - struct caml_context * next_context = Callback_link(sp); - sp = next_context->bottom_of_stack; - retaddr = next_context->last_retaddr; - regs = next_context->gc_regs; - /* A null sp means no more ML stack chunks; stop here. */ - if (sp == NULL) break; - } - } - } - /* Local C roots */ - for (lr = local_roots; lr != NULL; lr = lr->next) { - for (i = 0; i < lr->ntables; i++){ - for (j = 0; j < lr->nitems; j++){ - root = &(lr->tables[i][j]); - f (*root, root); - } - } - } -} diff --git a/asmrun/signals.c b/asmrun/signals.c deleted file mode 100644 index c05e9c73f0..0000000000 --- a/asmrun/signals.c +++ /dev/null @@ -1,677 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 1996 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 file ../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include -#include -#if defined(TARGET_sparc) && defined(SYS_solaris) -#include -#endif -#include "alloc.h" -#include "callback.h" -#include "memory.h" -#include "minor_gc.h" -#include "misc.h" -#include "mlvalues.h" -#include "fail.h" -#include "signals.h" -#include "stack.h" -#include "sys.h" -#ifdef HAS_STACK_OVERFLOW_DETECTION -#include -#include -#endif - -extern char * code_area_start, * code_area_end; - -#define In_code_area(pc) \ - ((char *)(pc) >= code_area_start && (char *)(pc) <= code_area_end) - -#ifdef _WIN32 -typedef void (*sighandler)(int sig); -extern sighandler win32_signal(int sig, sighandler action); -#define signal(sig,act) win32_signal(sig,act) -#endif - -#if defined(TARGET_power) && defined(SYS_rhapsody) - - #include - - #define STRUCT_SIGCONTEXT void - #define CONTEXT_GPR(ctx, regno) (*context_gpr_p ((ctx), (regno))) - #define CONTEXT_PC(ctx) CONTEXT_GPR ((ctx), -2) - static int ctx_version = 0; - static void init_ctx (void) - { - struct utsname name; - if (uname (&name) == 0){ - if (name.release[1] == '.' && name.release[0] <= '5'){ - ctx_version = 1; - }else{ - ctx_version = 2; - } - }else{ - fatal_error ("cannot determine SIGCONTEXT format"); - } - } - - #ifdef DARWIN_VERSION_6 - #include - static unsigned long *context_gpr_p (void *ctx, int regno) - { - unsigned long *regs; - if (ctx_version == 0) init_ctx (); - if (ctx_version == 1){ - /* old-style context (10.0 and 10.1) */ - regs = (unsigned long *)(((struct sigcontext *)ctx)->sc_regs); - }else{ - Assert (ctx_version == 2); - /* new-style context (10.2) */ - regs = (unsigned long *)&(((struct ucontext *)ctx)->uc_mcontext->ss); - } - return &(regs[2 + regno]); - } - #else - #define SA_SIGINFO 0x0040 - struct ucontext { - int uc_onstack; - sigset_t uc_sigmask; - struct sigaltstack uc_stack; - struct ucontext *uc_link; - size_t uc_mcsize; - unsigned long *uc_mcontext; - }; - static unsigned long *context_gpr_p (void *ctx, int regno) - { - unsigned long *regs; - if (ctx_version == 0) init_ctx (); - if (ctx_version == 1){ - /* old-style context (10.0 and 10.1) */ - regs = (unsigned long *)(((struct sigcontext *)ctx)->sc_regs); - }else{ - Assert (ctx_version == 2); - /* new-style context (10.2) */ - regs = (unsigned long *)((struct ucontext *)ctx)->uc_mcontext + 8; - } - return &(regs[2 + regno]); - } - #endif -#endif - -#if defined(TARGET_power) && defined(SYS_aix) -#ifdef _AIXVERSION_430 -#define STRUCT_SIGCONTEXT struct __sigcontext -#define CONTEXT_GPR(ctx, regno) \ - ((ctx)->__sc_jmpbuf.__jmp_context.__gpr[(regno)]) -#else -#define STRUCT_SIGCONTEXT struct sigcontext -#define CONTEXT_GPR(ctx, regno) \ - ((ctx)->sc_jmpbuf.jmp_context.gpr[(regno)]) -#endif -#endif - -volatile int async_signal_mode = 0; -volatile int pending_signal = 0; -volatile int force_major_slice = 0; -value signal_handlers = 0; -void (*enter_blocking_section_hook)() = NULL; -void (*leave_blocking_section_hook)() = NULL; - -static int rev_convert_signal_number(int signo); - -/* Execute a signal handler immediately. */ - -void execute_signal(int signal_number, int in_signal_handler) -{ - value res; -#ifdef POSIX_SIGNALS - sigset_t sigs; - /* Block the signal before executing the handler, and record in sigs - the original signal mask */ - sigemptyset(&sigs); - sigaddset(&sigs, signal_number); - sigprocmask(SIG_BLOCK, &sigs, &sigs); -#endif - res = callback_exn(Field(signal_handlers, signal_number), - Val_int(rev_convert_signal_number(signal_number))); -#ifdef POSIX_SIGNALS - if (! in_signal_handler) { - /* Restore the original signal mask */ - sigprocmask(SIG_SETMASK, &sigs, NULL); - } else if (Is_exception_result(res)) { - /* Restore the original signal mask and unblock the signal itself */ - sigdelset(&sigs, signal_number); - sigprocmask(SIG_SETMASK, &sigs, NULL); - } -#endif - if (Is_exception_result(res)) mlraise(Extract_exception(res)); -} - -/* This routine is the common entry point for garbage collection - and signal handling. It can trigger a callback to Caml code. - With system threads, this callback can cause a context switch. - Hence [garbage_collection] must not be called from regular C code - (e.g. the [alloc] function) because the context of the call - (e.g. [intern_val]) may not allow context switching. - Only generated assembly code can call [garbage_collection], - via the caml_call_gc assembly stubs. */ - -void garbage_collection(void) -{ - int sig; - - if (young_ptr < young_start || force_major_slice) minor_collection(); - /* If a signal arrives between the following two instructions, - it will be lost. */ - sig = pending_signal; - pending_signal = 0; - young_limit = young_start; - if (sig) execute_signal(sig, 0); -} - -/* Trigger a garbage collection as soon as possible */ - -void urge_major_slice (void) -{ - force_major_slice = 1; - young_limit = young_end; - /* This is only moderately effective on ports that cache young_limit - in a register, since modify() is called directly, not through - caml_c_call, so it may take a while before the register is reloaded - from young_limit. */ -} - -void enter_blocking_section(void) -{ - int sig; - - while (1){ - Assert (!async_signal_mode); - /* If a signal arrives between the next two instructions, - it will be lost. */ - sig = pending_signal; - pending_signal = 0; - young_limit = young_start; - if (sig) execute_signal(sig, 0); - async_signal_mode = 1; - if (!pending_signal) break; - async_signal_mode = 0; - } - if (enter_blocking_section_hook != NULL) enter_blocking_section_hook(); -} - -void leave_blocking_section(void) -{ - if (leave_blocking_section_hook != NULL) leave_blocking_section_hook(); - Assert(async_signal_mode); - async_signal_mode = 0; -} - -#ifdef POSIX_SIGNALS -static void reraise(int sig, int now) -{ - struct sigaction sa; - sa.sa_handler = 0; - sa.sa_flags = 0; - sigemptyset(&sa.sa_mask); - sigaction(sig, &sa, 0); - /* If the signal was sent using kill() (si_code == 0) or will - not recur then raise it here. Otherwise return. The - offending instruction will be reexecuted and the signal - will recur. */ - if (now == 1) - raise(sig); - return; -} -#endif - -#if defined(TARGET_alpha) || defined(TARGET_mips) -void handle_signal(int sig, int code, struct sigcontext * context) -#elif defined(TARGET_power) && defined(SYS_aix) -void handle_signal(int sig, int code, STRUCT_SIGCONTEXT * context) -#elif defined(TARGET_power) && defined(SYS_elf) -void handle_signal(int sig, struct sigcontext * context) -#elif defined(TARGET_power) && defined(SYS_rhapsody) -void handle_signal(int sig, int code, STRUCT_SIGCONTEXT * context) -#elif defined(TARGET_power) && defined(SYS_bsd) -void handle_signal(int sig, int code, struct sigcontext * context) -#elif defined(TARGET_sparc) && defined(SYS_solaris) -void handle_signal(int sig, int code, void * context) -#else -void handle_signal(int sig) -#endif -{ -#if !defined(POSIX_SIGNALS) && !defined(BSD_SIGNALS) - signal(sig, handle_signal); -#endif - if (async_signal_mode) { - /* We are interrupting a C function blocked on I/O. - Callback the Caml code immediately. */ - leave_blocking_section(); - execute_signal(sig, 1); - enter_blocking_section(); - } else { - /* We can't execute the signal code immediately. - Instead, we remember the signal and play with the allocation limit - so that the next allocation will trigger a garbage collection. */ - pending_signal = sig; - young_limit = young_end; - /* Some ports cache young_limit in a register. - Use the signal context to modify that register too, but only if - we are inside Caml code (not inside C code). */ -#if defined(TARGET_alpha) - if (In_code_area(context->sc_pc)) { - /* Cached in register $14 */ - context->sc_regs[14] = (long) young_limit; - } -#endif -#if defined(TARGET_mips) - if (In_code_area(context->sc_pc)) { - /* Cached in register $23 */ - context->sc_regs[23] = (int) young_limit; - } -#endif -#if defined(TARGET_power) && defined(SYS_aix) - if (caml_last_return_address == 0) { - /* Cached in register 30 */ - CONTEXT_GPR(context, 30) = (ulong_t) young_limit; - } -#endif -#if defined(TARGET_power) && defined(SYS_elf) - if (caml_last_return_address == 0) { - /* Cached in register 30 */ - context->regs->gpr[30] = (unsigned long) young_limit; - } -#endif -#if defined(TARGET_power) && defined(SYS_rhapsody) - if (In_code_area(CONTEXT_PC(context))) { - /* Cached in register 30 */ - CONTEXT_GPR(context, 30) = (unsigned long) young_limit; - } -#endif -#if defined(TARGET_power) && defined(SYS_bsd) - if (caml_last_return_address == 0) { - /* Cached in register 30 */ - context->sc_frame.fixreg[30] = (unsigned long) young_limit; - } -#endif -#if defined(TARGET_sparc) && defined(SYS_solaris) - { greg_t * gregs = ((ucontext_t *)context)->uc_mcontext.gregs; - if (In_code_area(gregs[REG_PC])) { - /* Cached in register l7, which is saved on the stack 7 words - after the stack pointer. */ - ((long *)(gregs[REG_SP]))[7] = (long) young_limit; - } - } -#endif - } -} - -#ifndef SIGABRT -#define SIGABRT -1 -#endif -#ifndef SIGALRM -#define SIGALRM -1 -#endif -#ifndef SIGFPE -#define SIGFPE -1 -#endif -#ifndef SIGHUP -#define SIGHUP -1 -#endif -#ifndef SIGILL -#define SIGILL -1 -#endif -#ifndef SIGINT -#define SIGINT -1 -#endif -#ifndef SIGKILL -#define SIGKILL -1 -#endif -#ifndef SIGPIPE -#define SIGPIPE -1 -#endif -#ifndef SIGQUIT -#define SIGQUIT -1 -#endif -#ifndef SIGSEGV -#define SIGSEGV -1 -#endif -#ifndef SIGTERM -#define SIGTERM -1 -#endif -#ifndef SIGUSR1 -#define SIGUSR1 -1 -#endif -#ifndef SIGUSR2 -#define SIGUSR2 -1 -#endif -#ifndef SIGCHLD -#define SIGCHLD -1 -#endif -#ifndef SIGCONT -#define SIGCONT -1 -#endif -#ifndef SIGSTOP -#define SIGSTOP -1 -#endif -#ifndef SIGTSTP -#define SIGTSTP -1 -#endif -#ifndef SIGTTIN -#define SIGTTIN -1 -#endif -#ifndef SIGTTOU -#define SIGTTOU -1 -#endif -#ifndef SIGVTALRM -#define SIGVTALRM -1 -#endif -#ifndef SIGPROF -#define SIGPROF -1 -#endif - -static int posix_signals[] = { - SIGABRT, SIGALRM, SIGFPE, SIGHUP, SIGILL, SIGINT, SIGKILL, SIGPIPE, - SIGQUIT, SIGSEGV, SIGTERM, SIGUSR1, SIGUSR2, SIGCHLD, SIGCONT, - SIGSTOP, SIGTSTP, SIGTTIN, SIGTTOU, SIGVTALRM, SIGPROF -}; - -int convert_signal_number(int signo) -{ - if (signo < 0 && signo >= -(sizeof(posix_signals) / sizeof(int))) - return posix_signals[-signo-1]; - else - return signo; -} - -static int rev_convert_signal_number(int signo) -{ - int i; - for (i = 0; i < sizeof(posix_signals) / sizeof(int); i++) - if (signo == posix_signals[i]) return -i - 1; - return signo; -} - -#ifndef NSIG -#define NSIG 64 -#endif - -value install_signal_handler(value signal_number, value action) /* ML */ -{ - CAMLparam2 (signal_number, action); - int sig; - void (*act)(int signo), (*oldact)(int signo); -#ifdef POSIX_SIGNALS - struct sigaction sigact, oldsigact; -#endif - CAMLlocal1 (res); - - sig = convert_signal_number(Int_val(signal_number)); - if (sig < 0 || sig >= NSIG) - invalid_argument("Sys.signal: unavailable signal"); - switch(action) { - case Val_int(0): /* Signal_default */ - act = SIG_DFL; - break; - case Val_int(1): /* Signal_ignore */ - act = SIG_IGN; - break; - default: /* Signal_handle */ - act = (void (*)(int)) handle_signal; - break; - } -#ifdef POSIX_SIGNALS - sigact.sa_handler = act; - sigemptyset(&sigact.sa_mask); -#if defined(SYS_solaris) || defined(SYS_rhapsody) - sigact.sa_flags = SA_SIGINFO; -#else - sigact.sa_flags = 0; -#endif - if (sigaction(sig, &sigact, &oldsigact) == -1) sys_error(NO_ARG); - oldact = oldsigact.sa_handler; -#else - oldact = signal(sig, act); - if (oldact == SIG_ERR) sys_error(NO_ARG); -#endif - if (oldact == (void (*)(int)) handle_signal) { - res = alloc_small(1, 0); /* Signal_handle */ - Field(res, 0) = Field(signal_handlers, sig); - } - else if (oldact == SIG_IGN) - res = Val_int(1); /* Signal_ignore */ - else - res = Val_int(0); /* Signal_default */ - if (Is_block(action)) { - if (signal_handlers == 0) { - signal_handlers = alloc(NSIG, 0); - register_global_root(&signal_handlers); - } - modify(&Field(signal_handlers, sig), Field(action, 0)); - } - CAMLreturn (res); -} - -/* Machine- and OS-dependent handling of bound check trap */ - -#if defined(TARGET_sparc) && defined(SYS_sunos) -static void trap_handler(int sig, int code, - struct sigcontext * context, char * address) -{ - int * sp; - /* Unblock SIGILL */ - sigset_t mask; - sigemptyset(&mask); - sigaddset(&mask, SIGILL); - sigprocmask(SIG_UNBLOCK, &mask, NULL); - if (code != ILL_TRAP_FAULT(5)) { - fprintf(stderr, "Fatal error: illegal instruction, code 0x%x\n", code); - exit(100); - } - /* Recover young_ptr and caml_exception_pointer from the %l5 and %l6 regs */ - sp = (int *) context->sc_sp; - caml_exception_pointer = (char *) sp[5]; - young_ptr = (char *) sp[6]; - array_bound_error(); -} -#endif - -#if defined(TARGET_sparc) && defined(SYS_solaris) -static void trap_handler(int sig, siginfo_t * info, void * context) -{ - long * sp; - - if (info->si_code != ILL_ILLTRP) { - fprintf(stderr, "Fatal error: illegal instruction, code 0x%x\n", - info->si_code); - exit(100); - } - /* Recover young_ptr and caml_exception_pointer from the %l5 and %l6 regs */ - sp = (long *) (((ucontext_t *)context)->uc_mcontext.gregs[REG_SP]); - caml_exception_pointer = (char *) sp[5]; - young_ptr = (char *) sp[6]; - array_bound_error(); -} -#endif - -#if defined(TARGET_sparc) && (defined(SYS_bsd) || defined(SYS_linux)) -static void trap_handler(int sig) -{ - /* TODO: recover registers from context and call array_bound_error */ - fatal_error("Fatal error: out-of-bound access in array or string\n"); -} -#endif - -#if defined(TARGET_power) && defined(SYS_aix) -static void trap_handler(int sig, int code, STRUCT_SIGCONTEXT * context) -{ - /* Unblock SIGTRAP */ - sigset_t mask; - sigemptyset(&mask); - sigaddset(&mask, SIGTRAP); - sigprocmask(SIG_UNBLOCK, &mask, NULL); - /* Recover young_ptr and caml_exception_pointer from registers 31 and 29 */ - caml_exception_pointer = (char *) CONTEXT_GPR(context, 29); - young_ptr = (char *) CONTEXT_GPR(context, 31); - array_bound_error(); -} -#endif - -#if defined(TARGET_power) && defined(SYS_elf) -static void trap_handler(int sig, struct sigcontext * context) -{ - /* Recover young_ptr and caml_exception_pointer from registers 31 and 29 */ - caml_exception_pointer = (char *) context->regs->gpr[29]; - young_ptr = (char *) context->regs->gpr[31]; - array_bound_error(); -} -#endif - -#if defined(TARGET_power) && defined(SYS_rhapsody) -static void trap_handler(int sig, int code, STRUCT_SIGCONTEXT * context) -{ - /* Unblock SIGTRAP */ - sigset_t mask; - sigemptyset(&mask); - sigaddset(&mask, SIGTRAP); - sigprocmask(SIG_UNBLOCK, &mask, NULL); - /* Recover young_ptr and caml_exception_pointer from registers 31 and 29 */ - caml_exception_pointer = (char *) CONTEXT_GPR(context, 29); - young_ptr = (char *) CONTEXT_GPR(context, 31); - array_bound_error(); -} -#endif - -#if defined(TARGET_power) && defined(SYS_bsd) -static void trap_handler(int sig, int code, struct sigcontext * context) -{ - /* Recover young_ptr and caml_exception_pointer from registers 31 and 29 */ - caml_exception_pointer = (char *) context->sc_frame.fixreg[29]; - young_ptr = (char *) context->sc_frame.fixreg[31]; - array_bound_error(); -} -#endif - - -/* Machine- and OS-dependent handling of stack overflow */ - -#ifdef HAS_STACK_OVERFLOW_DETECTION - -static char * system_stack_top; -static char sig_alt_stack[SIGSTKSZ]; - -static int is_stack_overflow(char * fault_addr) -{ - struct rlimit limit; - struct sigaction act; - - /* Sanity checks: - - faulting address is word-aligned - - faulting address is within the stack */ - if (((long) fault_addr & (sizeof(long) - 1)) == 0 && - getrlimit(RLIMIT_STACK, &limit) == 0 && - fault_addr < system_stack_top && - fault_addr >= system_stack_top - limit.rlim_cur - 0x2000) { - /* OK, caller can turn this into a Stack_overflow exception */ - return 1; - } else { - /* Otherwise, deactivate our exception handler. Caller will - return, causing fatal signal to be generated at point of error. */ - act.sa_handler = SIG_DFL; - act.sa_flags = 0; - sigemptyset(&act.sa_mask); - sigaction(SIGSEGV, &act, NULL); - return 0; - } -} - -#if defined(TARGET_i386) && defined(SYS_linux_elf) -static void segv_handler(int signo, struct sigcontext sc) -{ - if (is_stack_overflow((char *) sc.cr2)) - raise_stack_overflow(); -} -#endif - -#if defined(TARGET_i386) && !defined(SYS_linux_elf) -static void segv_handler(int signo, siginfo_t * info, void * arg) -{ - if (is_stack_overflow((char *) info->si_addr)) - raise_stack_overflow(); -} -#endif - -#endif - -/* Initialization of signal stuff */ - -void init_signals(void) -{ - /* Bound-check trap handling */ -#if defined(TARGET_sparc) && \ - (defined(SYS_sunos) || defined(SYS_bsd) || defined(SYS_linux)) - { - struct sigaction act; - act.sa_handler = (void (*)(int)) trap_handler; - sigemptyset(&act.sa_mask); - act.sa_flags = 0; - sigaction(SIGILL, &act, NULL); - } -#endif -#if defined(TARGET_sparc) && defined(SYS_solaris) - { - struct sigaction act; - act.sa_sigaction = trap_handler; - sigemptyset(&act.sa_mask); - act.sa_flags = SA_SIGINFO | SA_NODEFER; - sigaction(SIGILL, &act, NULL); - } -#endif -#if defined(TARGET_power) - { - struct sigaction act; - act.sa_handler = (void (*)(int)) trap_handler; - sigemptyset(&act.sa_mask); -#if defined (SYS_rhapsody) - act.sa_flags = SA_SIGINFO; -#elif defined (SYS_aix) - act.sa_flags = 0; -#else - act.sa_flags = SA_NODEFER; -#endif - sigaction(SIGTRAP, &act, NULL); - } -#endif - /* Stack overflow handling */ -#ifdef HAS_STACK_OVERFLOW_DETECTION - { - struct sigaltstack stk; - struct sigaction act; - stk.ss_sp = sig_alt_stack; - stk.ss_size = SIGSTKSZ; - stk.ss_flags = 0; -#if defined(TARGET_i386) && defined(SYS_linux_elf) - act.sa_handler = (void (*)(int)) segv_handler; - act.sa_flags = SA_ONSTACK | SA_NODEFER; -#else - act.sa_sigaction = segv_handler; - act.sa_flags = SA_SIGINFO | SA_ONSTACK | SA_NODEFER; -#endif - sigemptyset(&act.sa_mask); - system_stack_top = (char *) &act; - if (sigaltstack(&stk, NULL) == 0) { sigaction(SIGSEGV, &act, NULL); } - } -#endif -} diff --git a/asmrun/sparc.S b/asmrun/sparc.S deleted file mode 100644 index 1ac331d962..0000000000 --- a/asmrun/sparc.S +++ /dev/null @@ -1,398 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 1996 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 file ../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -/* Asm part of the runtime system for the Sparc processor. */ -/* Must be preprocessed by cpp */ - -/* SunOS 4 prefixes identifiers with _ */ - -#if defined(SYS_sunos) - - .common _caml_required_size, 4, "bss" - -#define Young_limit _young_limit -#define Young_ptr _young_ptr -#define Caml_bottom_of_stack _caml_bottom_of_stack -#define Caml_last_return_address _caml_last_return_address -#define Caml_gc_regs _caml_gc_regs -#define Caml_exception_pointer _caml_exception_pointer -#define Caml_required_size _caml_required_size -#define Caml_alloc _caml_alloc -#define Caml_call_gc _caml_call_gc -#define Garbage_collection _garbage_collection -#define Caml_c_call _caml_c_call -#define Caml_start_program _caml_start_program -#define Caml_program _caml_program -#define Raise_caml_exception _raise_caml_exception -#define Callback_exn _callback_exn -#define Callback2_exn _callback2_exn -#define Callback3_exn _callback3_exn -#define Caml_apply2 _caml_apply2 -#define Caml_apply3 _caml_apply3 -#define Mlraise _mlraise -#define System_frametable _system__frametable - -#else - - .common caml_required_size, 4, 4 - -#define Young_limit young_limit -#define Young_ptr young_ptr -#define Caml_bottom_of_stack caml_bottom_of_stack -#define Caml_last_return_address caml_last_return_address -#define Caml_gc_regs caml_gc_regs -#define Caml_exception_pointer caml_exception_pointer -#define Caml_required_size caml_required_size -#define Caml_alloc caml_alloc -#define Caml_call_gc caml_call_gc -#define Garbage_collection garbage_collection -#define Caml_c_call caml_c_call -#define Caml_start_program caml_start_program -#define Caml_program caml_program -#define Raise_caml_exception raise_caml_exception -#define Callback_exn callback_exn -#define Callback2_exn callback2_exn -#define Callback3_exn callback3_exn -#define Caml_apply2 caml_apply2 -#define Caml_apply3 caml_apply3 -#define Mlraise mlraise -#define System_frametable system__frametable - -#endif - -#ifndef SYS_solaris -#define INDIRECT_LIMIT -#endif - -#define Exn_ptr %l5 -#define Alloc_ptr %l6 -#define Alloc_limit %l7 - -#define Load(symb,reg) sethi %hi(symb), %g1; ld [%g1 + %lo(symb)], reg -#define Store(reg,symb) sethi %hi(symb), %g1; st reg, [%g1 + %lo(symb)] -#define Address(symb,reg) sethi %hi(symb), reg; or reg, %lo(symb), reg - -/* Allocation functions */ - - .text - .global Caml_alloc - .global Caml_call_gc - -/* Required size in %g2 */ -Caml_alloc: -#ifdef INDIRECT_LIMIT - ld [Alloc_limit], %g1 - sub Alloc_ptr, %g2, Alloc_ptr - cmp Alloc_ptr, %g1 -#else - sub Alloc_ptr, %g2, Alloc_ptr - cmp Alloc_ptr, Alloc_limit -#endif - /*blu,pt %icc, Caml_call_gc*/ - blu Caml_call_gc - nop - retl - nop - -/* Required size in %g2 */ -Caml_call_gc: - /* Save %g2 (required size) */ - Store(%g2, Caml_required_size) - /* Save exception pointer if GC raises */ - Store(Exn_ptr, Caml_exception_pointer) - /* Save current allocation pointer for debugging purposes */ - Store(Alloc_ptr, Young_ptr) - /* Record lowest stack address */ - Store(%sp, Caml_bottom_of_stack) - /* Record last return address */ - Store(%o7, Caml_last_return_address) - /* Allocate space on stack for caml_context structure and float regs */ - sub %sp, 20*4 + 15*8, %sp - /* Save int regs on stack and save it into caml_gc_regs */ -L100: add %sp, 96 + 15*8, %g2 - st %o0, [%g2] - st %o1, [%g2 + 0x4] - st %o2, [%g2 + 0x8] - st %o3, [%g2 + 0xc] - st %o4, [%g2 + 0x10] - st %o5, [%g2 + 0x14] - st %i0, [%g2 + 0x18] - st %i1, [%g2 + 0x1c] - st %i2, [%g2 + 0x20] - st %i3, [%g2 + 0x24] - st %i4, [%g2 + 0x28] - st %i5, [%g2 + 0x2c] - st %l0, [%g2 + 0x30] - st %l1, [%g2 + 0x34] - st %l2, [%g2 + 0x38] - st %l3, [%g2 + 0x3c] - st %l4, [%g2 + 0x40] - st %g3, [%g2 + 0x44] - st %g4, [%g2 + 0x48] - Store(%g2, Caml_gc_regs) - /* Save the floating-point registers */ - add %sp, 96, %g1 - std %f0, [%g1] - std %f2, [%g1 + 0x8] - std %f4, [%g1 + 0x10] - std %f6, [%g1 + 0x18] - std %f8, [%g1 + 0x20] - std %f10, [%g1 + 0x28] - std %f12, [%g1 + 0x30] - std %f14, [%g1 + 0x38] - std %f16, [%g1 + 0x40] - std %f18, [%g1 + 0x48] - std %f20, [%g1 + 0x50] - std %f22, [%g1 + 0x58] - std %f24, [%g1 + 0x60] - std %f26, [%g1 + 0x68] - std %f28, [%g1 + 0x70] - /* Call the garbage collector */ - call Garbage_collection - nop - /* Restore all regs used by the code generator */ - add %sp, 96 + 15*8, %g2 - ld [%g2], %o0 - ld [%g2 + 0x4], %o1 - ld [%g2 + 0x8], %o2 - ld [%g2 + 0xc], %o3 - ld [%g2 + 0x10], %o4 - ld [%g2 + 0x14], %o5 - ld [%g2 + 0x18], %i0 - ld [%g2 + 0x1c], %i1 - ld [%g2 + 0x20], %i2 - ld [%g2 + 0x24], %i3 - ld [%g2 + 0x28], %i4 - ld [%g2 + 0x2c], %i5 - ld [%g2 + 0x30], %l0 - ld [%g2 + 0x34], %l1 - ld [%g2 + 0x38], %l2 - ld [%g2 + 0x3c], %l3 - ld [%g2 + 0x40], %l4 - ld [%g2 + 0x44], %g3 - ld [%g2 + 0x48], %g4 - add %sp, 96, %g1 - ldd [%g1], %f0 - ldd [%g1 + 0x8], %f2 - ldd [%g1 + 0x10], %f4 - ldd [%g1 + 0x18], %f6 - ldd [%g1 + 0x20], %f8 - ldd [%g1 + 0x28], %f10 - ldd [%g1 + 0x30], %f12 - ldd [%g1 + 0x38], %f14 - ldd [%g1 + 0x40], %f16 - ldd [%g1 + 0x48], %f18 - ldd [%g1 + 0x50], %f20 - ldd [%g1 + 0x58], %f22 - ldd [%g1 + 0x60], %f24 - ldd [%g1 + 0x68], %f26 - ldd [%g1 + 0x70], %f28 - /* Reload alloc ptr */ - Load(Young_ptr, Alloc_ptr) - /* Allocate space for block */ - Load(Caml_required_size, %g2) -#ifdef INDIRECT_LIMIT - ld [Alloc_limit], %g1 - sub Alloc_ptr, %g2, Alloc_ptr - cmp Alloc_ptr, %g1 /* Check that we have enough free space */ -#else - Load(Young_limit,Alloc_limit) - sub Alloc_ptr, %g2, Alloc_ptr - cmp Alloc_ptr, Alloc_limit -#endif - blu L100 /* If not, call GC again */ - nop - /* Return to caller */ - Load(Caml_last_return_address, %o7) - retl - add %sp, 20*4 + 15*8, %sp /* in delay slot */ - -/* Call a C function from Caml */ - - .global Caml_c_call -/* Function to call is in %g2 */ -Caml_c_call: - /* Record lowest stack address and return address */ - Store(%sp, Caml_bottom_of_stack) - Store(%o7, Caml_last_return_address) - /* Save the exception handler and alloc pointer */ - Store(Exn_ptr, Caml_exception_pointer) - sethi %hi(Young_ptr), %g1 - /* Call the C function */ - call %g2 - st Alloc_ptr, [%g1 + %lo(Young_ptr)] /* in delay slot */ - /* Reload return address */ - Load(Caml_last_return_address, %o7) - /* Reload alloc pointer */ - sethi %hi(Young_ptr), %g1 - /* Return to caller */ - retl - ld [%g1 + %lo(Young_ptr)], Alloc_ptr /* in delay slot */ - -/* Start the Caml program */ - - .global Caml_start_program -Caml_start_program: - /* Save all callee-save registers */ - save %sp, -96, %sp - /* Address of code to call */ - Address(Caml_program, %l2) - - /* Code shared with callback* */ -L108: - /* Set up a callback link on the stack. */ - sub %sp, 16, %sp - Load(Caml_bottom_of_stack, %l0) - Load(Caml_last_return_address, %l1) - Load(Caml_gc_regs, %l3) - st %l0, [%sp + 96] - st %l1, [%sp + 100] - /* Set up a trap frame to catch exceptions escaping the Caml code */ - call L111 - st %l3, [%sp + 104] - b L110 - nop -L111: sub %sp, 8, %sp - Load(Caml_exception_pointer, Exn_ptr) - st %o7, [%sp + 96] - st Exn_ptr, [%sp + 100] - mov %sp, Exn_ptr - /* Reload allocation pointers */ - Load(Young_ptr, Alloc_ptr) -#ifdef INDIRECT_LIMIT - Address(Young_limit, Alloc_limit) -#else - Load(Young_limit, Alloc_limit) -#endif - /* Call the Caml code */ -L109: call %l2 - nop - /* Pop trap frame and restore caml_exception_pointer */ - ld [%sp + 100], Exn_ptr - add %sp, 8, %sp - Store(Exn_ptr, Caml_exception_pointer) - /* Pop callback link, restoring the global variables */ -L112: ld [%sp + 96], %l0 - ld [%sp + 100], %l1 - ld [%sp + 104], %l2 - Store(%l0, Caml_bottom_of_stack) - Store(%l1, Caml_last_return_address) - Store(%l2, Caml_gc_regs) - add %sp, 16, %sp - /* Save allocation pointer */ - Store(Alloc_ptr, Young_ptr) - /* Reload callee-save registers and return */ - ret - restore %o0, 0, %o0 /* copy %o0 in this window to caller's %o0 */ -L110: - /* The trap handler */ - Store(Exn_ptr, Caml_exception_pointer) - /* Encode exception bucket as an exception result */ - b L112 - or %o0, 2, %o0 - -/* Raise an exception from C */ - - .global Raise_caml_exception -Raise_caml_exception: - /* Save exception bucket in a register outside the reg windows */ - mov %o0, %g2 - /* Load exception pointer in a register outside the reg windows */ - Load(Caml_exception_pointer, %g3) - /* Pop some frames until the trap pointer is in the current frame. */ - cmp %g3, %fp - blt L107 /* if Exn_ptr < %fp, over */ - nop -L106: restore - cmp %fp, %g3 /* if %fp <= Exn_ptr, loop */ - ble L106 - nop -L107: - /* Reload allocation registers */ - Load(Young_ptr, Alloc_ptr) -#ifdef INDIRECT_LIMIT - Address(Young_limit, Alloc_limit) -#else - Load(Young_limit, Alloc_limit) -#endif - /* Branch to exception handler */ - mov %g3, %sp - ld [%sp + 96], %g1 - ld [%sp + 100], Exn_ptr - add %sp, 8, %sp - jmp %g1 + 8 - /* Restore bucket, in delay slot */ - mov %g2, %o0 - -/* Callbacks C -> ML */ - - .global Callback_exn -Callback_exn: - /* Save callee-save registers and return address */ - save %sp, -96, %sp - /* Initial shuffling of arguments */ - mov %i0, %g1 - mov %i1, %i0 /* first arg */ - mov %g1, %i1 /* environment */ - b L108 - ld [%g1], %l2 /* code pointer */ - - .global Callback2_exn -Callback2_exn: - /* Save callee-save registers and return address */ - save %sp, -104, %sp - /* Initial shuffling of arguments */ - mov %i0, %g1 - mov %i1, %i0 /* first arg */ - mov %i2, %i1 /* second arg */ - mov %g1, %i2 /* environment */ - sethi %hi(Caml_apply2), %l2 - b L108 - or %l2, %lo(Caml_apply2), %l2 - - .global Callback3_exn -Callback3_exn: - /* Save callee-save registers and return address */ - save %sp, -104, %sp - /* Initial shuffling of arguments */ - mov %i0, %g1 - mov %i1, %i0 /* first arg */ - mov %i2, %i1 /* second arg */ - mov %i3, %i2 /* third arg */ - mov %g1, %i3 /* environment */ - sethi %hi(Caml_apply3), %l2 - b L108 - or %l2, %lo(Caml_apply3), %l2 - -#ifdef SYS_solaris - .section ".rodata" -#else - .data -#endif - .global System_frametable -System_frametable: - .word 1 /* one descriptor */ - .word L109 /* return address into callback */ - .half -1 /* negative frame size => use callback link */ - .half 0 /* no roots */ - -#ifdef SYS_solaris - .type Caml_alloc, #function - .type Caml_call_gc, #function - .type Caml_c_call, #function - .type Caml_start_program, #function - .type Raise_caml_exception, #function - .type System_frametable, #object -#endif diff --git a/asmrun/stack.h b/asmrun/stack.h deleted file mode 100644 index 265b42d26f..0000000000 --- a/asmrun/stack.h +++ /dev/null @@ -1,105 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 1996 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 file ../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -/* Machine-dependent interface with the asm code */ - -#ifndef _stack_ -#define _stack_ - -/* Macros to access the stack frame */ -#ifdef TARGET_alpha -#define Saved_return_address(sp) *((long *)((sp) - 8)) -#define Already_scanned(sp, retaddr) ((retaddr) & 1L) -#define Mark_scanned(sp, retaddr) (*((long *)((sp) - 8)) = (retaddr) | 1L) -#define Mask_already_scanned(retaddr) ((retaddr) & ~1L) -#define Callback_link(sp) ((struct caml_context *)((sp) + 16)) -#endif - -#ifdef TARGET_sparc -#define Saved_return_address(sp) *((long *)((sp) + 92)) -#define Callback_link(sp) ((struct caml_context *)((sp) + 104)) -#endif - -#ifdef TARGET_i386 -#define Saved_return_address(sp) *((long *)((sp) - 4)) -#define Callback_link(sp) ((struct caml_context *)((sp) + 8)) -#endif - -#ifdef TARGET_mips -#define Saved_return_address(sp) *((long *)((sp) - 4)) -#define Callback_link(sp) ((struct caml_context *)((sp) + 16)) -#endif - -#ifdef TARGET_hppa -#define Stack_grows_upwards -#define Saved_return_address(sp) *((long *)(sp)) -#define Callback_link(sp) ((struct caml_context *)((sp) - 24)) -#endif - -#ifdef TARGET_power -#define Saved_return_address(sp) *((long *)((sp) - 4)) -#define Already_scanned(sp, retaddr) ((retaddr) & 1) -#define Mark_scanned(sp, retaddr) (*((long *)((sp) - 4)) = (retaddr) | 1) -#define Mask_already_scanned(retaddr) ((retaddr) & ~1) -#ifdef SYS_aix -#define Trap_frame_size 32 -#else -#define Trap_frame_size 16 -#endif -#define Callback_link(sp) ((struct caml_context *)((sp) + Trap_frame_size)) -#endif - -#ifdef TARGET_m68k -#define Saved_return_address(sp) *((long *)((sp) - 4)) -#define Callback_link(sp) ((struct caml_context *)((sp) + 8)) -#endif - -#ifdef TARGET_arm -#define Saved_return_address(sp) *((long *)((sp) - 4)) -#define Callback_link(sp) ((struct caml_context *)((sp) + 8)) -#endif - -#ifdef TARGET_ia64 -#define Saved_return_address(sp) *((long *)((sp) + 8)) -#define Already_scanned(sp, retaddr) ((retaddr) & 1L) -#define Mark_scanned(sp, retaddr) (*((long *)((sp) + 8)) = (retaddr) | 1L) -#define Mask_already_scanned(retaddr) ((retaddr) & ~1L) -#define Callback_link(sp) ((struct caml_context *)((sp) + 32)) -#endif - -#ifdef TARGET_amd64 -#define Saved_return_address(sp) *((long *)((sp) - 8)) -#define Callback_link(sp) ((struct caml_context *)((sp) + 16)) -#endif - -/* Structure of Caml callback contexts */ - -struct caml_context { - char * bottom_of_stack; /* beginning of Caml stack chunk */ - unsigned long last_retaddr; /* last return address in Caml code */ - value * gc_regs; /* pointer to register block */ -}; - -/* Declaration of variables used in the asm code */ -extern char * caml_bottom_of_stack; -extern unsigned long caml_last_return_address; -extern value * caml_gc_regs; -extern char * caml_exception_pointer; -extern value caml_globals[]; -extern long caml_globals_inited; -extern long * caml_frametable[]; - - -#endif /* _stack_ */ diff --git a/asmrun/startup.c b/asmrun/startup.c deleted file mode 100644 index b3ae46d3c1..0000000000 --- a/asmrun/startup.c +++ /dev/null @@ -1,158 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Xavier Leroy and Damien Doligez, INRIA Rocquencourt */ -/* */ -/* Copyright 1996 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 file ../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -/* Start-up code */ - -#include -#include -#include "callback.h" -#include "custom.h" -#include "fail.h" -#include "gc.h" -#include "gc_ctrl.h" -#include "misc.h" -#include "mlvalues.h" -#include "osdeps.h" -#include "printexc.h" -#include "sys.h" -#ifdef HAS_UI -#include "ui.h" -#endif - -extern int parser_trace; -header_t atom_table[256]; -char * static_data_start, * static_data_end; -char * code_area_start, * code_area_end; - -/* Initialize the atom table and the static data and code area limits. */ - -struct segment { char * begin; char * end; }; - -static void minmax_table(struct segment *table, char **min, char **max) -{ - int i; - *min = table[0].begin; - *max = table[0].end; - for (i = 1; table[i].begin != 0; i++) { - if (table[i].begin < *min) *min = table[i].begin; - if (table[i].end > *max) *max = table[i].end; - } -} - -static void init_atoms(void) -{ - int i; - extern struct segment caml_data_segments[], caml_code_segments[]; - - for (i = 0; i < 256; i++) atom_table[i] = Make_header(0, i, Caml_white); - minmax_table(caml_data_segments, &static_data_start, &static_data_end); - minmax_table(caml_code_segments, &code_area_start, &code_area_end); -} - -/* Configuration parameters and flags */ - -static unsigned long percent_free_init = Percent_free_def; -static unsigned long max_percent_free_init = Max_percent_free_def; -static unsigned long minor_heap_init = Minor_heap_def; -static unsigned long heap_chunk_init = Heap_chunk_def; -static unsigned long heap_size_init = Init_heap_def; -static unsigned long max_stack_init = Max_stack_def; - -/* Parse the CAMLRUNPARAM variable */ -/* The option letter for each runtime option is the first letter of the - last word of the ML name of the option (see [stdlib/gc.mli]). - Except for l (maximum stack size) and h (initial heap size). -*/ -/* Note: option l is irrelevant to the native-code runtime. */ - -/* If you change these functions, see also their copy in byterun/startup.c */ - -static void scanmult (char *opt, long unsigned int *var) -{ - char mult = ' '; - sscanf (opt, "=%lu%c", var, &mult); - sscanf (opt, "=0x%lx%c", var, &mult); - if (mult == 'k') *var = *var * 1024; - if (mult == 'M') *var = *var * (1024 * 1024); - if (mult == 'G') *var = *var * (1024 * 1024 * 1024); -} - -static void parse_camlrunparam(void) -{ - char *opt = getenv ("OCAMLRUNPARAM"); - - if (opt == NULL) opt = getenv ("CAMLRUNPARAM"); - - if (opt != NULL){ - while (*opt != '\0'){ - switch (*opt++){ - case 's': scanmult (opt, &minor_heap_init); break; - case 'i': scanmult (opt, &heap_chunk_init); break; - case 'h': scanmult (opt, &heap_size_init); break; - case 'l': scanmult (opt, &max_stack_init); break; - case 'o': scanmult (opt, &percent_free_init); break; - case 'O': scanmult (opt, &max_percent_free_init); break; - case 'v': scanmult (opt, &verb_gc); break; - case 'p': parser_trace = 1; break; - } - } - } -} - -/* These are termination hooks used by the systhreads library */ -struct longjmp_buffer caml_termination_jmpbuf; -void (*caml_termination_hook)(void *) = NULL; - -extern value caml_start_program (void); -extern void init_ieee_floats (void); -extern void init_signals (void); - -void caml_main(char **argv) -{ - char * exe_name; -#ifdef __linux__ - static char proc_self_exe[256]; -#endif - value res; - - init_ieee_floats(); - init_custom_operations(); -#ifdef DEBUG - verb_gc = 63; -#endif - parse_camlrunparam(); - init_gc (minor_heap_init, heap_size_init, heap_chunk_init, - percent_free_init, max_percent_free_init); - init_atoms(); - init_signals(); - exe_name = argv[0]; -#ifdef __linux__ - if (executable_name(proc_self_exe, sizeof(proc_self_exe)) == 0) - exe_name = proc_self_exe; -#endif - sys_init(exe_name, argv); - if (sigsetjmp(caml_termination_jmpbuf.buf, 0)) { - if (caml_termination_hook != NULL) caml_termination_hook(NULL); - return; - } - res = caml_start_program(); - if (Is_exception_result(res)) - fatal_uncaught_exception(Extract_exception(res)); -} - -void caml_startup(char **argv) -{ - caml_main(argv); -} diff --git a/boot/.cvsignore b/boot/.cvsignore deleted file mode 100644 index bc591db468..0000000000 --- a/boot/.cvsignore +++ /dev/null @@ -1,4 +0,0 @@ -Saved -ocamlrun -ocamlyacc -camlheader diff --git a/boot/ocamlc b/boot/ocamlc deleted file mode 100755 index 8b739e39d2..0000000000 Binary files a/boot/ocamlc and /dev/null differ diff --git a/boot/ocamllex b/boot/ocamllex deleted file mode 100755 index b62a2b463e..0000000000 Binary files a/boot/ocamllex and /dev/null differ diff --git a/camlp4/CHANGES b/camlp4/CHANGES deleted file mode 100644 index 0cba993c44..0000000000 --- a/camlp4/CHANGES +++ /dev/null @@ -1,851 +0,0 @@ -- [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..." instead of "\\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 diff --git a/camlp4/ICHANGES b/camlp4/ICHANGES deleted file mode 100644 index 5b17aaf71d..0000000000 --- a/camlp4/ICHANGES +++ /dev/null @@ -1,20 +0,0 @@ -Internal, very small, undocumented, or invisible changes -******************************************************** - -- [20 nov 03], token.mli: eval_string takes a location as a extra - argument (needed to issue a warning). - -Camlp4s Version 3.06+19 ------------------------ - -- [28 Oct 02] Changed and simplified local entry of pa_o.ml from "cvalue" - to "cvalue_binding". -- [18 Oct 02] The standard syntax for antiquotations in object class_types - and object class_expr are now: <:class_type< $opt:x$ $list:y$ >> and - <:class_expr< $opt:x$ $list:y$ >>: the syntax without the "opt" is - accepted but deprecated (a warning is displayed). -- [15 Oct 02] Changed Plexer which now manages better the line directives - (applied only on begin of lines, no error if parsing error in the - directive). -- [14 Sep 02] Grammar.print_entry does not end any more with - Format.print_flush. The "flush" is done by Grammar.Entry.print. diff --git a/camlp4/Makefile b/camlp4/Makefile deleted file mode 100644 index f80090a0b4..0000000000 --- a/camlp4/Makefile +++ /dev/null @@ -1,190 +0,0 @@ -# $Id$ - -include config/Makefile - -DIRS=odyl camlp4 meta etc top ocpp lib man -FDIRS=odyl camlp4 meta lib -OPTDIRS= lib odyl camlp4 meta etc compile -SHELL=/bin/sh -COLD_FILES=ocaml_src/camlp4/argl.ml ocaml_src/camlp4/ast2pt.ml ocaml_src/camlp4/ast2pt.mli ocaml_src/camlp4/mLast.mli ocaml_src/camlp4/pcaml.ml ocaml_src/camlp4/pcaml.mli ocaml_src/camlp4/quotation.ml ocaml_src/camlp4/quotation.mli ocaml_src/camlp4/reloc.ml ocaml_src/camlp4/reloc.mli ocaml_src/camlp4/spretty.ml ocaml_src/camlp4/spretty.mli ocaml_src/lib/extfun.ml ocaml_src/lib/extfun.mli ocaml_src/lib/fstream.ml ocaml_src/lib/fstream.mli ocaml_src/lib/gramext.ml ocaml_src/lib/gramext.mli ocaml_src/lib/grammar.ml ocaml_src/lib/grammar.mli ocaml_src/lib/plexer.ml ocaml_src/lib/plexer.mli ocaml_src/lib/stdpp.ml ocaml_src/lib/stdpp.mli ocaml_src/lib/token.ml ocaml_src/lib/token.mli ocaml_src/meta/pa_extend.ml ocaml_src/meta/pa_extend_m.ml ocaml_src/meta/pa_macro.ml ocaml_src/meta/pa_r.ml ocaml_src/meta/pa_rp.ml ocaml_src/meta/pr_dump.ml ocaml_src/meta/q_MLast.ml ocaml_src/odyl/odyl_main.ml ocaml_src/odyl/odyl_main.mli ocaml_src/odyl/odyl.ml - -all: boot/camlp4$(EXE) - set -e; for i in $(DIRS); do cd $$i; $(MAKE) all; cd ..; done - -opt: - cd lib; $(MAKE) opt - -opt.opt: - set -e; for i in $(OPTDIRS); do cd $$i; $(MAKE) opt; cd ..; done - -boot/camlp4$(EXE): $(COLD_FILES) - $(MAKE) clean_cold library_cold compile_cold - $(MAKE) promote_cold - $(MAKE) clean_cold clean_hot library - -clean_hot: - for i in $(DIRS) compile; do (cd $$i; $(MAKE) clean); done - -depend: - for i in $(DIRS) compile; do (cd $$i; $(MAKE) depend); done - -install: - for i in $(DIRS) compile; do (cd $$i; $(MAKE) install BINDIR="$(BINDIR)" LIBDIR="$(LIBDIR)" MANDIR="$(MANDIR)"); done - -uninstall: - rm -rf "$(LIBDIR)/camlp4" - cd "$(BINDIR)"; rm -f *camlp4* odyl ocpp - -clean:: - $(MAKE) clean_hot clean_cold - rm -f boot/*.cm[oi] boot/camlp4* - rm -rf boot/SAVED - -scratch: clean - -always: - -# Normal bootstrap - -bootstrap: backup promote clean_hot all compare - -backup: - mkdir boot.new - make mv_cvs FROM=boot TO=boot.new - mv boot boot.new/SAVED - mv boot.new boot - -restore: - mv boot/SAVED boot.new - make mv_cvs FROM=boot TO=boot.new - rm -rf boot - mv boot.new boot - -promote: - for i in $(FDIRS); do (cd $$i; $(MAKE) promote); done - -compare: - @if (for i in $(FDIRS); do \ - if (cd $$i; $(MAKE) compare 2>/dev/null); then :; \ - else exit 1; fi; \ - done); \ - then echo "Fixpoint reached, bootstrap succeeded."; \ - else echo "Fixpoint not reached, try one more bootstrapping cycle."; \ - fi - -cleanboot: - rm -rf boot/SAVED/SAVED - - -# Core and core bootstrap - -bootstrap_core: backup promote clean_hot core compare - -core: boot/camlp4$(EXE) - set -e; for i in $(FDIRS); do cd $$i; $(MAKE) all; cd ..; done - -clean_core: - for i in $(FDIRS); do (cd $$i; $(MAKE) clean); done - - -# The very beginning - -world: - $(MAKE) clean_cold library_cold compile_cold - $(MAKE) promote_cold - $(MAKE) clean_cold clean_hot library all - -library: - cd lib; $(MAKE) all promote - -# Cold start using pure Objective Caml sources - -library_cold: - cd ocaml_src/lib; $(MAKE) all promote OTOP=../$(OTOP) - -compile_cold: - cd ocaml_src; set -e; \ - for i in $(FDIRS); do \ - cd $$i; $(MAKE) all OTOP=../$(OTOP); cd ..; \ - done - -promote_cold: - for i in $(FDIRS); do \ - (cd ocaml_src/$$i; $(MAKE) promote); \ - done - -clean_cold: - for i in $(FDIRS); do \ - (cd ocaml_src/$$i; $(MAKE) clean); \ - done - -# Configuring for native win32 - -configure_nt: - echo pouet - echo BINDIR = $(BINDIR) - -# Bootstrap the sources - -TXTGEN=This file has been generated by program: do not edit! - -bootstrap_sources: - cd etc; make pr_o.cmo - mkdir ocaml_src.new - @-for i in $(FDIRS); do \ - (mkdir ocaml_src.new/$$i; cd ocaml_src.new/$$i; \ - sed 's/# $$Id.*\$$/# $(TXTGEN)/' ../../$$i/Makefile | \ - sed 's-include ../config-include ../../config-g' | \ - sed 's-../boot-../../boot-g' > Makefile; \ - sed 's/# $$Id.*\$$/# $(TXTGEN)/' ../../$$i/Makefile.Mac | \ - sed 's-:boot-::boot-g' > Makefile.Mac; \ - cp ../../$$i/.depend . ; \ - cp ../../$$i/Makefile.Mac.depend .); \ - done - @-for i in $(FDIRS); do \ - (cd $$i; \ - for j in *.ml*; do \ - echo ============================================; \ - echo ocaml_src.new/$$i/$$j; \ - OTOP=../.. ../tools/conv.sh $$j | \ - sed 's/$$Id.*\$$/$(TXTGEN)/' > \ - ../ocaml_src.new/$$i/$$j; \ - done); \ - done - -untouch_sources: - @-cd ocaml_src; \ - for i in $(FDIRS); do \ - for j in $$i/*.ml* $$i/Makefile*; do \ - if cmp -s $$j ../ocaml_src.new/$$j 2>/dev/null; then \ - cp -p $$j ../ocaml_src.new/$$j; \ - fi; \ - done; \ - done - -promote_sources: - make mv_cvs FROM=ocaml_src TO=ocaml_src.new - for i in $(FDIRS); do \ - make mv_cvs FROM=ocaml_src/$$i TO=ocaml_src.new/$$i; \ - done - mv ocaml_src/tools ocaml_src.new/. - mv ocaml_src ocaml_src.new/SAVED - mv ocaml_src.new ocaml_src - -unpromote_sources: - mv ocaml_src ocaml_src.new - mv ocaml_src.new/SAVED ocaml_src - mv ocaml_src.new/tools ocaml_src/. - for i in $(FDIRS); do \ - make mv_cvs FROM=ocaml_src.new/$$i TO=ocaml_src/$$i; \ - done - make mv_cvs FROM=ocaml_src.new TO=ocaml_src - -clean_sources: - rm -rf ocaml_src/SAVED/SAVED - -# Utility - -mv_cvs: - test ! -d $(FROM)/CVS || mv $(FROM)/CVS $(TO)/. - test ! -f $(FROM)/.cvsignore || mv $(FROM)/.cvsignore $(TO)/. diff --git a/camlp4/Makefile.Mac b/camlp4/Makefile.Mac deleted file mode 100644 index 7b96430a1e..0000000000 --- a/camlp4/Makefile.Mac +++ /dev/null @@ -1,204 +0,0 @@ -####################################################################### -# # -# Camlp4 # -# # -# Damien Doligez, projet Para, INRIA Rocquencourt # -# # -# Copyright 1999 Institut National de Recherche en Informatique et # -# en Automatique. Distributed only by permission. # -# # -####################################################################### - -# $Id$ - -DIRS = odyl camlp4 meta etc top ocpp lib man -FDIRS = odyl camlp4 meta lib - -all Ä :boot:camlp4 - for i in {DIRS} - directory {i} - domake all - directory :: - end - -:boot:camlp4 Ä - domake clean_cold library_cold compile_cold - domake promote_cold - domake clean_cold clean_hot library - -clean_hot Ä - for i in {DIRS} - directory {i} - domake clean - directory :: - end - -depend Ä - for i in {DIRS} - directory {i} - domake depend - directory :: - end - -install Ä - for i in {DIRS} - directory {i} - domake install - directory :: - end - -scratch Ä clean - delete -i :boot:Å.cm[oi] || set status 0 - delete -i :boot:camlp4Å || set status 0 - delete -y -i :boot:SAVED - -clean Ä clean_hot clean_cold - -# Normal bootstrap - -bootstrap Ä backup promote clean_hot all compare - -backup Ä - newfolder :boot.new - domake mv_cvs -d FROM=:boot: -d TO=:boot.new: - move :boot :boot.new:SAVED - move :boot.new :boot - -restore Ä - move :boot:SAVED :boot.new - domake mv_cvs -d FROM=:boot: -d TO=:boot.new: - delete -y -i :boot - rename :boot.new :boot - -promote Ä - for i in {FDIRS} - directory {i} - domake promote - directory :: - end - -compare Ä - set failures 0 - set exit 0 - for i in {FDIRS} - directory {i} - domake compare ³ dev:null - evaluate failures += {status} - directory :: - end - if {failures} - echo "Fixpoint not reached, try one more bootstrapping cycle." - else - echo "Fixpoint reached, bootstrap succeeded." - end - -cleanboot Ä - delete -i -y :boot:SAVED:SAVED - - -# Fast bootstrap - -bootstrap_fast Ä backup promote clean_hot fast compare - -fast Ä :boot:camlp4 - for i in {FDIRS} - directory {i} - domake all - directory :: - end - -clean_fast Ä - for i in {FDIRS} - directory {i} - domake clean - directory :: - end - - -# The very beginning - -world Ä - domake clean_cold library_cold compile_cold - domake promote_cold - domake clean_cold clean_hot library all - -library Ä - directory lib - domake all promote - directory :: - -# Cold start using pure Objective Caml sources - -library_cold Ä - directory :ocaml_src:lib - domake all promote - directory ::: - -compile_cold Ä - directory ocaml_src - for i in {FDIRS} - directory {i} - domake all - directory :: - end - directory :: - -promote_cold Ä - for i in {FDIRS} - directory :ocaml_src:{i} - domake promote - directory ::: - end - -clean_cold Ä - for i in {FDIRS} - directory :ocaml_src:{i} - domake clean - directory ::: - end - -# Bootstrap the sources - -#bootstrap_sources Ä -# cd etc; make pr_o.cmo -# mkdir ocaml_src.new -# @-for i in $(FDIRS); do \ -# (mkdir ocaml_src.new/$$i; cd ocaml_src.new/$$i; \ -# sed 's/# $$Id.*\$$/# Id/' ../../$$i/Makefile | \ -# sed 's-include ../config-include ../../config-g' | \ -# sed 's-../boot-../../boot-g' > Makefile; \ -# cp ../../$$i/.depend .) \ -# done -# @-for i in $(FDIRS); do \ -# for j in $$i/*.ml*; do \ -# echo ============================================; \ -# echo ocaml_src.new/$$j; \ -# ./tools/conv.sh $$j | \ -# sed 's/$$Id.*\$$/Id/' > ocaml_src.new/$$j; \ -# done; \ -# done - -#promote_sources: -# make mv_cvs FROM=ocaml_src TO=ocaml_src.new -# for i in $(FDIRS); do \ -# make mv_cvs FROM=ocaml_src/$$i TO=ocaml_src.new/$$i; \ -# done -# mv ocaml_src/tools ocaml_src.new/. -# mv ocaml_src ocaml_src.new/SAVED -# mv ocaml_src.new ocaml_src - -#unpromote_sources: -# mv ocaml_src ocaml_src.new -# mv ocaml_src.new/SAVED ocaml_src -# mv ocaml_src.new/tools ocaml_src/. -# for i in $(FDIRS); do \ -# make mv_cvs FROM=ocaml_src.new/$$i TO=ocaml_src/$$i; \ -# done -# make mv_cvs FROM=ocaml_src.new TO=ocaml_src - -#clean_sources: -# rm -rf ocaml_src/SAVED/SAVED - -mv_cvs Ä - if "`exists "{FROM}CVS"`"; move "{FROM}CVS" "{TO}"; end - if "`exists "{FROM}.cvsignore"`"; move "{FROM}.cvsignore" "{TO}"; end diff --git a/camlp4/boot/.cvsignore b/camlp4/boot/.cvsignore deleted file mode 100644 index 85599a4b58..0000000000 --- a/camlp4/boot/.cvsignore +++ /dev/null @@ -1,5 +0,0 @@ -*.cm[oia] -camlp4 -camlp4o -camlp4r -SAVED diff --git a/camlp4/camlp4/.cvsignore b/camlp4/camlp4/.cvsignore deleted file mode 100644 index 38b5e0906f..0000000000 --- a/camlp4/camlp4/.cvsignore +++ /dev/null @@ -1,6 +0,0 @@ -*.cm[oia] -camlp4 -*.lib -crc.ml -extract_crc -phony diff --git a/camlp4/camlp4/.depend b/camlp4/camlp4/.depend deleted file mode 100644 index bf82065403..0000000000 --- a/camlp4/camlp4/.depend +++ /dev/null @@ -1,21 +0,0 @@ -ast2pt.cmi: $(OTOP)/parsing/location.cmi $(OTOP)/parsing/longident.cmi mLast.cmi \ - $(OTOP)/parsing/parsetree.cmi -pcaml.cmi: mLast.cmi spretty.cmi -quotation.cmi: mLast.cmi -reloc.cmi: mLast.cmi -argl.cmo: ast2pt.cmi mLast.cmi ../odyl/odyl_main.cmi pcaml.cmi -argl.cmx: ast2pt.cmx mLast.cmi ../odyl/odyl_main.cmx pcaml.cmx -ast2pt.cmo: $(OTOP)/parsing/asttypes.cmi $(OTOP)/parsing/location.cmi \ - $(OTOP)/parsing/longident.cmi mLast.cmi $(OTOP)/parsing/parsetree.cmi \ - ast2pt.cmi -ast2pt.cmx: $(OTOP)/parsing/asttypes.cmi $(OTOP)/parsing/location.cmx \ - $(OTOP)/parsing/longident.cmx mLast.cmi $(OTOP)/parsing/parsetree.cmi \ - ast2pt.cmi -pcaml.cmo: ast2pt.cmi mLast.cmi quotation.cmi reloc.cmi spretty.cmi pcaml.cmi -pcaml.cmx: ast2pt.cmx mLast.cmi quotation.cmx reloc.cmx spretty.cmx pcaml.cmi -quotation.cmo: mLast.cmi quotation.cmi -quotation.cmx: mLast.cmi quotation.cmi -reloc.cmo: mLast.cmi reloc.cmi -reloc.cmx: mLast.cmi reloc.cmi -spretty.cmo: spretty.cmi -spretty.cmx: spretty.cmi diff --git a/camlp4/camlp4/Makefile b/camlp4/camlp4/Makefile deleted file mode 100644 index 31ffc05057..0000000000 --- a/camlp4/camlp4/Makefile +++ /dev/null @@ -1,71 +0,0 @@ -# $Id$ - -include ../config/Makefile - -SHELL=/bin/sh - -INCLUDES=-I ../odyl -I ../boot -I $(OTOP)/utils -I $(OTOP)/parsing -I $(OTOP)/otherlibs/dynlink -OCAMLCFLAGS= $(INCLUDES) -warn-error A $(INCLUDES) -LINKFLAGS=$(INCLUDES) -INTERFACES=-I $(OLIBDIR) Arg Array ArrayLabels Buffer Callback CamlinternalOO Char Complex Digest Filename Format Gc Genlex Hashtbl Int32 Int64 Lazy Lexing List ListLabels Map Marshal MoreLabels Nativeint Obj Oo Parsing Pervasives Printexc Printf Queue Random Scanf Set Sort Stack StdLabels Stream String StringLabels Sys Weak -I ../boot Extfold Extfun Fstream Gramext Grammar Plexer Stdpp Token -I $(OTOP)/utils Config Warnings -I $(OTOP)/parsing Asttypes Location Longident Parsetree -I . Ast2pt MLast Pcaml Quotation Spretty -CAMLP4_INTF=$(OTOP)/utils/config.cmi $(OTOP)/utils/warnings.cmi $(OTOP)/parsing/asttypes.cmi $(OTOP)/parsing/location.cmi $(OTOP)/parsing/longident.cmi $(OTOP)/parsing/parsetree.cmi ast2pt.cmi mLast.cmi pcaml.cmi spretty.cmi quotation.cmi -CAMLP4_OBJS=../boot/stdpp.cmo ../boot/token.cmo ../boot/plexer.cmo ../boot/gramext.cmo ../boot/grammar.cmo ../boot/extfold.cmo ../boot/extfun.cmo ../boot/fstream.cmo $(OTOP)/utils/config.cmo quotation.cmo ast2pt.cmo spretty.cmo reloc.cmo pcaml.cmo argl.cmo -CAMLP4_XOBJS=../lib/stdpp.cmx ../lib/token.cmx ../lib/plexer.cmx ../lib/gramext.cmx ../lib/grammar.cmx ../lib/extfold.cmx ../lib/extfun.cmx ../lib/fstream.cmx $(OTOP)/utils/config.cmx quotation.cmx ast2pt.cmx spretty.cmx reloc.cmx pcaml.cmx argl.cmx -OBJS=../odyl/odyl.cma camlp4.cma -CAMLP4M= - -CAMLP4=camlp4$(EXE) -CAMLP4OPT=phony - -all: $(CAMLP4) -opt: $(OBJS:.cma=.cmxa) -optp4: $(CAMLP4OPT) - -$(CAMLP4): $(OBJS) ../odyl/odyl.cmo - $(OCAMLC) $(OBJS) $(CAMLP4M) ../odyl/odyl.cmo -linkall -o $(CAMLP4) - -$(CAMLP4OPT): $(OBJS:.cma=.cmxa) ../odyl/odyl.cmx - $(OCAMLOPT) $(OBJS:.cma=.cmxa) $(CAMLP4M) ../odyl/odyl.cmx -linkall -o $(CAMLP4OPT) - -$(OTOP)/utils/config.cmx: $(OTOP)/utils/config.ml - $(OCAMLOPT) -c $(OTOP)/utils/config.ml - -camlp4.cma: $(CAMLP4_OBJS) - $(OCAMLC) $(LINKFLAGS) $(CAMLP4_OBJS) -a -o camlp4.cma - -camlp4.cmxa: $(CAMLP4_XOBJS) - $(OCAMLOPT) $(LINKFLAGS) $(CAMLP4_XOBJS) -a -o camlp4.cmxa - -clean:: - rm -f *.cm* *.pp[io] *.$(O) *.$(A) *.bak .*.bak *.out *.opt - rm -f $(CAMLP4) - -depend: - cp .depend .depend.bak - > .depend - @for i in *.mli *.ml; do \ - ../tools/apply.sh pr_depend.cmo -- $(INCLUDES) $$i | \ - sed -e 's| \.\./\.\.| $$(OTOP)|g' >> .depend; \ - done - -promote: - cp $(CAMLP4) ../boot/. - -compare: - @for j in $(CAMLP4); do \ - if cmp $$j ../boot/$$j; then :; else exit 1; fi; \ - done - -install: - -$(MKDIR) "$(BINDIR)" - -$(MKDIR) "$(LIBDIR)/camlp4" - cp $(CAMLP4) "$(BINDIR)/." - cp mLast.mli quotation.mli ast2pt.mli pcaml.mli spretty.mli "$(LIBDIR)/camlp4/." - cp mLast.cmi quotation.cmi ast2pt.cmi pcaml.cmi spretty.cmi "$(LIBDIR)/camlp4/." - cp camlp4.cma $(LIBDIR)/camlp4/. - if [ -f camlp4.cmxa ]; \ - then cp camlp4.cmxa camlp4.$(A) $(LIBDIR)/camlp4/.; \ - else : ; \ - fi - -include .depend diff --git a/camlp4/camlp4/Makefile.Mac b/camlp4/camlp4/Makefile.Mac deleted file mode 100644 index 63a0e6bed3..0000000000 --- a/camlp4/camlp4/Makefile.Mac +++ /dev/null @@ -1,69 +0,0 @@ -####################################################################### -# # -# Camlp4 # -# # -# Damien Doligez, projet Para, INRIA Rocquencourt # -# # -# Copyright 1999 Institut National de Recherche en Informatique et # -# en Automatique. Distributed only by permission. # -# # -####################################################################### - -# $Id$ - -INCLUDES = -I ::odyl: -I ::boot: -I "{OTOP}utils:" -I "{OTOP}parsing:" ¶ - -I "{OTOP}otherlibs:dynlink:" -OCAMLCFLAGS = {INCLUDES} -LINKFLAGS = {INCLUDES} -INTERFACES = -I "{OLIBDIR}" Arg Array ArrayLabels Buffer Callback CamlinternalOO Char Complex Digest Filename Format Gc Genlex Hashtbl Int32 Int64 Lazy Lexing List ListLabels Map Marshal MoreLabels Nativeint Obj Oo Parsing Pervasives Printexc Printf Queue Random Scanf Set Sort Stack StdLabels Stream String StringLabels Sys Weak ¶ - -I ::boot: Extfold Extfun Fstream ¶ - Gramext Grammar Plexer ¶ - Stdpp Token -I "{OTOP}utils:" Config Warnings ¶ - -I "{OTOP}parsing:" Asttypes Location Longident Parsetree ¶ - -I : Ast2pt MLast Pcaml Quotation Spretty -CAMLP4_INTF = "{OTOP}utils:config.cmi" "{OTOP}utils:warnings.cmi" ¶ - "{OTOP}parsing:asttypes.cmi" "{OTOP}parsing:location.cmi" ¶ - "{OTOP}parsing:longident.cmi" "{OTOP}parsing:parsetree.cmi" ¶ - ast2pt.cmo mLast.cmi pcaml.cmi spretty.cmi ¶ - quotation.cmi -CAMLP4_OBJS = ::boot:stdpp.cmo ::boot:token.cmo ::boot:plexer.cmo ¶ - ::boot:gramext.cmo ::boot:grammar.cmo ::boot:extfold.cmo ::boot:extfun.cmo ¶ - ::boot:fstream.cmo "{OTOP}utils:config.cmo" ¶ - quotation.cmo ast2pt.cmo spretty.cmo reloc.cmo pcaml.cmo ¶ - argl.cmo crc.cmo -OBJS = ::odyl:odyl.cma camlp4.cma -XOBJS = camlp4.cmxa -CAMLP4M = - -CAMLP4 = camlp4 - -all Ä {CAMLP4} - -{CAMLP4} Ä {OBJS} ::odyl:odyl.cmo - {OCAMLC} {OBJS} {CAMLP4M} ::odyl:odyl.cmo -linkall -o {CAMLP4} - -camlp4.cma Ä {CAMLP4_OBJS} - {OCAMLC} {LINKFLAGS} {CAMLP4_OBJS} -a -o camlp4.cma - -clean ÄÄ - delete -i {CAMLP4} - -{dependrule} - -promote Ä - duplicate -y {CAMLP4} ::boot: - -compare Ä - for i in {CAMLP4} - equal -s {i} ::boot:{i} || exit 1 - end - -install Ä - (newfolder "{BINDIR}" || set status 0) ³ dev:null - duplicate -y {CAMLP4} "{BINDIR}" - duplicate -y mLast.mli quotation.mli pcaml.mli spretty.mli "{P4LIBDIR}" - duplicate -y mLast.cmi quotation.cmi ast2pt.cmi pcaml.cmi spretty.cmi ¶ - "{P4LIBDIR}" - duplicate -y camlp4.cma "{P4LIBDIR}" - -{defrules} diff --git a/camlp4/camlp4/Makefile.Mac.depend b/camlp4/camlp4/Makefile.Mac.depend deleted file mode 100644 index 3665195f77..0000000000 --- a/camlp4/camlp4/Makefile.Mac.depend +++ /dev/null @@ -1,15 +0,0 @@ -pcaml.cmiÄ mLast.cmi spretty.cmi -quotation.cmiÄ mLast.cmi -reloc.cmiÄ mLast.cmi -argl.cmoÄ ast2pt.cmo mLast.cmi pcaml.cmi -argl.cmxÄ ast2pt.cmx mLast.cmi pcaml.cmx -ast2pt.cmoÄ mLast.cmi -ast2pt.cmxÄ mLast.cmi -pcaml.cmoÄ ast2pt.cmo mLast.cmi quotation.cmi reloc.cmi spretty.cmi pcaml.cmi -pcaml.cmxÄ ast2pt.cmx mLast.cmi quotation.cmx reloc.cmx spretty.cmx pcaml.cmi -quotation.cmoÄ mLast.cmi quotation.cmi -quotation.cmxÄ mLast.cmi quotation.cmi -reloc.cmoÄ mLast.cmi reloc.cmi -reloc.cmxÄ mLast.cmi reloc.cmi -spretty.cmoÄ spretty.cmi -spretty.cmxÄ spretty.cmi diff --git a/camlp4/camlp4/argl.ml b/camlp4/camlp4/argl.ml deleted file mode 100644 index 8880f07fd1..0000000000 --- a/camlp4/camlp4/argl.ml +++ /dev/null @@ -1,424 +0,0 @@ -(* camlp4r q_MLast.cmo *) -(* $Id$ *) - -open Printf; - -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 rec parse_arg s sl = - fun - [ [(name, action, _) :: spec_list] -> - 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 _ -> parse_arg s sl spec_list ] - else parse_arg s sl spec_list - | [] -> None ] -; - -value rec parse_aux spec_list anon_fun = - fun - [ [] -> [] - | [s :: sl] -> - if String.length s > 1 && s.[0] = '-' then - match parse_arg s sl spec_list with - [ Some sl -> parse_aux spec_list anon_fun sl - | None -> [s :: parse_aux spec_list anon_fun sl] ] - else do { (anon_fun s : unit); parse_aux spec_list anon_fun sl } ] -; - -value loc_fmt = - match Sys.os_type with - [ "MacOS" -> - format_of_string "File \"%s\"; line %d; characters %d to %d\n### " - | _ -> - format_of_string "File \"%s\", line %d, characters %d-%d:\n" ] -; - -value print_location loc = - if Pcaml.input_file.val <> "-" then - let (fname, line, bp, ep) = Stdpp.line_of_loc Pcaml.input_file.val loc in - eprintf loc_fmt Pcaml.input_file.val line bp ep - else eprintf "At location %d-%d\n" (fst loc) (snd loc) -; - -value print_warning loc s = - do { print_location loc; eprintf "%s\n" s } -; - -value rec parse_file pa getdir useast = - let name = Pcaml.input_file.val in - do { - Pcaml.warning.val := print_warning; - let ic = if name = "-" then stdin else open_in_bin name in - let cs = Stream.of_channel ic in - let clear () = if name = "-" then () else close_in ic in - let phr = - try - loop () where rec loop () = - let (pl, stopped_at_directive) = pa cs in - if stopped_at_directive then - let pl = - let rpl = List.rev pl in - match getdir rpl with - [ Some x -> - match x with - [ (loc, "load", Some <:expr< $str:s$ >>) -> - do { Odyl_main.loadfile s; pl } - | (loc, "directory", Some <:expr< $str:s$ >>) -> - do { Odyl_main.directory s; pl } - | (loc, "use", Some <:expr< $str:s$ >>) -> - List.rev_append rpl - [(useast loc s (use_file pa getdir useast s), loc)] - | (loc, _, _) -> - Stdpp.raise_with_loc loc (Stream.Error "bad directive") ] - | None -> pl ] - in - pl @ loop () - else pl - with x -> - do { clear (); raise x } - in - clear (); - phr - } -and use_file pa getdir useast s = - let clear = - let v_input_file = Pcaml.input_file.val in - fun () -> Pcaml.input_file.val := v_input_file - in - do { - Pcaml.input_file.val := s; - try - let r = parse_file pa getdir useast in - do { clear (); r } - with e -> - do { clear (); raise e } - } -; - -value process pa pr getdir useast = - pr (parse_file pa getdir useast); - - -value gind = - fun - [ [(MLast.SgDir loc n dp, _) :: _] -> Some (loc, n, dp) - | _ -> None ] -; - -value gimd = - fun - [ [(MLast.StDir loc n dp, _) :: _] -> Some (loc, n, dp) - | _ -> None ] -; - -value usesig loc fname ast = MLast.SgUse loc fname ast; -value usestr loc fname ast = MLast.StUse loc fname ast; - -value process_intf () = - process Pcaml.parse_interf.val Pcaml.print_interf.val gind usesig; -value process_impl () = - process Pcaml.parse_implem.val Pcaml.print_implem.val gimd usestr; - -type file_kind = - [ Intf - | Impl ] -; -value file_kind = ref Intf; -value file_kind_of_name name = - if Filename.check_suffix name ".mli" then Intf - else if Filename.check_suffix name ".ml" then Impl - else raise (Arg.Bad ("don't know what to do with " ^ name)) -; - -value print_version () = - do { - eprintf "Camlp4 version %s\n" Pcaml.version; flush stderr; exit 0 - } -; - -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 (13 - String.length key - String.length p)) ' ' - in - p ^ tab ^ s -; - -value make_symlist l = - match l with - [ [] -> "" - | [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 make_symlist l = - match l with - [ [] -> "" - | [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 usage ini_sl ext_sl = - do { - eprintf "\ -Usage: camlp4 [load-options] [--] [other-options] -Load options: - -I directory Add directory in search patch for object files. - -where Print camlp4 library directory and exit. - -nolib No automatic search for object files in library directory. - Load this file in Camlp4 core. -Other options: - Parse this file.\n"; - 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.\n" ]; - if ext_sl <> [] then do { - eprintf "Options added by loaded object files:\n"; - print_usage_list ext_sl; - } - else (); - } -; - -value warn_noassert () = - do { - eprintf "\ -camlp4 warning: option -noassert is obsolete -You should give the -noassert option to the ocaml compiler instead. -"; - } -; - -value initial_spec_list = - [("-intf", - Arg.String - (fun x -> do { file_kind.val := Intf; Pcaml.input_file.val := x }), - " Parse as an interface, whatever its extension."); - ("-impl", - Arg.String - (fun x -> do { file_kind.val := Impl; Pcaml.input_file.val := x }), - " Parse as an implementation, whatever its extension."); - ("-unsafe", Arg.Set Ast2pt.fast, - "Generate unsafe accesses to array and strings."); - ("-noassert", Arg.Unit warn_noassert, - "Obsolete, do not use this option."); - ("-verbose", Arg.Set Grammar.error_verbose, - "More verbose in parsing errors."); - ("-loc", Arg.String (fun x -> Stdpp.loc_name.val := x), - " Name of the location variable (default: " ^ Stdpp.loc_name.val ^ - ")"); - ("-QD", Arg.String (fun x -> Pcaml.quotation_dump_file.val := Some x), - " Dump quotation expander result in case of syntax error."); - ("-o", Arg.String (fun x -> Pcaml.output_file.val := Some x), - " Output on instead of standard output."); - ("-v", Arg.Unit print_version, - "Print Camlp4 version and exit.")] -; - -value anon_fun x = - do { Pcaml.input_file.val := x; file_kind.val := file_kind_of_name x } -; - -value parse spec_list anon_fun remaining_args = - let spec_list = - Sort.list (fun (k1, _, _) (k2, _, _) -> k1 >= k2) spec_list - in - try parse_aux spec_list anon_fun remaining_args with - [ Arg.Bad s -> - do { - eprintf "Error: %s\n" s; - eprintf "Use option -help for usage\n"; - flush stderr; - exit 2 - } ] -; - -value remaining_args = - let rec loop l i = - if i == Array.length Sys.argv then l else loop [Sys.argv.(i) :: l] (i + 1) - in - List.rev (loop [] (Arg.current.val + 1)) -; - -value report_error = - fun - [ Odyl_main.Error fname msg -> - do { - Format.print_string "Error while loading \""; - Format.print_string fname; - Format.print_string "\": "; - Format.print_string msg - } - | exc -> Pcaml.report_error exc ] -; - -value go () = - let ext_spec_list = Pcaml.arg_spec_list () in - let arg_spec_list = initial_spec_list @ ext_spec_list in - do { - match parse arg_spec_list anon_fun remaining_args with - [ [] -> () - | ["-help" :: sl] -> do { usage initial_spec_list ext_spec_list; exit 0 } - | [s :: sl] -> - do { - eprintf "%s: unknown or misused option\n" s; - eprintf "Use option -help for usage\n"; - exit 2 - } ]; - try - if Pcaml.input_file.val <> "" then - match file_kind.val with - [ Intf -> process_intf () - | Impl -> process_impl () ] - else () - with exc -> - do { - Format.set_formatter_out_channel stderr; - Format.open_vbox 0; - let exc = - match exc with - [ Stdpp.Exc_located (bp, ep) exc -> - do { print_location (bp, ep); exc } - | _ -> exc ] - in - report_error exc; - Format.close_box (); - Format.print_newline (); - exit 2 - } - } -; - -Odyl_main.name.val := "camlp4"; -Odyl_main.go.val := go; diff --git a/camlp4/camlp4/ast2pt.ml b/camlp4/camlp4/ast2pt.ml deleted file mode 100644 index 09b2e037b3..0000000000 --- a/camlp4/camlp4/ast2pt.ml +++ /dev/null @@ -1,867 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -open Stdpp; -open MLast; -open Parsetree; -open Longident; -open Asttypes; - -value fast = ref False; -value no_constructors_arity = ref False; - -value get_tag x = - if Obj.is_block (Obj.repr x) then Obj.tag (Obj.repr x) else Obj.magic x -; - -value error loc str = raise_with_loc loc (Failure str); - -value char_of_char_token loc s = - try Token.eval_char s with [ Failure _ as exn -> raise_with_loc loc exn ] -; - -value string_of_string_token loc s = - try Token.eval_string loc s - with [ Failure _ as exn -> raise_with_loc loc exn ] -; - -value glob_fname = ref ""; - -value mkloc (bp, ep) = - let loc_at n = { - Lexing.pos_fname = glob_fname.val; - Lexing.pos_lnum = 1; (* ddr met -1 ici ??? *) - Lexing.pos_bol = 0; - Lexing.pos_cnum = n - } - in - {Location.loc_start = loc_at bp; - Location.loc_end = loc_at ep; - Location.loc_ghost = False} (* ddr met: bp = 0 && ep = 0 *) -; - -value mkghloc (bp, ep) = - let loc_at n = { - Lexing.pos_fname = ""; - Lexing.pos_lnum = 1; - Lexing.pos_bol = 0; - Lexing.pos_cnum = n - } - in - {Location.loc_start = loc_at bp; - Location.loc_end = loc_at ep; - Location.loc_ghost = True} -; - -value mktyp loc d = {ptyp_desc = d; ptyp_loc = mkloc loc}; -value mkpat loc d = {ppat_desc = d; ppat_loc = mkloc loc}; -value mkghpat loc d = {ppat_desc = d; ppat_loc = mkghloc loc}; -value mkexp loc d = {pexp_desc = d; pexp_loc = mkloc loc}; -value mkmty loc d = {pmty_desc = d; pmty_loc = mkloc loc}; -value mksig loc d = {psig_desc = d; psig_loc = mkloc loc}; -value mkmod loc d = {pmod_desc = d; pmod_loc = mkloc loc}; -value mkstr loc d = {pstr_desc = d; pstr_loc = mkloc loc}; -value mkfield loc d = {pfield_desc = d; pfield_loc = mkloc loc}; -value mkcty loc d = {pcty_desc = d; pcty_loc = mkloc loc}; -value mkpcl loc d = {pcl_desc = d; pcl_loc = mkloc loc}; -value mkpolytype t = - match t with - [ TyPol _ _ _ -> t - | _ -> TyPol (MLast.loc_of_ctyp t) [] t ] -; - -value lident s = Lident s; -value ldot l s = Ldot l s; - -value conv_con = - let t = Hashtbl.create 73 in - do { - List.iter (fun (s, s') -> Hashtbl.add t s s') - [("True", "true"); ("False", "false"); (" True", "True"); - (" False", "False")]; - fun s -> try Hashtbl.find t s with [ Not_found -> s ] - } -; - -value conv_lab = - let t = Hashtbl.create 73 in - do { - List.iter (fun (s, s') -> Hashtbl.add t s s') [("val", "contents")]; - fun s -> try Hashtbl.find t s with [ Not_found -> s ] - } -; - -value array_function str name = - ldot (lident str) (if fast.val then "unsafe_" ^ name else name) -; - -value mkrf = - fun - [ True -> Recursive - | False -> Nonrecursive ] -; - -value mkli s = - loop (fun s -> lident s) where rec loop f = - fun - [ [i :: il] -> loop (fun s -> ldot (f i) s) il - | [] -> f s ] -; - -value long_id_of_string_list loc sl = - match List.rev sl with - [ [] -> error loc "bad ast" - | [s :: sl] -> mkli s (List.rev sl) ] -; - -value rec ctyp_fa al = - fun - [ TyApp _ f a -> ctyp_fa [a :: al] f - | f -> (f, al) ] -; - -value rec ctyp_long_id = - fun - [ TyAcc _ m (TyLid _ s) -> - let (is_cls, li) = ctyp_long_id m in - (is_cls, ldot li s) - | TyAcc _ m (TyUid _ s) -> - let (is_cls, li) = ctyp_long_id m in - (is_cls, ldot li s) - | TyApp _ m1 m2 -> - let (is_cls, li1) = ctyp_long_id m1 in - let (_, li2) = ctyp_long_id m2 in - (is_cls, Lapply li1 li2) - | TyUid _ s -> (False, lident s) - | TyLid _ s -> (False, lident s) - | TyCls loc sl -> (True, long_id_of_string_list loc sl) - | t -> error (loc_of_ctyp t) "incorrect type" ] -; - -value rec ctyp = - fun - [ TyAcc loc _ _ as f -> - let (is_cls, li) = ctyp_long_id f in - if is_cls then mktyp loc (Ptyp_class li [] []) - else mktyp loc (Ptyp_constr li []) - | TyAli loc t1 t2 -> - let (t, i) = - match (t1, t2) with - [ (t, TyQuo _ s) -> (t, s) - | (TyQuo _ s, t) -> (t, s) - | _ -> error loc "incorrect alias type" ] - in - mktyp loc (Ptyp_alias (ctyp t) i) - | TyAny loc -> mktyp loc Ptyp_any - | TyApp loc _ _ as f -> - let (f, al) = ctyp_fa [] f in - let (is_cls, li) = ctyp_long_id f in - if is_cls then mktyp loc (Ptyp_class li (List.map ctyp al) []) - else mktyp loc (Ptyp_constr li (List.map ctyp al)) - | TyArr loc (TyLab loc1 lab t1) t2 -> - mktyp loc (Ptyp_arrow lab (ctyp t1) (ctyp t2)) - | TyArr loc (TyOlb loc1 lab t1) t2 -> - let t1 = TyApp loc1 (TyLid loc1 "option") t1 in - mktyp loc (Ptyp_arrow ("?" ^ lab) (ctyp t1) (ctyp t2)) - | TyArr loc t1 t2 -> mktyp loc (Ptyp_arrow "" (ctyp t1) (ctyp t2)) - | TyObj loc fl v -> mktyp loc (Ptyp_object (meth_list loc fl v)) - | TyCls loc id -> - mktyp loc (Ptyp_class (long_id_of_string_list loc id) [] []) - | TyLab loc _ _ -> error loc "labelled type not allowed here" - | TyLid loc s -> mktyp loc (Ptyp_constr (lident s) []) - | TyMan loc _ _ -> error loc "manifest type not allowed here" - | TyOlb loc lab _ -> error loc "labelled type not allowed here" - | TyPol loc pl t -> mktyp loc (Ptyp_poly pl (ctyp t)) - | TyQuo loc s -> mktyp loc (Ptyp_var s) - | TyRec loc _ _ -> error loc "record type not allowed here" - | TySum loc _ _ -> error loc "sum type not allowed here" - | TyTup loc tl -> mktyp loc (Ptyp_tuple (List.map ctyp tl)) - | TyUid loc s -> mktyp loc (Ptyp_constr (lident s) []) - | TyVrn loc catl ool -> - let catl = - List.map - (fun - [ RfTag c a t -> Rtag c a (List.map ctyp t) - | RfInh t -> Rinherit (ctyp t) ]) - catl - in - let (clos, sl) = - match ool with - [ None -> (True, None) - | Some None -> (False, None) - | Some (Some sl) -> (True, Some sl) ] - in - mktyp loc (Ptyp_variant catl clos sl) ] -and meth_list loc fl v = - match fl with - [ [] -> if v then [mkfield loc Pfield_var] else [] - | [(lab, t) :: fl] -> - [mkfield loc (Pfield lab (ctyp (mkpolytype t))) :: meth_list loc fl v] ] -; - -value mktype loc tl cl tk tm = - let (params, variance) = List.split tl in - {ptype_params = params; ptype_cstrs = cl; ptype_kind = tk; - ptype_manifest = tm; ptype_loc = mkloc loc; ptype_variance = variance} -; -value mkmutable m = if m then Mutable else Immutable; -value mkprivate m = if m then Private else Public; -value mktrecord (_, n, m, t) = (n, mkmutable m, ctyp (mkpolytype t)); -value mkvariant (_, c, tl) = (c, List.map ctyp tl); -value type_decl tl cl = - fun - [ TyMan loc t (TyRec _ pflag ltl) -> - mktype loc tl cl (Ptype_record (List.map mktrecord ltl) (mkprivate pflag)) - (Some (ctyp t)) - | TyMan loc t (TySum _ pflag ctl) -> - mktype loc tl cl (Ptype_variant (List.map mkvariant ctl) (mkprivate pflag)) - (Some (ctyp t)) - | TyRec loc pflag ltl -> - mktype loc tl cl (Ptype_record (List.map mktrecord ltl) (mkprivate pflag)) None - | TySum loc pflag ctl -> - mktype loc tl cl (Ptype_variant (List.map mkvariant ctl) (mkprivate pflag)) None - | t -> - let m = - match t with - [ TyQuo _ s -> if List.mem_assoc s tl then Some (ctyp t) else None - | _ -> Some (ctyp t) ] - in - mktype (loc_of_ctyp t) tl cl Ptype_abstract m ] -; - -value mkvalue_desc t p = {pval_type = ctyp t; pval_prim = p}; - -value option f = - fun - [ Some x -> Some (f x) - | None -> None ] -; - -value expr_of_lab loc lab = - fun - [ Some e -> e - | None -> ExLid loc lab ] -; - -value patt_of_lab loc lab = - fun - [ Some p -> p - | None -> PaLid loc lab ] -; - -value paolab loc lab peoo = - let lab = - match (lab, peoo) with - [ ("", Some (PaLid _ i | PaTyc _ (PaLid _ i) _, _)) -> i - | ("", _) -> error loc "bad ast" - | _ -> lab ] - in - let (p, eo) = - match peoo with - [ Some peo -> peo - | None -> (PaLid loc lab, None) ] - in - (lab, p, eo) -; - -value rec same_type_expr ct ce = - match (ct, ce) with - [ (TyLid _ s1, ExLid _ s2) -> s1 = s2 - | (TyUid _ s1, ExUid _ s2) -> s1 = s2 - | (TyAcc _ t1 t2, ExAcc _ e1 e2) -> - same_type_expr t1 e1 && same_type_expr t2 e2 - | _ -> False ] -; - -value rec common_id loc t e = - match (t, e) with - [ (TyLid _ s1, ExLid _ s2) when s1 = s2 -> lident s1 - | (TyUid _ s1, ExUid _ s2) when s1 = s2 -> lident s1 - | (TyAcc _ t1 (TyLid _ s1), ExAcc _ e1 (ExLid _ s2)) when s1 = s2 -> - ldot (common_id loc t1 e1) s1 - | (TyAcc _ t1 (TyUid _ s1), ExAcc _ e1 (ExUid _ s2)) when s1 = s2 -> - ldot (common_id loc t1 e1) s1 - | _ -> error loc "this expression should repeat the class id inherited" ] -; - -value rec type_id loc t = - match t with - [ TyLid _ s1 -> lident s1 - | TyUid _ s1 -> lident s1 - | TyAcc _ t1 (TyLid _ s1) -> ldot (type_id loc t1) s1 - | TyAcc _ t1 (TyUid _ s1) -> ldot (type_id loc t1) s1 - | _ -> error loc "type identifier expected" ] -; - -value rec module_type_long_id = - fun - [ MtAcc _ m (MtUid _ s) -> ldot (module_type_long_id m) s - | MtAcc _ m (MtLid _ s) -> ldot (module_type_long_id m) s - | MtApp _ m1 m2 -> Lapply (module_type_long_id m1) (module_type_long_id m2) - | MtLid _ s -> lident s - | MtUid _ s -> lident s - | t -> error (loc_of_module_type t) "bad module type long ident" ] -; - -value rec module_expr_long_id = - fun - [ MeAcc _ m (MeUid _ s) -> ldot (module_expr_long_id m) s - | MeUid _ s -> lident s - | t -> error (loc_of_module_expr t) "bad module expr long ident" ] -; - -value mkwithc = - fun - [ WcTyp loc id tpl ct -> - let (params, variance) = List.split tpl in - (long_id_of_string_list loc id, - Pwith_type - {ptype_params = params; ptype_cstrs = []; - ptype_kind = Ptype_abstract; ptype_manifest = Some (ctyp ct); - ptype_loc = mkloc loc; ptype_variance = variance}) - | WcMod loc id m -> - (long_id_of_string_list loc id, Pwith_module (module_expr_long_id m)) ] -; - -value rec patt_fa al = - fun - [ PaApp _ f a -> patt_fa [a :: al] f - | f -> (f, al) ] -; - -value rec deep_mkrangepat loc c1 c2 = - if c1 = c2 then mkghpat loc (Ppat_constant (Const_char c1)) - else - mkghpat loc - (Ppat_or (mkghpat loc (Ppat_constant (Const_char c1))) - (deep_mkrangepat loc (Char.chr (Char.code c1 + 1)) c2)) -; - -value rec mkrangepat loc c1 c2 = - if c1 > c2 then mkrangepat loc c2 c1 - else if c1 = c2 then mkpat loc (Ppat_constant (Const_char c1)) - else - mkpat loc - (Ppat_or (mkghpat loc (Ppat_constant (Const_char c1))) - (deep_mkrangepat loc (Char.chr (Char.code c1 + 1)) c2)) -; - -value rec patt_long_id il = - fun - [ PaAcc _ p (PaUid _ i) -> patt_long_id [i :: il] p - | p -> (p, il) ] -; - -value rec patt_label_long_id = - fun - [ PaAcc _ m (PaLid _ s) -> ldot (patt_label_long_id m) (conv_lab s) - | PaAcc _ m (PaUid _ s) -> ldot (patt_label_long_id m) s - | PaUid _ s -> lident s - | PaLid _ s -> lident (conv_lab s) - | p -> error (loc_of_patt p) "bad label" ] -; - -value rec patt = - fun - [ PaAcc loc p1 p2 -> - let p = - match patt_long_id [] p1 with - [ (PaUid _ i, il) -> - match p2 with - [ PaUid _ s -> - Ppat_construct (mkli (conv_con s) [i :: il]) None - (not no_constructors_arity.val) - | _ -> error (loc_of_patt p2) "uppercase identifier expected" ] - | _ -> error (loc_of_patt p2) "bad pattern" ] - in - mkpat loc p - | PaAli loc p1 p2 -> - let (p, i) = - match (p1, p2) with - [ (p, PaLid _ s) -> (p, s) - | (PaLid _ s, p) -> (p, s) - | _ -> error loc "incorrect alias pattern" ] - in - mkpat loc (Ppat_alias (patt p) i) - | PaAnt _ p -> patt p - | PaAny loc -> mkpat loc Ppat_any - | PaApp loc _ _ as f -> - let (f, al) = patt_fa [] f in - let al = List.map patt al in - match (patt f).ppat_desc with - [ Ppat_construct li None _ -> - if no_constructors_arity.val then - let a = - match al with - [ [a] -> a - | _ -> mkpat loc (Ppat_tuple al) ] - in - mkpat loc (Ppat_construct li (Some a) False) - else - let a = mkpat loc (Ppat_tuple al) in - mkpat loc (Ppat_construct li (Some a) True) - | Ppat_variant s None -> - let a = - match al with - [ [a] -> a - | _ -> mkpat loc (Ppat_tuple al) ] - in - mkpat loc (Ppat_variant s (Some a)) - | _ -> - error (loc_of_patt f) - "this is not a constructor, it cannot be applied in a pattern" ] - | PaArr loc pl -> mkpat loc (Ppat_array (List.map patt pl)) - | PaChr loc s -> - mkpat loc (Ppat_constant (Const_char (char_of_char_token loc s))) - | PaInt loc s -> mkpat loc (Ppat_constant (Const_int (int_of_string s))) - | PaInt32 loc s -> mkpat loc (Ppat_constant (Const_int32 (Int32.of_string s))) - | PaInt64 loc s -> mkpat loc (Ppat_constant (Const_int64 (Int64.of_string s))) - | PaNativeInt loc s -> mkpat loc (Ppat_constant (Const_nativeint (Nativeint.of_string s))) - | PaFlo loc s -> mkpat loc (Ppat_constant (Const_float s)) - | PaLab loc _ _ -> error loc "labeled pattern not allowed here" - | PaLid loc s -> mkpat loc (Ppat_var s) - | PaOlb loc _ _ -> error loc "labeled pattern not allowed here" - | PaOrp loc p1 p2 -> mkpat loc (Ppat_or (patt p1) (patt p2)) - | PaRng loc p1 p2 -> - match (p1, p2) with - [ (PaChr loc1 c1, PaChr loc2 c2) -> - let c1 = char_of_char_token loc1 c1 in - let c2 = char_of_char_token loc2 c2 in - mkrangepat loc c1 c2 - | _ -> error loc "range pattern allowed only for characters" ] - | PaRec loc lpl -> mkpat loc (Ppat_record (List.map mklabpat lpl)) - | PaStr loc s -> - mkpat loc (Ppat_constant (Const_string (string_of_string_token loc s))) - | PaTup loc pl -> mkpat loc (Ppat_tuple (List.map patt pl)) - | PaTyc loc p t -> mkpat loc (Ppat_constraint (patt p) (ctyp t)) - | PaTyp loc sl -> mkpat loc (Ppat_type (long_id_of_string_list loc sl)) - | PaUid loc s -> - let ca = not no_constructors_arity.val in - mkpat loc (Ppat_construct (lident (conv_con s)) None ca) - | PaVrn loc s -> mkpat loc (Ppat_variant s None) ] -and mklabpat (lab, p) = (patt_label_long_id lab, patt p); - -value rec expr_fa al = - fun - [ ExApp _ f a -> expr_fa [a :: al] f - | f -> (f, al) ] -; - -value rec class_expr_fa al = - fun - [ CeApp _ ce a -> class_expr_fa [a :: al] ce - | ce -> (ce, al) ] -; - -value rec sep_expr_acc l = - fun - [ ExAcc _ e1 e2 -> sep_expr_acc (sep_expr_acc l e2) e1 - | ExUid ((bp, _) as loc) s as e -> - match l with - [ [] -> [(loc, [], e)] - | [((_, ep), sl, e) :: l] -> [((bp, ep), [s :: sl], e) :: l] ] - | e -> [(loc_of_expr e, [], e) :: l] ] -; - -(* -value expr_label_long_id e = - match sep_expr_acc [] e with - [ [(_, ml, ExLid _ s)] -> mkli (conv_lab s) ml - | _ -> error (loc_of_expr e) "invalid label" ] -; -*) - -value class_info class_expr ci = - let (params, variance) = List.split (snd ci.ciPrm) in - {pci_virt = if ci.ciVir then Virtual else Concrete; - pci_params = (params, mkloc (fst ci.ciPrm)); pci_name = ci.ciNam; - pci_expr = class_expr ci.ciExp; pci_loc = mkloc ci.ciLoc; - pci_variance = variance} -; - -value apply_with_var v x f = - let vx = v.val in - try - do { - v.val := x; - let r = f (); - v.val := vx; - r - } - with e -> do { v.val := vx; raise e } -; - -value rec expr = - fun - [ ExAcc loc x (ExLid _ "val") -> - mkexp loc - (Pexp_apply (mkexp loc (Pexp_ident (Lident "!"))) [("", expr x)]) - | ExAcc loc _ _ as e -> - let (e, l) = - match sep_expr_acc [] e with - [ [(loc, ml, ExUid _ s) :: l] -> - let ca = not no_constructors_arity.val in - (mkexp loc (Pexp_construct (mkli s ml) None ca), l) - | [(loc, ml, ExLid _ s) :: l] -> - (mkexp loc (Pexp_ident (mkli s ml)), l) - | [(_, [], e) :: l] -> (expr e, l) - | _ -> error loc "bad ast" ] - in - let (_, e) = - List.fold_left - (fun ((bp, _), e1) ((_, ep), ml, e2) -> - match e2 with - [ ExLid _ s -> - let loc = (bp, ep) in - (loc, mkexp loc (Pexp_field e1 (mkli (conv_lab s) ml))) - | _ -> error (loc_of_expr e2) "lowercase identifier expected" ]) - (loc, e) l - in - e - | ExAnt _ e -> expr e - | ExApp loc _ _ as f -> - let (f, al) = expr_fa [] f in - let al = List.map label_expr al in - match (expr f).pexp_desc with - [ Pexp_construct li None _ -> - let al = List.map snd al in - if no_constructors_arity.val then - let a = - match al with - [ [a] -> a - | _ -> mkexp loc (Pexp_tuple al) ] - in - mkexp loc (Pexp_construct li (Some a) False) - else - let a = mkexp loc (Pexp_tuple al) in - mkexp loc (Pexp_construct li (Some a) True) - | Pexp_variant s None -> - let al = List.map snd al in - let a = - match al with - [ [a] -> a - | _ -> mkexp loc (Pexp_tuple al) ] - in - mkexp loc (Pexp_variant s (Some a)) - | _ -> mkexp loc (Pexp_apply (expr f) al) ] - | ExAre loc e1 e2 -> - mkexp loc - (Pexp_apply (mkexp loc (Pexp_ident (array_function "Array" "get"))) - [("", expr e1); ("", expr e2)]) - | ExArr loc el -> mkexp loc (Pexp_array (List.map expr el)) - | ExAsf loc -> mkexp loc Pexp_assertfalse - | ExAss loc e v -> - let e = - match e with - [ ExAcc loc x (ExLid _ "val") -> - Pexp_apply (mkexp loc (Pexp_ident (Lident ":="))) - [("", expr x); ("", expr v)] - | ExAcc loc _ _ -> - match (expr e).pexp_desc with - [ Pexp_field e lab -> Pexp_setfield e lab (expr v) - | _ -> error loc "bad record access" ] - | ExAre _ e1 e2 -> - Pexp_apply (mkexp loc (Pexp_ident (array_function "Array" "set"))) - [("", expr e1); ("", expr e2); ("", expr v)] - | ExLid _ lab -> Pexp_setinstvar lab (expr v) - | ExSte _ e1 e2 -> - Pexp_apply - (mkexp loc (Pexp_ident (array_function "String" "set"))) - [("", expr e1); ("", expr e2); ("", expr v)] - | _ -> error loc "bad left part of assignment" ] - in - mkexp loc e - | ExAsr loc e -> mkexp loc (Pexp_assert (expr e)) - | ExChr loc s -> - mkexp loc (Pexp_constant (Const_char (char_of_char_token loc s))) - | ExCoe loc e t1 t2 -> - mkexp loc (Pexp_constraint (expr e) (option ctyp t1) (Some (ctyp t2))) - | ExFlo loc s -> mkexp loc (Pexp_constant (Const_float s)) - | ExFor loc i e1 e2 df el -> - let e3 = ExSeq loc el in - let df = if df then Upto else Downto in - mkexp loc (Pexp_for i (expr e1) (expr e2) df (expr e3)) - | ExFun loc [(PaLab _ lab po, w, e)] -> - mkexp loc - (Pexp_function lab None - [(patt (patt_of_lab loc lab po), when_expr e w)]) - | ExFun loc [(PaOlb _ lab peoo, w, e)] -> - let (lab, p, eo) = paolab loc lab peoo in - mkexp loc - (Pexp_function ("?" ^ lab) (option expr eo) [(patt p, when_expr e w)]) - | ExFun loc pel -> mkexp loc (Pexp_function "" None (List.map mkpwe pel)) - | ExIfe loc e1 e2 e3 -> - mkexp loc (Pexp_ifthenelse (expr e1) (expr e2) (Some (expr e3))) - | ExInt loc s -> mkexp loc (Pexp_constant (Const_int (int_of_string s))) - | ExInt32 loc s -> mkexp loc (Pexp_constant (Const_int32 (Int32.of_string s))) - | ExInt64 loc s -> mkexp loc (Pexp_constant (Const_int64 (Int64.of_string s))) - | ExNativeInt loc s -> mkexp loc (Pexp_constant (Const_nativeint (Nativeint.of_string s))) - | ExLab loc _ _ -> error loc "labeled expression not allowed here" - | ExLaz loc e -> mkexp loc (Pexp_lazy (expr e)) - | ExLet loc rf pel e -> - mkexp loc (Pexp_let (mkrf rf) (List.map mkpe pel) (expr e)) - | ExLid loc s -> mkexp loc (Pexp_ident (lident s)) - | ExLmd loc i me e -> mkexp loc (Pexp_letmodule i (module_expr me) (expr e)) - | ExMat loc e pel -> mkexp loc (Pexp_match (expr e) (List.map mkpwe pel)) - | ExNew loc id -> mkexp loc (Pexp_new (long_id_of_string_list loc id)) - | ExOlb loc _ _ -> error loc "labeled expression not allowed here" - | ExOvr loc iel -> mkexp loc (Pexp_override (List.map mkideexp iel)) - | ExRec loc lel eo -> - if lel = [] then error loc "empty record" - else - let eo = - match eo with - [ Some e -> Some (expr e) - | None -> None ] - in - mkexp loc (Pexp_record (List.map mklabexp lel) eo) - | ExSeq loc el -> - let rec loop = - fun - [ [] -> expr (ExUid loc "()") - | [e] -> expr e - | [e :: el] -> - let loc = (fst (loc_of_expr e), snd loc) in - mkexp loc (Pexp_sequence (expr e) (loop el)) ] - in - loop el - | ExSnd loc e s -> mkexp loc (Pexp_send (expr e) s) - | ExSte loc e1 e2 -> - mkexp loc - (Pexp_apply (mkexp loc (Pexp_ident (array_function "String" "get"))) - [("", expr e1); ("", expr e2)]) - | ExStr loc s -> - mkexp loc (Pexp_constant (Const_string (string_of_string_token loc s))) - | ExTry loc e pel -> mkexp loc (Pexp_try (expr e) (List.map mkpwe pel)) - | ExTup loc el -> mkexp loc (Pexp_tuple (List.map expr el)) - | ExTyc loc e t -> mkexp loc (Pexp_constraint (expr e) (Some (ctyp t)) None) - | ExUid loc s -> - let ca = not no_constructors_arity.val in - mkexp loc (Pexp_construct (lident (conv_con s)) None ca) - | ExVrn loc s -> mkexp loc (Pexp_variant s None) - | ExWhi loc e1 el -> - let e2 = ExSeq loc el in - mkexp loc (Pexp_while (expr e1) (expr e2)) ] -and label_expr = - fun - [ ExLab loc lab eo -> (lab, expr (expr_of_lab loc lab eo)) - | ExOlb loc lab eo -> ("?" ^ lab, expr (expr_of_lab loc lab eo)) - | e -> ("", expr e) ] -and mkpe (p, e) = (patt p, expr e) -and mkpwe (p, w, e) = (patt p, when_expr e w) -and when_expr e = - fun - [ Some w -> mkexp (loc_of_expr e) (Pexp_when (expr w) (expr e)) - | None -> expr e ] -and mklabexp (lab, e) = (patt_label_long_id lab, expr e) -and mkideexp (ide, e) = (ide, expr e) -and mktype_decl ((loc, c), tl, td, cl) = - let cl = - List.map - (fun (t1, t2) -> - let loc = (fst (loc_of_ctyp t1), snd (loc_of_ctyp t2)) in - (ctyp t1, ctyp t2, mkloc loc)) - cl - in - (c, type_decl tl cl td) -and module_type = - fun - [ MtAcc loc _ _ as f -> mkmty loc (Pmty_ident (module_type_long_id f)) - | MtApp loc _ _ as f -> mkmty loc (Pmty_ident (module_type_long_id f)) - | MtFun loc n nt mt -> - mkmty loc (Pmty_functor n (module_type nt) (module_type mt)) - | MtLid loc s -> mkmty loc (Pmty_ident (lident s)) - | MtQuo loc _ -> error loc "abstract module type not allowed here" - | MtSig loc sl -> - mkmty loc (Pmty_signature (List.fold_right sig_item sl [])) - | MtUid loc s -> mkmty loc (Pmty_ident (lident s)) - | MtWit loc mt wcl -> - mkmty loc (Pmty_with (module_type mt) (List.map mkwithc wcl)) ] -and sig_item s l = - match s with - [ SgCls loc cd -> - [mksig loc (Psig_class (List.map (class_info class_type) cd)) :: l] - | SgClt loc ctd -> - [mksig loc (Psig_class_type (List.map (class_info class_type) ctd)) :: - l] - | SgDcl loc sl -> List.fold_right sig_item sl l - | SgDir loc _ _ -> l - | SgExc loc n tl -> [mksig loc (Psig_exception n (List.map ctyp tl)) :: l] - | SgExt loc n t p -> [mksig loc (Psig_value n (mkvalue_desc t p)) :: l] - | SgInc loc mt -> [mksig loc (Psig_include (module_type mt)) :: l] - | SgMod loc n mt -> [mksig loc (Psig_module n (module_type mt)) :: l] - | SgRecMod loc nmts -> - [mksig loc (Psig_recmodule (List.map (fun (n,mt) -> (n, module_type mt)) nmts)) :: l] - | SgMty loc n mt -> - let si = - match mt with - [ MtQuo _ _ -> Pmodtype_abstract - | _ -> Pmodtype_manifest (module_type mt) ] - in - [mksig loc (Psig_modtype n si) :: l] - | SgOpn loc id -> - [mksig loc (Psig_open (long_id_of_string_list loc id)) :: l] - | SgTyp loc tdl -> [mksig loc (Psig_type (List.map mktype_decl tdl)) :: l] - | SgUse loc fn sl -> - apply_with_var glob_fname fn - (fun () -> List.fold_right (fun (si, _) -> sig_item si) sl l) - | SgVal loc n t -> [mksig loc (Psig_value n (mkvalue_desc t [])) :: l] ] -and module_expr = - fun - [ MeAcc loc _ _ as f -> mkmod loc (Pmod_ident (module_expr_long_id f)) - | MeApp loc me1 me2 -> - mkmod loc (Pmod_apply (module_expr me1) (module_expr me2)) - | MeFun loc n mt me -> - mkmod loc (Pmod_functor n (module_type mt) (module_expr me)) - | MeStr loc sl -> - mkmod loc (Pmod_structure (List.fold_right str_item sl [])) - | MeTyc loc me mt -> - mkmod loc (Pmod_constraint (module_expr me) (module_type mt)) - | MeUid loc s -> mkmod loc (Pmod_ident (lident s)) ] -and str_item s l = - match s with - [ StCls loc cd -> - [mkstr loc (Pstr_class (List.map (class_info class_expr) cd)) :: l] - | StClt loc ctd -> - [mkstr loc (Pstr_class_type (List.map (class_info class_type) ctd)) :: - l] - | StDcl loc sl -> List.fold_right str_item sl l - | StDir loc _ _ -> l - | StExc loc n tl sl -> - let si = - match (tl, sl) with - [ (tl, []) -> Pstr_exception n (List.map ctyp tl) - | ([], sl) -> Pstr_exn_rebind n (long_id_of_string_list loc sl) - | _ -> error loc "bad exception declaration" ] - in - [mkstr loc si :: l] - | StExp loc e -> [mkstr loc (Pstr_eval (expr e)) :: l] - | StExt loc n t p -> [mkstr loc (Pstr_primitive n (mkvalue_desc t p)) :: l] - | StInc loc me -> [mkstr loc (Pstr_include (module_expr me)) :: l] - | StMod loc n me -> [mkstr loc (Pstr_module n (module_expr me)) :: l] - | StRecMod loc nmes -> - [mkstr loc - (Pstr_recmodule - (List.map - (fun (n,mt,me) -> (n, module_type mt, module_expr me)) - nmes)) :: l] - | StMty loc n mt -> [mkstr loc (Pstr_modtype n (module_type mt)) :: l] - | StOpn loc id -> - [mkstr loc (Pstr_open (long_id_of_string_list loc id)) :: l] - | StTyp loc tdl -> [mkstr loc (Pstr_type (List.map mktype_decl tdl)) :: l] - | StUse loc fn sl -> - apply_with_var glob_fname fn - (fun () -> List.fold_right (fun (si, _) -> str_item si) sl l) - | StVal loc rf pel -> - [mkstr loc (Pstr_value (mkrf rf) (List.map mkpe pel)) :: l] ] -and class_type = - fun - [ CtCon loc id tl -> - mkcty loc - (Pcty_constr (long_id_of_string_list loc id) (List.map ctyp tl)) - | CtFun loc (TyLab _ lab t) ct -> - mkcty loc (Pcty_fun lab (ctyp t) (class_type ct)) - | CtFun loc (TyOlb loc1 lab t) ct -> - let t = TyApp loc1 (TyLid loc1 "option") t in - mkcty loc (Pcty_fun ("?" ^ lab) (ctyp t) (class_type ct)) - | CtFun loc t ct -> mkcty loc (Pcty_fun "" (ctyp t) (class_type ct)) - | CtSig loc t_o ctfl -> - let t = - match t_o with - [ Some t -> t - | None -> TyAny loc ] - in - let cil = List.fold_right class_sig_item ctfl [] in - mkcty loc (Pcty_signature (ctyp t, cil)) ] -and class_sig_item c l = - match c with - [ CgCtr loc t1 t2 -> [Pctf_cstr (ctyp t1, ctyp t2, mkloc loc) :: l] - | CgDcl loc cl -> List.fold_right class_sig_item cl l - | CgInh loc ct -> [Pctf_inher (class_type ct) :: l] - | CgMth loc s pf t -> - [Pctf_meth (s, mkprivate pf, ctyp (mkpolytype t), mkloc loc) :: l] - | CgVal loc s b t -> - [Pctf_val (s, mkmutable b, Some (ctyp t), mkloc loc) :: l] - | CgVir loc s b t -> - [Pctf_virt (s, mkprivate b, ctyp (mkpolytype t), mkloc loc) :: l] ] -and class_expr = - fun - [ CeApp loc _ _ as c -> - let (ce, el) = class_expr_fa [] c in - let el = List.map label_expr el in - mkpcl loc (Pcl_apply (class_expr ce) el) - | CeCon loc id tl -> - mkpcl loc - (Pcl_constr (long_id_of_string_list loc id) (List.map ctyp tl)) - | CeFun loc (PaLab _ lab po) ce -> - mkpcl loc - (Pcl_fun lab None (patt (patt_of_lab loc lab po)) (class_expr ce)) - | CeFun loc (PaOlb _ lab peoo) ce -> - let (lab, p, eo) = paolab loc lab peoo in - mkpcl loc - (Pcl_fun ("?" ^ lab) (option expr eo) (patt p) (class_expr ce)) - | CeFun loc p ce -> mkpcl loc (Pcl_fun "" None (patt p) (class_expr ce)) - | CeLet loc rf pel ce -> - mkpcl loc (Pcl_let (mkrf rf) (List.map mkpe pel) (class_expr ce)) - | CeStr loc po cfl -> - let p = - match po with - [ Some p -> p - | None -> PaAny loc ] - in - let cil = List.fold_right class_str_item cfl [] in - mkpcl loc (Pcl_structure (patt p, cil)) - | CeTyc loc ce ct -> - mkpcl loc (Pcl_constraint (class_expr ce) (class_type ct)) ] -and class_str_item c l = - match c with - [ CrCtr loc t1 t2 -> [Pcf_cstr (ctyp t1, ctyp t2, mkloc loc) :: l] - | CrDcl loc cl -> List.fold_right class_str_item cl l - | CrInh loc ce pb -> [Pcf_inher (class_expr ce) pb :: l] - | CrIni loc e -> [Pcf_init (expr e) :: l] - | CrMth loc s b e t -> - let t = option (fun t -> ctyp (mkpolytype t)) t in - let e = mkexp loc (Pexp_poly (expr e) t) in - [Pcf_meth (s, mkprivate b, e, mkloc loc) :: l] - | CrVal loc s b e -> [Pcf_val (s, mkmutable b, expr e, mkloc loc) :: l] - | CrVir loc s b t -> - [Pcf_virt (s, mkprivate b, ctyp (mkpolytype t), mkloc loc) :: l] ] -; - -value interf ast = List.fold_right sig_item ast []; -value implem ast = List.fold_right str_item ast []; - -value directive loc = - fun - [ None -> Pdir_none - | Some (ExStr _ s) -> Pdir_string s - | Some (ExInt _ i) -> Pdir_int (int_of_string i) - | Some (ExUid _ "True") -> Pdir_bool True - | Some (ExUid _ "False") -> Pdir_bool False - | Some e -> - let sl = - loop e where rec loop = - fun - [ ExLid _ i | ExUid _ i -> [i] - | ExAcc _ e (ExLid _ i) | ExAcc _ e (ExUid _ i) -> loop e @ [i] - | e -> raise_with_loc (loc_of_expr e) (Failure "bad ast") ] - in - Pdir_ident (long_id_of_string_list loc sl) ] -; - -value phrase = - fun - [ StDir loc d dp -> Ptop_dir d (directive loc dp) - | si -> Ptop_def (str_item si []) ] -; diff --git a/camlp4/camlp4/ast2pt.mli b/camlp4/camlp4/ast2pt.mli deleted file mode 100644 index 3e7da854f6..0000000000 --- a/camlp4/camlp4/ast2pt.mli +++ /dev/null @@ -1,23 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -value fast : ref bool; -value no_constructors_arity : ref bool; -value mkloc : (int * int) -> Location.t; -value long_id_of_string_list : (int * int) -> list string -> Longident.t; - -value str_item : MLast.str_item -> Parsetree.structure -> Parsetree.structure; -value interf : list MLast.sig_item -> Parsetree.signature; -value implem : list MLast.str_item -> Parsetree.structure; -value phrase : MLast.str_item -> Parsetree.toplevel_phrase; diff --git a/camlp4/camlp4/mLast.mli b/camlp4/camlp4/mLast.mli deleted file mode 100644 index 2d77944318..0000000000 --- a/camlp4/camlp4/mLast.mli +++ /dev/null @@ -1,211 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* Module [MLast]: abstract syntax tree - - This is undocumented because the AST is not supposed to be used - directly; the good usage is to use the quotations representing - these values in concrete syntax (see the Camlp4 documentation). - See also the file q_MLast.ml in Camlp4 sources. *) - -type loc = (int * int); - -type ctyp = - [ TyAcc of loc and ctyp and ctyp - | TyAli of loc and ctyp and ctyp - | TyAny of loc - | TyApp of loc and ctyp and ctyp - | TyArr of loc and ctyp and ctyp - | TyCls of loc and list string - | TyLab of loc and string and ctyp - | TyLid of loc and string - | TyMan of loc and ctyp and ctyp - | TyObj of loc and list (string * ctyp) and bool - | TyOlb of loc and string and ctyp - | TyPol of loc and list string and ctyp - | TyQuo of loc and string - | TyRec of loc and bool and list (loc * string * bool * ctyp) - | TySum of loc and bool and list (loc * string * list ctyp) - | TyTup of loc and list ctyp - | TyUid of loc and string - | TyVrn of loc and list row_field and option (option (list string)) ] -and row_field = - [ RfTag of string and bool and list ctyp - | RfInh of ctyp ] -; - -type class_infos 'a = - { ciLoc : loc; - ciVir : bool; - ciPrm : (loc * list (string * (bool * bool))); - ciNam : string; - ciExp : 'a } -; - -type patt = - [ PaAcc of loc and patt and patt - | PaAli of loc and patt and patt - | PaAnt of loc and patt - | PaAny of loc - | PaApp of loc and patt and patt - | PaArr of loc and list patt - | PaChr of loc and string - | 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 option patt - | PaLid of loc and string - | PaOlb of loc and string and option (patt * option expr) - | PaOrp of loc and patt and patt - | PaRng of loc and patt and patt - | PaRec of loc and list (patt * patt) - | PaStr of loc and string - | PaTup of loc and list patt - | PaTyc of loc and patt and ctyp - | PaTyp of loc and list string - | PaUid of loc and string - | PaVrn of loc and string ] -and expr = - [ ExAcc of loc and expr and expr - | ExAnt of loc and expr - | ExApp of loc and expr and expr - | ExAre of loc and expr and expr - | ExArr of loc and list expr - | ExAsf of loc (* assert False *) - | ExAsr of loc and expr (* assert *) - | ExAss of loc and expr and expr (* assignment *) - | ExChr of loc and string - | ExCoe of loc and expr and option ctyp and ctyp - | ExFlo of loc and string - | ExFor of loc and string and expr and expr and bool and list expr - | ExFun of loc and list (patt * option expr * expr) - | ExIfe of loc and expr and expr and expr - | ExInt of loc and string - | ExInt32 of loc and string - | ExInt64 of loc and string - | ExNativeInt of loc and string - | ExLab of loc and string and option expr - | ExLaz of loc and expr - | ExLet of loc and bool and list (patt * expr) and expr - | ExLid of loc and string - | ExLmd of loc and string and module_expr and expr - | ExMat of loc and expr and list (patt * option expr * expr) - | ExNew of loc and list string - | ExOlb of loc and string and option expr - | ExOvr of loc and list (string * expr) - | ExRec of loc and list (patt * expr) and option expr - | ExSeq of loc and list expr - | ExSnd of loc and expr and string - | ExSte of loc and expr and expr - | ExStr of loc and string - | ExTry of loc and expr and list (patt * option expr * expr) - | ExTup of loc and list expr - | ExTyc of loc and expr and ctyp - | ExUid of loc and string - | ExVrn of loc and string - | ExWhi of loc and expr and list expr ] -and module_type = - [ MtAcc of loc and module_type and module_type - | MtApp of loc and module_type and module_type - | MtFun of loc and string and module_type and module_type - | MtLid of loc and string - | MtQuo of loc and string - | MtSig of loc and list sig_item - | MtUid of loc and string - | MtWit of loc and module_type and list with_constr ] -and sig_item = - [ SgCls of loc and list (class_infos class_type) - | SgClt of loc and list (class_infos class_type) - | SgDcl of loc and list sig_item - | SgDir of loc and string and option expr - | SgExc of loc and string and list ctyp - | SgExt of loc and string and ctyp and list string - | SgInc of loc and module_type - | SgMod of loc and string and module_type - | SgRecMod of loc and list (string * module_type) - | SgMty of loc and string and module_type - | SgOpn of loc and list string - | SgTyp of loc and list type_decl - | SgUse of loc and string and list (sig_item * loc) - | SgVal of loc and string and ctyp ] -and with_constr = - [ WcTyp of loc and list string and list (string * (bool * bool)) and ctyp - | WcMod of loc and list string and module_expr ] -and module_expr = - [ MeAcc of loc and module_expr and module_expr - | MeApp of loc and module_expr and module_expr - | MeFun of loc and string and module_type and module_expr - | MeStr of loc and list str_item - | MeTyc of loc and module_expr and module_type - | MeUid of loc and string ] -and str_item = - [ StCls of loc and list (class_infos class_expr) - | StClt of loc and list (class_infos class_type) - | StDcl of loc and list str_item - | StDir of loc and string and option expr - | StExc of loc and string and list ctyp and list string - | StExp of loc and expr - | StExt of loc and string and ctyp and list string - | StInc of loc and module_expr - | StMod of loc and string and module_expr - | StRecMod of loc and list (string * module_type * module_expr) - | StMty of loc and string and module_type - | StOpn of loc and list string - | StTyp of loc and list type_decl - | StUse of loc and string and list (str_item * loc) - | StVal of loc and bool and list (patt * expr) ] -and type_decl = - ((loc * string) * list (string * (bool * bool)) * ctyp * list (ctyp * ctyp)) -and class_type = - [ CtCon of loc and list string and list ctyp - | CtFun of loc and ctyp and class_type - | CtSig of loc and option ctyp and list class_sig_item ] -and class_sig_item = - [ CgCtr of loc and ctyp and ctyp - | CgDcl of loc and list class_sig_item - | CgInh of loc and class_type - | CgMth of loc and string and bool and ctyp - | CgVal of loc and string and bool and ctyp - | CgVir of loc and string and bool and ctyp ] -and class_expr = - [ CeApp of loc and class_expr and expr - | CeCon of loc and list string and list ctyp - | CeFun of loc and patt and class_expr - | CeLet of loc and bool and list (patt * expr) and class_expr - | CeStr of loc and option patt and list class_str_item - | CeTyc of loc and class_expr and class_type ] -and class_str_item = - [ CrCtr of loc and ctyp and ctyp - | CrDcl of loc and list class_str_item - | CrInh of loc and class_expr and option string - | CrIni of loc and expr - | CrMth of loc and string and bool and expr and option ctyp - | CrVal of loc and string and bool and expr - | CrVir of loc and string and bool and ctyp ] -; - -external loc_of_ctyp : ctyp -> loc = "%field0"; -external loc_of_patt : patt -> loc = "%field0"; -external loc_of_expr : expr -> loc = "%field0"; -external loc_of_module_type : module_type -> loc = "%field0"; -external loc_of_module_expr : module_expr -> loc = "%field0"; -external loc_of_sig_item : sig_item -> loc = "%field0"; -external loc_of_str_item : str_item -> loc = "%field0"; - -external loc_of_class_type : class_type -> loc = "%field0"; -external loc_of_class_sig_item : class_sig_item -> loc = "%field0"; -external loc_of_class_expr : class_expr -> loc = "%field0"; -external loc_of_class_str_item : class_str_item -> loc = "%field0"; diff --git a/camlp4/camlp4/pcaml.ml b/camlp4/camlp4/pcaml.ml deleted file mode 100644 index 63c083ceba..0000000000 --- a/camlp4/camlp4/pcaml.ml +++ /dev/null @@ -1,457 +0,0 @@ -(* camlp4r pa_extend.cmo *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -value version = Sys.ocaml_version; - -value syntax_name = ref ""; - -value gram = - Grammar.gcreate - {Token.tok_func _ = failwith "no loaded parsing module"; - Token.tok_using _ = (); Token.tok_removing _ = (); - Token.tok_match = fun []; Token.tok_text _ = ""; - Token.tok_comm = None} -; - -value interf = Grammar.Entry.create gram "interf"; -value implem = Grammar.Entry.create gram "implem"; -value top_phrase = Grammar.Entry.create gram "top_phrase"; -value use_file = Grammar.Entry.create gram "use_file"; -value sig_item = Grammar.Entry.create gram "sig_item"; -value str_item = Grammar.Entry.create gram "str_item"; -value module_type = Grammar.Entry.create gram "module_type"; -value module_expr = Grammar.Entry.create gram "module_expr"; -value expr = Grammar.Entry.create gram "expr"; -value patt = Grammar.Entry.create gram "patt"; -value ctyp = Grammar.Entry.create gram "type"; -value let_binding = Grammar.Entry.create gram "let_binding"; -value type_declaration = Grammar.Entry.create gram "type_declaration"; - -value class_sig_item = Grammar.Entry.create gram "class_sig_item"; -value class_str_item = Grammar.Entry.create gram "class_str_item"; -value class_type = Grammar.Entry.create gram "class_type"; -value class_expr = Grammar.Entry.create gram "class_expr"; - -value parse_interf = ref (Grammar.Entry.parse interf); -value parse_implem = ref (Grammar.Entry.parse implem); - -value rec skip_to_eol cs = - match Stream.peek cs with - [ Some '\n' -> () - | Some c -> do { Stream.junk cs; skip_to_eol cs } - | _ -> () ] -; -value sync = ref skip_to_eol; - -value input_file = ref ""; -value output_file = ref None; - -value warning_default_function (bp, ep) txt = - do { Printf.eprintf " loc %d %d: %s\n" bp ep txt; flush stderr } -; - -value warning = ref warning_default_function; - -value apply_with_var v x f = - let vx = v.val in - try - do { - v.val := x; - let r = f (); - v.val := vx; - r - } - with e -> do { v.val := vx; raise e } -; - -List.iter (fun (n, f) -> Quotation.add n f) - [("id", Quotation.ExStr (fun _ s -> "$0:" ^ s ^ "$")); - ("string", Quotation.ExStr (fun _ s -> "\"" ^ String.escaped s ^ "\""))]; - -value quotation_dump_file = ref (None : option string); - -type err_ctx = - [ Finding | Expanding | ParsingResult of (int * int) and string | Locating ] -; -exception Qerror of string and err_ctx and exn; - -value expand_quotation loc expander shift name str = - let new_warning = - let warn = warning.val in - fun (bp, ep) txt -> warn (shift + bp, shift + ep) txt - in - apply_with_var warning new_warning - (fun () -> - try expander str with - [ Stdpp.Exc_located (p1, p2) exc -> - let exc1 = Qerror name Expanding exc in - raise (Stdpp.Exc_located (shift + p1, shift + p2) exc1) - | exc -> - let exc1 = Qerror name Expanding exc in - raise (Stdpp.Exc_located loc exc1) ]) -; - -value parse_quotation_result entry loc shift name str = - let cs = Stream.of_string str in - try Grammar.Entry.parse entry cs with - [ Stdpp.Exc_located iloc (Qerror _ Locating _ as exc) -> - raise (Stdpp.Exc_located (shift + fst iloc, shift + snd iloc) exc) - | Stdpp.Exc_located iloc (Qerror _ Expanding exc) -> - let ctx = ParsingResult iloc str in - let exc1 = Qerror name ctx exc in - raise (Stdpp.Exc_located loc exc1) - | Stdpp.Exc_located _ (Qerror _ _ _ as exc) -> - raise (Stdpp.Exc_located loc exc) - | Stdpp.Exc_located iloc exc -> - let ctx = ParsingResult iloc str in - let exc1 = Qerror name ctx exc in - raise (Stdpp.Exc_located loc exc1) ] -; - -value handle_quotation loc proj in_expr entry reloc (name, str) = - let shift = - match name with - [ "" -> String.length "<<" - | _ -> String.length "<:" + String.length name + String.length "<" ] - in - let shift = fst loc + shift in - let expander = - try Quotation.find name with exc -> - let exc1 = Qerror name Finding exc in - let loc = (fst loc, shift) in - raise (Stdpp.Exc_located loc exc1) - in - let ast = - match expander with - [ Quotation.ExStr f -> - let new_str = expand_quotation loc (f in_expr) shift name str in - parse_quotation_result entry loc shift name new_str - | Quotation.ExAst fe_fp -> - expand_quotation loc (proj fe_fp) shift name str ] - in - reloc (fun _ -> loc) shift ast -; - -value parse_locate entry shift str = - let cs = Stream.of_string str in - try Grammar.Entry.parse entry cs with - [ Stdpp.Exc_located (p1, p2) exc -> - let ctx = Locating in - let exc1 = Qerror (Grammar.Entry.name entry) ctx exc in - raise (Stdpp.Exc_located (shift + p1, shift + p2) exc1) ] -; - -value handle_locate loc entry ast_f (pos, str) = - let s = str in - let loc = (pos, pos + String.length s) in - let x = parse_locate entry (fst loc) s in - ast_f loc x -; - -value expr_anti loc e = MLast.ExAnt loc e; -value patt_anti loc p = MLast.PaAnt loc p; -value expr_eoi = Grammar.Entry.create gram "expression"; -value patt_eoi = Grammar.Entry.create gram "pattern"; -EXTEND - expr_eoi: - [ [ x = expr; EOI -> x ] ] - ; - patt_eoi: - [ [ x = patt; EOI -> x ] ] - ; -END; - -value handle_expr_quotation loc x = - handle_quotation loc fst True expr_eoi Reloc.expr x -; - -value handle_expr_locate loc x = handle_locate loc expr_eoi expr_anti x; - -value handle_patt_quotation loc x = - handle_quotation loc snd False patt_eoi Reloc.patt x -; - -value handle_patt_locate loc x = handle_locate loc patt_eoi patt_anti x; - -value expr_reloc = Reloc.expr; -value patt_reloc = Reloc.patt; - -value rename_id = ref (fun x -> x); - -value find_line (bp, ep) str = - find 0 1 0 where rec find i line col = - if i == String.length str then (line, 0, col) - else if i == bp then (line, col, col + ep - bp) - else if str.[i] == '\n' then find (succ i) (succ line) 0 - else find (succ i) line (succ col) -; - -value loc_fmt = - match Sys.os_type with - [ "MacOS" -> - format_of_string "File \"%s\"; line %d; characters %d to %d\n### " - | _ -> - format_of_string "File \"%s\", line %d, characters %d-%d:\n" ] -; - -value report_quotation_error name ctx = - let name = if name = "" then Quotation.default.val else name in - do { - Format.print_flush (); - Format.open_hovbox 2; - Printf.eprintf "While %s \"%s\":" - (match ctx with - [ Finding -> "finding quotation" - | Expanding -> "expanding quotation" - | ParsingResult _ _ -> "parsing result of quotation" - | Locating -> "parsing" ]) - name; - match ctx with - [ ParsingResult (bp, ep) str -> - match quotation_dump_file.val with - [ Some dump_file -> - do { - Printf.eprintf " dumping result...\n"; - flush stderr; - try - let (line, c1, c2) = find_line (bp, ep) str in - let oc = open_out_bin dump_file in - do { - output_string oc str; - output_string oc "\n"; - flush oc; - close_out oc; - Printf.eprintf loc_fmt dump_file line c1 c2; - flush stderr - } - with _ -> - do { - Printf.eprintf "Error while dumping result in file \"%s\"" - dump_file; - Printf.eprintf "; dump aborted.\n"; - flush stderr - } - } - | None -> - do { - if input_file.val = "" then - Printf.eprintf - "\n(consider setting variable Pcaml.quotation_dump_file)\n" - else Printf.eprintf " (consider using option -QD)\n"; - flush stderr - } ] - | _ -> do { Printf.eprintf "\n"; flush stderr } ] - } -; - -value print_format str = - let rec flush ini cnt = - if cnt > ini then Format.print_string (String.sub str ini (cnt - ini)) - else () - in - let rec loop ini cnt = - if cnt == String.length str then flush ini cnt - else - match str.[cnt] with - [ '\n' -> - do { - flush ini cnt; - Format.close_box (); - Format.force_newline (); - Format.open_box 2; - loop (cnt + 1) (cnt + 1) - } - | ' ' -> - do { - flush ini cnt; Format.print_space (); loop (cnt + 1) (cnt + 1) - } - | _ -> loop ini (cnt + 1) ] - in - do { Format.open_box 2; loop 0 0; Format.close_box () } -; - -value print_file_failed file line char = - do { - Format.print_string ", file \""; - Format.print_string file; - Format.print_string "\", line "; - Format.print_int line; - Format.print_string ", char "; - Format.print_int char - } -; - -value print_exn = - fun - [ Out_of_memory -> Format.print_string "Out of memory\n" - | Assert_failure (file, line, char) -> - do { - Format.print_string "Assertion failed"; - print_file_failed file line char; - } - | Match_failure (file, line, char) -> - do { - Format.print_string "Pattern matching failed"; - print_file_failed file line char; - } - | Stream.Error str -> print_format ("Parse error: " ^ str) - | Stream.Failure -> Format.print_string "Parse failure" - | Token.Error str -> - do { Format.print_string "Lexing error: "; Format.print_string str } - | Failure str -> - do { Format.print_string "Failure: "; Format.print_string str } - | Invalid_argument str -> - do { Format.print_string "Invalid argument: "; Format.print_string str } - | Sys_error msg -> - do { Format.print_string "I/O error: "; Format.print_string msg } - | x -> - do { - Format.print_string "Uncaught exception: "; - Format.print_string - (Obj.magic (Obj.field (Obj.field (Obj.repr x) 0) 0)); - if Obj.size (Obj.repr x) > 1 then do { - Format.print_string " ("; - for i = 1 to Obj.size (Obj.repr x) - 1 do { - if i > 1 then Format.print_string ", " else (); - let arg = Obj.field (Obj.repr x) i in - if not (Obj.is_block arg) then - Format.print_int (Obj.magic arg : int) - else if Obj.tag arg = Obj.tag (Obj.repr "a") then do { - Format.print_char '"'; - Format.print_string (Obj.magic arg : string); - Format.print_char '"' - } - else Format.print_char '_' - }; - Format.print_char ')' - } - else () - } ] -; - -value report_error exn = - match exn with - [ Qerror name Finding Not_found -> - let name = if name = "" then Quotation.default.val else name in - do { - Format.print_flush (); - Format.open_hovbox 2; - Format.printf "Unbound quotation: \"%s\"" name; - Format.close_box () - } - | Qerror name ctx exn -> - do { report_quotation_error name ctx; print_exn exn } - | e -> print_exn exn ] -; - -value no_constructors_arity = Ast2pt.no_constructors_arity; -(*value no_assert = ref False;*) - -value arg_spec_list_ref = ref []; -value arg_spec_list () = arg_spec_list_ref.val; -value add_option name spec descr = - arg_spec_list_ref.val := arg_spec_list_ref.val @ [(name, spec, descr)] -; - -(* Printers *) - -open Spretty; - -type printer_t 'a = - { pr_fun : mutable string -> 'a -> string -> kont -> pretty; - pr_levels : mutable list (pr_level 'a) } -and pr_level 'a = - { pr_label : string; - pr_box : 'a -> Stream.t pretty -> pretty; - pr_rules : mutable pr_rule 'a } -and pr_rule 'a = - Extfun.t 'a (curr 'a -> next 'a -> string -> kont -> Stream.t pretty) -and curr 'a = 'a -> string -> kont -> Stream.t pretty -and next 'a = 'a -> string -> kont -> pretty -and kont = Stream.t pretty -; - -value pr_str_item = {pr_fun = fun []; pr_levels = []}; -value pr_sig_item = {pr_fun = fun []; pr_levels = []}; -value pr_module_type = {pr_fun = fun []; pr_levels = []}; -value pr_module_expr = {pr_fun = fun []; pr_levels = []}; -value pr_expr = {pr_fun = fun []; pr_levels = []}; -value pr_patt = {pr_fun = fun []; pr_levels = []}; -value pr_ctyp = {pr_fun = fun []; pr_levels = []}; -value pr_class_sig_item = {pr_fun = fun []; pr_levels = []}; -value pr_class_str_item = {pr_fun = fun []; pr_levels = []}; -value pr_class_type = {pr_fun = fun []; pr_levels = []}; -value pr_class_expr = {pr_fun = fun []; pr_levels = []}; -value pr_expr_fun_args = ref Extfun.empty; - -value pr_fun name pr lab = - loop False pr.pr_levels where rec loop app = - fun - [ [] -> fun x dg k -> failwith ("unable to print " ^ name) - | [lev :: levl] -> - if app || lev.pr_label = lab then - let next = loop True levl in - let rec curr x dg k = Extfun.apply lev.pr_rules x curr next dg k in - fun x dg k -> lev.pr_box x (curr x dg k) - else loop app levl ] -; - -pr_str_item.pr_fun := pr_fun "str_item" pr_str_item; -pr_sig_item.pr_fun := pr_fun "sig_item" pr_sig_item; -pr_module_type.pr_fun := pr_fun "module_type" pr_module_type; -pr_module_expr.pr_fun := pr_fun "module_expr" pr_module_expr; -pr_expr.pr_fun := pr_fun "expr" pr_expr; -pr_patt.pr_fun := pr_fun "patt" pr_patt; -pr_ctyp.pr_fun := pr_fun "ctyp" pr_ctyp; -pr_class_sig_item.pr_fun := pr_fun "class_sig_item" pr_class_sig_item; -pr_class_str_item.pr_fun := pr_fun "class_str_item" pr_class_str_item; -pr_class_type.pr_fun := pr_fun "class_type" pr_class_type; -pr_class_expr.pr_fun := pr_fun "class_expr" pr_class_expr; - -value rec find_pr_level lab = - fun - [ [] -> failwith ("level " ^ lab ^ " not found") - | [lev :: levl] -> - if lev.pr_label = lab then lev else find_pr_level lab levl ] -; - -value undef x = ref (fun _ -> failwith x); -value print_interf = undef "no printer"; -value print_implem = undef "no printer"; - -value top_printer pr x = - do { - Format.force_newline (); - Spretty.print_pretty Format.print_char Format.print_string - Format.print_newline "<< " " " 78 - (fun _ _ -> ("", 0, 0, 0)) 0 (pr.pr_fun "top" x "" [: :]); - Format.print_string " >>"; - } -; - -value buff = Buffer.create 73; -value buffer_char = Buffer.add_char buff; -value buffer_string = Buffer.add_string buff; -value buffer_newline () = Buffer.add_char buff '\n'; - -value string_of pr x = - do { - Buffer.clear buff; - Spretty.print_pretty buffer_char buffer_string buffer_newline "" "" 78 - (fun _ _ -> ("", 0, 0, 0)) 0 (pr.pr_fun "top" x "" [: :]); - Buffer.contents buff - } -; - -value inter_phrases = ref None; diff --git a/camlp4/camlp4/pcaml.mli b/camlp4/camlp4/pcaml.mli deleted file mode 100644 index c87ebe39ae..0000000000 --- a/camlp4/camlp4/pcaml.mli +++ /dev/null @@ -1,157 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2001 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(** Language grammar, entries and printers. - - Hold variables to be set by language syntax extensions. Some of them - are provided for quotations management. *) - -value syntax_name : ref string; - -(** {6 Parsers} *) - -value parse_interf : - ref (Stream.t char -> (list (MLast.sig_item * MLast.loc) * bool)); -value parse_implem : - ref (Stream.t char -> (list (MLast.str_item * MLast.loc) * bool)); - (** Called when parsing an interface (mli file) or an implementation - (ml file) to build the syntax tree; the returned list contains the - phrases (signature items or structure items) and their locations; - the boolean tells that the parser has encountered a directive; in - this case, since the directive may change the syntax, the parsing - stops, the directive is evaluated, and this function is called - again. - These functions are references, because they can be changed to - use another technology than the Camlp4 extended grammars. By - default, they use the grammars entries [implem] and [interf] - defined below. *) - -value gram : Grammar.g; - (** Grammar variable of the OCaml language *) - -value interf : Grammar.Entry.e (list (MLast.sig_item * MLast.loc) * bool); -value implem : Grammar.Entry.e (list (MLast.str_item * MLast.loc) * bool); -value top_phrase : Grammar.Entry.e (option MLast.str_item); -value use_file : Grammar.Entry.e (list MLast.str_item * bool); -value module_type : Grammar.Entry.e MLast.module_type; -value module_expr : Grammar.Entry.e MLast.module_expr; -value sig_item : Grammar.Entry.e MLast.sig_item; -value str_item : Grammar.Entry.e MLast.str_item; -value expr : Grammar.Entry.e MLast.expr; -value patt : Grammar.Entry.e MLast.patt; -value ctyp : Grammar.Entry.e MLast.ctyp; -value let_binding : Grammar.Entry.e (MLast.patt * MLast.expr); -value type_declaration : Grammar.Entry.e MLast.type_decl; -value class_sig_item : Grammar.Entry.e MLast.class_sig_item; -value class_str_item : Grammar.Entry.e MLast.class_str_item; -value class_expr : Grammar.Entry.e MLast.class_expr; -value class_type : Grammar.Entry.e MLast.class_type; - (** Some entries of the language, set by [pa_o.cmo] and [pa_r.cmo]. *) - -value input_file : ref string; - (** The file currently being parsed. *) -value output_file : ref (option string); - (** The output file, stdout if None (default) *) -value report_error : exn -> unit; - (** Prints an error message, using the module [Format]. *) -value quotation_dump_file : ref (option string); - (** [quotation_dump_file] optionally tells the compiler to dump the - result of an expander if this result is syntactically incorrect. - If [None] (default), this result is not dumped. If [Some fname], the - result is dumped in the file [fname]. *) -value version : string; - (** The current version of Camlp4. *) -value add_option : string -> Arg.spec -> string -> unit; - (** Add an option to the command line options. *) -value no_constructors_arity : ref bool; - (** [True]: dont generate constructor arity. *) -(*value no_assert : ref bool; - (** [True]: dont generate assertion checks. *) -*) - -value sync : ref (Stream.t char -> unit); - -value handle_expr_quotation : MLast.loc -> (string * string) -> MLast.expr; -value handle_expr_locate : MLast.loc -> (int * string) -> MLast.expr; - -value handle_patt_quotation : MLast.loc -> (string * string) -> MLast.patt; -value handle_patt_locate : MLast.loc -> (int * string) -> MLast.patt; - -value expr_reloc : - (MLast.loc -> MLast.loc) -> int -> MLast.expr -> MLast.expr; -value patt_reloc : - (MLast.loc -> MLast.loc) -> int -> MLast.patt -> MLast.patt; - -(** To possibly rename identifiers; parsers may call this function - when generating their identifiers; default = identity *) -value rename_id : ref (string -> string); - -(** Allow user to catch exceptions in quotations *) -type err_ctx = - [ Finding | Expanding | ParsingResult of (int * int) and string | Locating ] -; -exception Qerror of string and err_ctx and exn; - -(** {6 Printers} *) - -open Spretty; - -value print_interf : ref (list (MLast.sig_item * MLast.loc) -> unit); -value print_implem : ref (list (MLast.str_item * MLast.loc) -> unit); - (** Some printers, set by [pr_dump.cmo], [pr_o.cmo] and [pr_r.cmo]. *) - -type printer_t 'a = - { pr_fun : mutable string -> 'a -> string -> kont -> pretty; - pr_levels : mutable list (pr_level 'a) } -and pr_level 'a = - { pr_label : string; - pr_box : 'a -> Stream.t pretty -> pretty; - pr_rules : mutable pr_rule 'a } -and pr_rule 'a = - Extfun.t 'a (curr 'a -> next 'a -> string -> kont -> Stream.t pretty) -and curr 'a = 'a -> string -> kont -> Stream.t pretty -and next 'a = 'a -> string -> kont -> pretty -and kont = Stream.t pretty -; - -value pr_sig_item : printer_t MLast.sig_item; -value pr_str_item : printer_t MLast.str_item; -value pr_module_type : printer_t MLast.module_type; -value pr_module_expr : printer_t MLast.module_expr; -value pr_expr : printer_t MLast.expr; -value pr_patt : printer_t MLast.patt; -value pr_ctyp : printer_t MLast.ctyp; -value pr_class_sig_item : printer_t MLast.class_sig_item; -value pr_class_str_item : printer_t MLast.class_str_item; -value pr_class_type : printer_t MLast.class_type; -value pr_class_expr : printer_t MLast.class_expr; - -value pr_expr_fun_args : - ref (Extfun.t MLast.expr (list MLast.patt * MLast.expr)); - -value find_pr_level : string -> list (pr_level 'a) -> pr_level 'a; - -value top_printer : printer_t 'a -> 'a -> unit; -value string_of : printer_t 'a -> 'a -> string; - -value inter_phrases : ref (option string); - -(**/**) - -(* for system use *) - -value warning : ref ((int * int) -> string -> unit); -value expr_eoi : Grammar.Entry.e MLast.expr; -value patt_eoi : Grammar.Entry.e MLast.patt; -value arg_spec_list : unit -> list (string * Arg.spec * string); diff --git a/camlp4/camlp4/quotation.ml b/camlp4/camlp4/quotation.ml deleted file mode 100644 index 431a75768d..0000000000 --- a/camlp4/camlp4/quotation.ml +++ /dev/null @@ -1,33 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -type expander = - [ ExStr of bool -> string -> string - | ExAst of (string -> MLast.expr * string -> MLast.patt) ] -; - -value expanders_table = ref []; - -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 = List.assoc (expander_name name) expanders_table.val; - -value add name f = expanders_table.val := [(name, f) :: expanders_table.val]; diff --git a/camlp4/camlp4/quotation.mli b/camlp4/camlp4/quotation.mli deleted file mode 100644 index 3c0f5f6c4f..0000000000 --- a/camlp4/camlp4/quotation.mli +++ /dev/null @@ -1,48 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1998 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(** Quotation operations. *) - -type expander = - [ ExStr of bool -> string -> string - | ExAst of (string -> MLast.expr * string -> MLast.patt) ] -; - -(** The type for quotation expanders kind: -- [ExStr exp] for an expander [exp] returning a string which - can be parsed to create a syntax tree. Its boolean parameter - tells whether the quotation is in position of an expression - (True) or in position of a pattern (False). Quotations expanders - created with this way may work for some particular language syntax, - and not for another one (e.g. may work when used with Revised - syntax and not when used with Ocaml syntax, and conversely). -- [ExAst (expr_exp, patt_exp)] for expanders returning directly - syntax trees, therefore not necessiting to be parsed afterwards. - The function [expr_exp] is called when the quotation is in - position of an expression, and [patt_exp] when the quotation is - in position of a pattern. Quotation expanders created with this - way are independant from the language syntax. *) - -value add : string -> expander -> unit; - (** [add name exp] adds the quotation [name] associated with the - expander [exp]. *) - -value find : string -> expander; - (** [find name] returns the expander of the given quotation name. *) - -value default : ref string; - (** [default] holds the default quotation name. *) - -value translate : ref (string -> string); - (** function translating quotation names; default = identity *) diff --git a/camlp4/camlp4/reloc.ml b/camlp4/camlp4/reloc.ml deleted file mode 100644 index 73f81b9b7b..0000000000 --- a/camlp4/camlp4/reloc.ml +++ /dev/null @@ -1,289 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1998 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -open MLast; - -value option_map f = - fun - [ Some x -> Some (f x) - | None -> None ] -; - -value rec ctyp floc sh = - self where rec self = - fun - [ TyAcc loc x1 x2 -> TyAcc (floc loc) (self x1) (self x2) - | TyAli loc x1 x2 -> TyAli (floc loc) (self x1) (self x2) - | TyAny loc -> TyAny (floc loc) - | TyApp loc x1 x2 -> TyApp (floc loc) (self x1) (self x2) - | TyArr loc x1 x2 -> TyArr (floc loc) (self x1) (self x2) - | TyCls loc x1 -> TyCls (floc loc) x1 - | TyLab loc x1 x2 -> TyLab (floc loc) x1 (self x2) - | TyLid loc x1 -> TyLid (floc loc) x1 - | TyMan loc x1 x2 -> TyMan (floc loc) (self x1) (self x2) - | TyObj loc x1 x2 -> - TyObj (floc loc) (List.map (fun (x1, x2) -> (x1, self x2)) x1) x2 - | TyOlb loc x1 x2 -> TyOlb (floc loc) x1 (self x2) - | TyPol loc x1 x2 -> TyPol (floc loc) x1 (self x2) - | TyQuo loc x1 -> TyQuo (floc loc) x1 - | TyRec loc pflag x1 -> - TyRec (floc loc) pflag - (List.map (fun (loc, x1, x2, x3) -> (floc loc, x1, x2, self x3)) x1) - | TySum loc pflag x1 -> - TySum (floc loc) pflag - (List.map (fun (loc, x1, x2) -> (floc loc, x1, List.map self x2)) x1) - | TyTup loc x1 -> TyTup (floc loc) (List.map self x1) - | TyUid loc x1 -> TyUid (floc loc) x1 - | TyVrn loc x1 x2 -> - TyVrn (floc loc) (List.map (row_field floc sh) x1) x2 ] -and row_field floc sh = - fun - [ RfTag x1 x2 x3 -> RfTag x1 x2 (List.map (ctyp floc sh) x3) - | RfInh x1 -> RfInh (ctyp floc sh x1) ] -; - -value class_infos a floc sh x = - {ciLoc = floc x.ciLoc; ciVir = x.ciVir; - ciPrm = - let (x1, x2) = x.ciPrm in - (floc x1, x2); - ciNam = x.ciNam; ciExp = a floc sh x.ciExp} -; - -value rec patt floc sh = - self where rec self = - fun - [ PaAcc loc x1 x2 -> PaAcc (floc loc) (self x1) (self x2) - | PaAli loc x1 x2 -> PaAli (floc loc) (self x1) (self x2) - | PaAnt loc x1 -> - patt (fun (p1, p2) -> (sh + fst loc + p1, sh + fst loc + p2)) 0 x1 - | PaAny loc -> PaAny (floc loc) - | PaApp loc x1 x2 -> PaApp (floc loc) (self x1) (self x2) - | PaArr loc x1 -> PaArr (floc loc) (List.map self x1) - | PaChr loc x1 -> PaChr (floc loc) x1 - | PaInt loc x1 -> PaInt (floc loc) x1 - | PaInt32 loc x1 -> PaInt32 (floc loc) x1 - | PaInt64 loc x1 -> PaInt64 (floc loc) x1 - | PaNativeInt loc x1 -> PaNativeInt (floc loc) x1 - | PaFlo loc x1 -> PaFlo (floc loc) x1 - | PaLab loc x1 x2 -> PaLab (floc loc) x1 (option_map self x2) - | PaLid loc x1 -> PaLid (floc loc) x1 - | PaOlb loc x1 x2 -> - PaOlb (floc loc) x1 - (option_map - (fun (x1, x2) -> (self x1, option_map (expr floc sh) x2)) x2) - | PaOrp loc x1 x2 -> PaOrp (floc loc) (self x1) (self x2) - | PaRng loc x1 x2 -> PaRng (floc loc) (self x1) (self x2) - | PaRec loc x1 -> - PaRec (floc loc) (List.map (fun (x1, x2) -> (self x1, self x2)) x1) - | PaStr loc x1 -> PaStr (floc loc) x1 - | PaTup loc x1 -> PaTup (floc loc) (List.map self x1) - | PaTyc loc x1 x2 -> PaTyc (floc loc) (self x1) (ctyp floc sh x2) - | PaTyp loc x1 -> PaTyp (floc loc) x1 - | PaUid loc x1 -> PaUid (floc loc) x1 - | PaVrn loc x1 -> PaVrn (floc loc) x1 ] -and expr floc sh = - self where rec self = - fun - [ ExAcc loc x1 x2 -> ExAcc (floc loc) (self x1) (self x2) - | ExAnt loc x1 -> - expr (fun (p1, p2) -> (sh + fst loc + p1, sh + fst loc + p2)) 0 x1 - | ExApp loc x1 x2 -> ExApp (floc loc) (self x1) (self x2) - | ExAre loc x1 x2 -> ExAre (floc loc) (self x1) (self x2) - | ExArr loc x1 -> ExArr (floc loc) (List.map self x1) - | ExAsf loc -> ExAsf (floc loc) - | ExAsr loc x1 -> ExAsr (floc loc) (self x1) - | ExAss loc x1 x2 -> ExAss (floc loc) (self x1) (self x2) - | ExChr loc x1 -> ExChr (floc loc) x1 - | ExCoe loc x1 x2 x3 -> - ExCoe (floc loc) (self x1) (option_map (ctyp floc sh) x2) - (ctyp floc sh x3) - | ExFlo loc x1 -> ExFlo (floc loc) x1 - | ExFor loc x1 x2 x3 x4 x5 -> - ExFor (floc loc) x1 (self x2) (self x3) x4 (List.map self x5) - | ExFun loc x1 -> - ExFun (floc loc) - (List.map - (fun (x1, x2, x3) -> - (patt floc sh x1, option_map self x2, self x3)) - x1) - | ExIfe loc x1 x2 x3 -> ExIfe (floc loc) (self x1) (self x2) (self x3) - | ExInt loc x1 -> ExInt (floc loc) x1 - | ExInt32 loc x1 -> ExInt32 (floc loc) x1 - | ExInt64 loc x1 -> ExInt64 (floc loc) x1 - | ExNativeInt loc x1 -> ExNativeInt (floc loc) x1 - | ExLab loc x1 x2 -> ExLab (floc loc) x1 (option_map self x2) - | ExLaz loc x1 -> ExLaz (floc loc) (self x1) - | ExLet loc x1 x2 x3 -> - ExLet (floc loc) x1 - (List.map (fun (x1, x2) -> (patt floc sh x1, self x2)) x2) (self x3) - | ExLid loc x1 -> ExLid (floc loc) x1 - | ExLmd loc x1 x2 x3 -> - ExLmd (floc loc) x1 (module_expr floc sh x2) (self x3) - | ExMat loc x1 x2 -> - ExMat (floc loc) (self x1) - (List.map - (fun (x1, x2, x3) -> - (patt floc sh x1, option_map self x2, self x3)) - x2) - | ExNew loc x1 -> ExNew (floc loc) x1 - | ExOlb loc x1 x2 -> ExOlb (floc loc) x1 (option_map self x2) - | ExOvr loc x1 -> - ExOvr (floc loc) (List.map (fun (x1, x2) -> (x1, self x2)) x1) - | ExRec loc x1 x2 -> - ExRec (floc loc) - (List.map (fun (x1, x2) -> (patt floc sh x1, self x2)) x1) - (option_map self x2) - | ExSeq loc x1 -> ExSeq (floc loc) (List.map self x1) - | ExSnd loc x1 x2 -> ExSnd (floc loc) (self x1) x2 - | ExSte loc x1 x2 -> ExSte (floc loc) (self x1) (self x2) - | ExStr loc x1 -> ExStr (floc loc) x1 - | ExTry loc x1 x2 -> - ExTry (floc loc) (self x1) - (List.map - (fun (x1, x2, x3) -> - (patt floc sh x1, option_map self x2, self x3)) - x2) - | ExTup loc x1 -> ExTup (floc loc) (List.map self x1) - | ExTyc loc x1 x2 -> ExTyc (floc loc) (self x1) (ctyp floc sh x2) - | ExUid loc x1 -> ExUid (floc loc) x1 - | ExVrn loc x1 -> ExVrn (floc loc) x1 - | ExWhi loc x1 x2 -> ExWhi (floc loc) (self x1) (List.map self x2) ] -and module_type floc sh = - self where rec self = - fun - [ MtAcc loc x1 x2 -> MtAcc (floc loc) (self x1) (self x2) - | MtApp loc x1 x2 -> MtApp (floc loc) (self x1) (self x2) - | MtFun loc x1 x2 x3 -> MtFun (floc loc) x1 (self x2) (self x3) - | MtLid loc x1 -> MtLid (floc loc) x1 - | MtQuo loc x1 -> MtQuo (floc loc) x1 - | MtSig loc x1 -> MtSig (floc loc) (List.map (sig_item floc sh) x1) - | MtUid loc x1 -> MtUid (floc loc) x1 - | MtWit loc x1 x2 -> - MtWit (floc loc) (self x1) (List.map (with_constr floc sh) x2) ] -and sig_item floc sh = - self where rec self = - fun - [ SgCls loc x1 -> - SgCls (floc loc) (List.map (class_infos class_type floc sh) x1) - | SgClt loc x1 -> - SgClt (floc loc) (List.map (class_infos class_type floc sh) x1) - | SgDcl loc x1 -> SgDcl (floc loc) (List.map self x1) - | SgDir loc x1 x2 -> SgDir (floc loc) x1 x2 - | SgExc loc x1 x2 -> SgExc (floc loc) x1 (List.map (ctyp floc sh) x2) - | SgExt loc x1 x2 x3 -> SgExt (floc loc) x1 (ctyp floc sh x2) x3 - | SgInc loc x1 -> SgInc (floc loc) (module_type floc sh x1) - | SgMod loc x1 x2 -> SgMod (floc loc) x1 (module_type floc sh x2) - | SgRecMod loc xxs - -> SgRecMod (floc loc) (List.map (fun (x1,x2) -> (x1, (module_type floc sh x2))) xxs) - | SgMty loc x1 x2 -> SgMty (floc loc) x1 (module_type floc sh x2) - | SgOpn loc x1 -> SgOpn (floc loc) x1 - | SgTyp loc x1 -> - SgTyp (floc loc) - (List.map - (fun ((loc, x1), x2, x3, x4) -> - ((floc loc, x1), x2, ctyp floc sh x3, - List.map (fun (x1, x2) -> (ctyp floc sh x1, ctyp floc sh x2)) - x4)) - x1) - | SgUse loc x1 x2 -> SgUse loc x1 x2 - | SgVal loc x1 x2 -> SgVal (floc loc) x1 (ctyp floc sh x2) ] -and with_constr floc sh = - self where rec self = - fun - [ WcTyp loc x1 x2 x3 -> WcTyp (floc loc) x1 x2 (ctyp floc sh x3) - | WcMod loc x1 x2 -> WcMod (floc loc) x1 (module_expr floc sh x2) ] -and module_expr floc sh = - self where rec self = - fun - [ MeAcc loc x1 x2 -> MeAcc (floc loc) (self x1) (self x2) - | MeApp loc x1 x2 -> MeApp (floc loc) (self x1) (self x2) - | MeFun loc x1 x2 x3 -> - MeFun (floc loc) x1 (module_type floc sh x2) (self x3) - | MeStr loc x1 -> MeStr (floc loc) (List.map (str_item floc sh) x1) - | MeTyc loc x1 x2 -> MeTyc (floc loc) (self x1) (module_type floc sh x2) - | MeUid loc x1 -> MeUid (floc loc) x1 ] -and str_item floc sh = - self where rec self = - fun - [ StCls loc x1 -> - StCls (floc loc) (List.map (class_infos class_expr floc sh) x1) - | StClt loc x1 -> - StClt (floc loc) (List.map (class_infos class_type floc sh) x1) - | StDcl loc x1 -> StDcl (floc loc) (List.map self x1) - | StDir loc x1 x2 -> StDir (floc loc) x1 x2 - | StExc loc x1 x2 x3 -> StExc (floc loc) x1 (List.map (ctyp floc sh) x2) x3 - | StExp loc x1 -> StExp (floc loc) (expr floc sh x1) - | StExt loc x1 x2 x3 -> StExt (floc loc) x1 (ctyp floc sh x2) x3 - | StInc loc x1 -> StInc (floc loc) (module_expr floc sh x1) - | StMod loc x1 x2 -> StMod (floc loc) x1 (module_expr floc sh x2) - | StRecMod loc nmtmes -> - StRecMod (floc loc) (List.map (fun (n, mt, me) -> (n, module_type floc sh mt, module_expr floc sh me)) nmtmes) - | StMty loc x1 x2 -> StMty (floc loc) x1 (module_type floc sh x2) - | StOpn loc x1 -> StOpn (floc loc) x1 - | StTyp loc x1 -> - StTyp (floc loc) - (List.map - (fun ((loc, x1), x2, x3, x4) -> - ((floc loc, x1), x2, ctyp floc sh x3, - List.map (fun (x1, x2) -> (ctyp floc sh x1, ctyp floc sh x2)) - x4)) - x1) - | StUse loc x1 x2 -> StUse loc x1 x2 - | StVal loc x1 x2 -> - StVal (floc loc) x1 - (List.map (fun (x1, x2) -> (patt floc sh x1, expr floc sh x2)) x2) ] -and class_type floc sh = - self where rec self = - fun - [ CtCon loc x1 x2 -> CtCon (floc loc) x1 (List.map (ctyp floc sh) x2) - | CtFun loc x1 x2 -> CtFun (floc loc) (ctyp floc sh x1) (self x2) - | CtSig loc x1 x2 -> - CtSig (floc loc) (option_map (ctyp floc sh) x1) - (List.map (class_sig_item floc sh) x2) ] -and class_sig_item floc sh = - self where rec self = - fun - [ CgCtr loc x1 x2 -> CgCtr (floc loc) (ctyp floc sh x1) (ctyp floc sh x2) - | CgDcl loc x1 -> CgDcl (floc loc) (List.map (class_sig_item floc sh) x1) - | CgInh loc x1 -> CgInh (floc loc) (class_type floc sh x1) - | CgMth loc x1 x2 x3 -> CgMth (floc loc) x1 x2 (ctyp floc sh x3) - | CgVal loc x1 x2 x3 -> CgVal (floc loc) x1 x2 (ctyp floc sh x3) - | CgVir loc x1 x2 x3 -> CgVir (floc loc) x1 x2 (ctyp floc sh x3) ] -and class_expr floc sh = - self where rec self = - fun - [ CeApp loc x1 x2 -> CeApp (floc loc) (self x1) (expr floc sh x2) - | CeCon loc x1 x2 -> CeCon (floc loc) x1 (List.map (ctyp floc sh) x2) - | CeFun loc x1 x2 -> CeFun (floc loc) (patt floc sh x1) (self x2) - | CeLet loc x1 x2 x3 -> - CeLet (floc loc) x1 - (List.map (fun (x1, x2) -> (patt floc sh x1, expr floc sh x2)) x2) - (self x3) - | CeStr loc x1 x2 -> - CeStr (floc loc) (option_map (patt floc sh) x1) - (List.map (class_str_item floc sh) x2) - | CeTyc loc x1 x2 -> CeTyc (floc loc) (self x1) (class_type floc sh x2) ] -and class_str_item floc sh = - self where rec self = - fun - [ CrCtr loc x1 x2 -> CrCtr (floc loc) (ctyp floc sh x1) (ctyp floc sh x2) - | CrDcl loc x1 -> CrDcl (floc loc) (List.map (class_str_item floc sh) x1) - | CrInh loc x1 x2 -> CrInh (floc loc) (class_expr floc sh x1) x2 - | CrIni loc x1 -> CrIni (floc loc) (expr floc sh x1) - | CrMth loc x1 x2 x3 x4 -> - CrMth (floc loc) x1 x2 (expr floc sh x3) (option_map (ctyp floc sh) x4) - | CrVal loc x1 x2 x3 -> CrVal (floc loc) x1 x2 (expr floc sh x3) - | CrVir loc x1 x2 x3 -> CrVir (floc loc) x1 x2 (ctyp floc sh x3) ] -; diff --git a/camlp4/camlp4/reloc.mli b/camlp4/camlp4/reloc.mli deleted file mode 100644 index d1a09a4e1f..0000000000 --- a/camlp4/camlp4/reloc.mli +++ /dev/null @@ -1,16 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1998 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -value patt : (MLast.loc -> MLast.loc) -> int -> MLast.patt -> MLast.patt; -value expr : (MLast.loc -> MLast.loc) -> int -> MLast.expr -> MLast.expr; diff --git a/camlp4/camlp4/spretty.ml b/camlp4/camlp4/spretty.ml deleted file mode 100644 index 2484cb47be..0000000000 --- a/camlp4/camlp4/spretty.ml +++ /dev/null @@ -1,481 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -type glue = [ LO | RO | LR | NO ]; -type pretty = - [ S of glue and string - | Hbox of Stream.t pretty - | HVbox of Stream.t pretty - | HOVbox of Stream.t pretty - | HOVCbox of Stream.t pretty - | Vbox of Stream.t pretty - | BEbox of Stream.t pretty - | BEVbox of Stream.t pretty - | LocInfo of (int * int) and pretty ] -; -type prettyL = - [ SL of int and glue and string - | HL of list prettyL - | BL of list prettyL - | PL of list prettyL - | QL of list prettyL - | VL of list prettyL - | BE of list prettyL - | BV of list prettyL - | LI of (string * int * int) and prettyL ] -; -type getcomm = int -> int -> (string * int * int * int); - -value quiet = ref True; -value maxl = ref 20; -value dt = ref 2; -value tol = ref 1; -value sp = ref ' '; -value last_ep = ref 0; -value getcomm = ref (fun _ _ -> ("", 0, 0, 0)); -value prompt = ref ""; -value print_char_fun = ref (output_char stdout); -value print_string_fun = ref (output_string stdout); -value print_newline_fun = ref (fun () -> output_char stdout '\n'); -value lazy_tab = ref (-1); - -value flush_tab () = - if lazy_tab.val >= 0 then do { - print_newline_fun.val (); - print_string_fun.val prompt.val; - for i = 1 to lazy_tab.val do { print_char_fun.val sp.val }; - lazy_tab.val := -1 - } - else () -; -value print_newline_and_tab tab = lazy_tab.val := tab; -value print_char c = do { flush_tab (); print_char_fun.val c }; -value print_string s = do { flush_tab (); print_string_fun.val s }; - -value rec print_spaces nsp = - for i = 1 to nsp do { print_char sp.val } -; - -value end_with_tab s = - loop (String.length s - 1) where rec loop i = - if i >= 0 then - if s.[i] = ' ' then loop (i - 1) - else s.[i] = '\n' - else False -; - -value print_comment tab s nl_bef tab_bef empty_stmt = - if s = "" then () - else do { - let (tab_aft, i_bef_tab) = - loop 0 (String.length s - 1) where rec loop tab_aft i = - if i >= 0 && s.[i] = ' ' then loop (tab_aft + 1) (i - 1) - else (tab_aft, i) - ; - let tab_bef = if nl_bef > 0 then tab_bef else tab in - let len = if empty_stmt then i_bef_tab else String.length s in - loop 0 where rec loop i = - if i = len then () - else do { - print_char_fun.val s.[i]; - let i = - if s.[i] = '\n' && (i+1 = len || s.[i+1] <> '\n') - then - let delta_ind = - if i = i_bef_tab then tab - tab_aft else tab - tab_bef - in - if delta_ind >= 0 then do { - for i = 1 to delta_ind do { print_char_fun.val ' ' }; - i + 1 - } - else - loop delta_ind (i + 1) where rec loop cnt i = - if cnt = 0 then i - else if i = len then i - else if s.[i] = ' ' then loop (cnt + 1) (i + 1) - else i - else i + 1 - in - loop i - } - } -; - -value string_np pos np = pos + np; - -value trace_ov pos = - if not quiet.val && pos > maxl.val then do { - prerr_string " prettych: overflow (length = "; - prerr_int pos; - prerr_endline ")" - } - else () -; - -value tolerate tab pos spc = pos + spc <= tab + dt.val + tol.val; - -value h_print_string pos spc np x = - let npos = string_np (pos + spc) np in - do { print_spaces spc; print_string x; npos } -; - -value n_print_string pos spc np x = - do { print_spaces spc; print_string x; string_np (pos + spc) np } -; - -value rec hnps ((pos, spc) as ps) = - fun - [ SL np RO _ -> (string_np pos np, 1) - | SL np LO _ -> (string_np (pos + spc) np, 0) - | SL np NO _ -> (string_np pos np, 0) - | SL np LR _ -> (string_np (pos + spc) np, 1) - | HL x -> hnps_list ps x - | BL x -> hnps_list ps x - | PL x -> hnps_list ps x - | QL x -> hnps_list ps x - | VL [x] -> hnps ps x - | VL [] -> ps - | VL x -> (maxl.val + 1, 0) - | BE x -> hnps_list ps x - | BV x -> (maxl.val + 1, 0) - | LI _ x -> hnps ps x ] -and hnps_list ((pos, _) as ps) pl = - if pos > maxl.val then (maxl.val + 1, 0) - else - match pl with - [ [p :: pl] -> hnps_list (hnps ps p) pl - | [] -> ps ] -; - -value rec first = - fun - [ SL _ _ s -> Some s - | HL x -> first_in_list x - | BL x -> first_in_list x - | PL x -> first_in_list x - | QL x -> first_in_list x - | VL x -> first_in_list x - | BE x -> first_in_list x - | BV x -> first_in_list x - | LI _ x -> first x ] -and first_in_list = - fun - [ [p :: pl] -> - match first p with - [ Some p -> Some p - | None -> first_in_list pl ] - | [] -> None ] -; - -value first_is_too_big tab p = - match first p with - [ Some s -> tab + String.length s >= maxl.val - | None -> False ] -; - -value too_long tab x p = - if first_is_too_big tab p then False - else - let (pos, spc) = hnps x p in - pos > maxl.val -; - -value rec has_comment = - fun - [ [LI (comm, nl_bef, tab_bef) x :: pl] -> - comm <> "" || has_comment [x :: pl] - | [HL x | BL x | PL x | QL x | VL x | BE x | BV x :: pl] -> - has_comment x || has_comment pl - | [SL _ _ _ :: pl] -> has_comment pl - | [] -> False ] -; - -value rec hprint_pretty tab pos spc = - fun - [ SL np RO x -> (h_print_string pos 0 np x, 1) - | SL np LO x -> (h_print_string pos spc np x, 0) - | SL np NO x -> (h_print_string pos 0 np x, 0) - | SL np LR x -> (h_print_string pos spc np x, 1) - | HL x -> hprint_box tab pos spc x - | BL x -> hprint_box tab pos spc x - | PL x -> hprint_box tab pos spc x - | QL x -> hprint_box tab pos spc x - | VL [x] -> hprint_pretty tab pos spc x - | VL [] -> (pos, spc) - | VL x -> hprint_box tab pos spc x - | BE x -> hprint_box tab pos spc x - | BV x -> - (* This should not occur: should be - invalid_arg "hprint_pretty" instead *) - hprint_box tab pos spc x - | LI (comm, nl_bef, tab_bef) x -> - do { - if lazy_tab.val >= 0 then do { - for i = 2 to nl_bef do { print_char_fun.val '\n' }; - flush_tab () - } - else (); - print_comment tab comm nl_bef tab_bef False; - hprint_pretty tab pos spc x - } ] -and hprint_box tab pos spc = - fun - [ [p :: pl] -> - let (pos, spc) = hprint_pretty tab pos spc p in - hprint_box tab pos spc pl - | [] -> (pos, spc) ] -; - -value rec print_pretty tab pos spc = - fun - [ SL np RO x -> (n_print_string pos 0 np x, 1) - | SL np LO x -> (n_print_string pos spc np x, 0) - | SL np NO x -> (n_print_string pos 0 np x, 0) - | SL np LR x -> (n_print_string pos spc np x, 1) - | HL x as p -> print_horiz tab pos spc x - | BL x as p -> print_horiz_vertic tab pos spc (too_long tab (pos, spc) p) x - | PL x as p -> print_paragraph tab pos spc (too_long tab (pos, spc) p) x - | QL x as p -> print_sparagraph tab pos spc (too_long tab (pos, spc) p) x - | VL x -> print_vertic tab pos spc x - | BE x as p -> print_begin_end tab pos spc (too_long tab (pos, spc) p) x - | BV x -> print_beg_end tab pos spc x - | LI (comm, nl_bef, tab_bef) x -> - do { - if lazy_tab.val >= 0 then do { - for i = 2 to nl_bef do { print_char_fun.val '\n' }; - if comm <> "" && nl_bef = 0 then - for i = 1 to tab_bef do { print_char_fun.val ' ' } - else if comm = "" && x = BL [] then lazy_tab.val := -1 - else flush_tab () - } - else (); - print_comment tab comm nl_bef tab_bef (x = BL []); - if comm <> "" && nl_bef = 0 then - if end_with_tab comm then lazy_tab.val := -1 else flush_tab () - else (); - print_pretty tab pos spc x - } ] -and print_horiz tab pos spc = - fun - [ [p :: pl] -> - let (npos, nspc) = print_pretty tab pos spc p in - if match pl with - [ [] -> True - | _ -> False ] - then - (npos, nspc) - else print_horiz tab npos nspc pl - | [] -> (pos, spc) ] -and print_horiz_vertic tab pos spc ov pl = - if ov || has_comment pl then print_vertic tab pos spc pl - else hprint_box tab pos spc pl -and print_vertic tab pos spc = - fun - [ [p :: pl] -> - let (npos, nspc) = print_pretty tab pos spc p in - if match pl with - [ [] -> True - | _ -> False ] - then - (npos, nspc) - else if tolerate tab npos nspc then do { - print_spaces nspc; print_vertic_rest (npos + nspc) pl - } - else do { - print_newline_and_tab (tab + dt.val); - print_vertic_rest (tab + dt.val) pl - } - | [] -> (pos, spc) ] -and print_vertic_rest tab = - fun - [ [p :: pl] -> - let (pos, spc) = print_pretty tab tab 0 p in - if match pl with - [ [] -> True - | _ -> False ] - then - (pos, spc) - else do { - print_newline_and_tab tab; - print_vertic_rest tab pl - } - | [] -> (tab, 0) ] -and print_paragraph tab pos spc ov pl = - if has_comment pl then print_vertic tab pos spc pl - else if ov then print_parag tab pos spc pl - else hprint_box tab pos spc pl -and print_parag tab pos spc = - fun - [ [p :: pl] -> - let (npos, nspc) = print_pretty tab pos spc p in - if match pl with - [ [] -> True - | _ -> False ] - then - (npos, nspc) - else if npos == tab then print_parag_rest tab tab 0 pl - else if too_long tab (pos, spc) p then do { - print_newline_and_tab (tab + dt.val); - print_parag_rest (tab + dt.val) (tab + dt.val) 0 pl - } - else if tolerate tab npos nspc then do { - print_spaces nspc; print_parag_rest (npos + nspc) (npos + nspc) 0 pl - } - else print_parag_rest (tab + dt.val) npos nspc pl - | [] -> (pos, spc) ] -and print_parag_rest tab pos spc = - fun - [ [p :: pl] -> - let (pos, spc) = - if pos > tab && too_long tab (pos, spc) p then do { - print_newline_and_tab tab; (tab, 0) - } - else (pos, spc) - in - let (npos, nspc) = print_pretty tab pos spc p in - if match pl with - [ [] -> True - | _ -> False ] - then - (npos, nspc) - else - let (pos, spc) = - if npos > tab && too_long tab (pos, spc) p then do { - print_newline_and_tab tab; - (tab, 0) - } - else (npos, nspc) - in - print_parag_rest tab pos spc pl - | [] -> (pos, spc) ] -and print_sparagraph tab pos spc ov pl = - if has_comment pl then print_vertic tab pos spc pl - else if ov then print_sparag tab pos spc pl - else hprint_box tab pos spc pl -and print_sparag tab pos spc = - fun - [ [p :: pl] -> - let (npos, nspc) = print_pretty tab pos spc p in - if match pl with - [ [] -> True - | _ -> False ] - then - (npos, nspc) - else if tolerate tab npos nspc then do { - print_spaces nspc; print_sparag_rest (npos + nspc) (npos + nspc) 0 pl - } - else print_sparag_rest (tab + dt.val) npos nspc pl - | [] -> (pos, spc) ] -and print_sparag_rest tab pos spc = - fun - [ [p :: pl] -> - let (pos, spc) = - if pos > tab && too_long tab (pos, spc) p then do { - print_newline_and_tab tab; (tab, 0) - } - else (pos, spc) - in - let (npos, nspc) = print_pretty tab pos spc p in - if match pl with - [ [] -> True - | _ -> False ] - then - (npos, nspc) - else print_sparag_rest tab npos nspc pl - | [] -> (pos, spc) ] -and print_begin_end tab pos spc ov pl = - if ov || has_comment pl then print_beg_end tab pos spc pl - else hprint_box tab pos spc pl -and print_beg_end tab pos spc = - fun - [ [p :: pl] -> - let (npos, nspc) = print_pretty tab pos spc p in - if match pl with - [ [] -> True - | _ -> False ] - then - (npos, nspc) - else if tolerate tab npos nspc then do { - let nspc = if npos == tab then nspc + dt.val else nspc in - print_spaces nspc; - print_beg_end_rest tab (npos + nspc) pl - } - else do { - print_newline_and_tab (tab + dt.val); - print_beg_end_rest tab (tab + dt.val) pl - } - | [] -> (pos, spc) ] -and print_beg_end_rest tab pos = - fun - [ [p :: pl] -> - let (pos, spc) = print_pretty (tab + dt.val) pos 0 p in - if match pl with - [ [] -> True - | _ -> False ] - then - (pos, spc) - else do { - print_newline_and_tab tab; - print_beg_end_rest tab tab pl - } - | [] -> (pos, 0) ] -; - -value string_npos s = String.length s; - -value rec conv = - fun - [ S g s -> SL (string_npos s) g s - | Hbox x -> HL (conv_stream x) - | HVbox x -> BL (conv_stream x) - | HOVbox x -> - match conv_stream x with - [ [(PL _ as x)] -> x - | x -> PL x ] - | HOVCbox x -> QL (conv_stream x) - | Vbox x -> VL (conv_stream x) - | BEbox x -> BE (conv_stream x) - | BEVbox x -> BV (conv_stream x) - | LocInfo (bp, ep) x -> - let (comm, nl_bef, tab_bef, cnt) = - let len = bp - last_ep.val in - if len > 0 then getcomm.val last_ep.val len - else ("", 0, 0, 0) - in - do { - last_ep.val := last_ep.val + cnt; - let v = conv x in - last_ep.val := max ep last_ep.val; - LI (comm, nl_bef, tab_bef) v - } ] -and conv_stream = - parser - [ [: `p; s :] -> let x = conv p in [x :: conv_stream s] - | [: :] -> [] ] -; - -value print_pretty pr_ch pr_str pr_nl pr pr2 m lf bp p = - do { - maxl.val := m; - print_char_fun.val := pr_ch; - print_string_fun.val := pr_str; - print_newline_fun.val := pr_nl; - prompt.val := pr2; - getcomm.val := lf; - last_ep.val := bp; - print_string pr; - let _ = print_pretty 0 0 0 (conv p) in - () - } -; diff --git a/camlp4/camlp4/spretty.mli b/camlp4/camlp4/spretty.mli deleted file mode 100644 index 6ce1fd8fc0..0000000000 --- a/camlp4/camlp4/spretty.mli +++ /dev/null @@ -1,54 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1998 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* Hbox: horizontal box - HVbox: horizontal-vertical box - HOVbox and HOVCbox: fill maximum of elements horizontally, line by line; - in HOVbox, if an element has to be displayed vertically (need several - lines), the next element is displayed next line; in HOVCbox, this next - element may be displayed same line if it holds. - Vbox: vertical box - BEbox: begin-end box: horizontal or 2nd element indented, 3rd element not - BEVbox: begin-end box always vertical - LocInfo: call back with location to allow inserting comments *) - -(* In case of box displayed vertically, 2nd line and following are indented - by dt.val spaces, except if first element of the box is empty: to not - indent, put HVbox [: :] as first element *) - -type glue = [ LO | RO | LR | NO ]; -type pretty = - [ S of glue and string - | Hbox of Stream.t pretty - | HVbox of Stream.t pretty - | HOVbox of Stream.t pretty - | HOVCbox of Stream.t pretty - | Vbox of Stream.t pretty - | BEbox of Stream.t pretty - | BEVbox of Stream.t pretty - | LocInfo of (int * int) and pretty ] -; -type getcomm = int -> int -> (string * int * int * int); - -value print_pretty : - (char -> unit) -> (string -> unit) -> (unit -> unit) -> - string -> string -> int -> getcomm -> int -> pretty -> unit; -value quiet : ref bool; - -value dt : ref int; - -(*--*) - -value tol : ref int; -value sp : ref char; diff --git a/camlp4/compile/.cvsignore b/camlp4/compile/.cvsignore deleted file mode 100644 index 47817ccef6..0000000000 --- a/camlp4/compile/.cvsignore +++ /dev/null @@ -1,4 +0,0 @@ -*.fast -*.fast.opt -o_fast.ml -pa_o_fast.ml diff --git a/camlp4/compile/.depend b/camlp4/compile/.depend deleted file mode 100644 index 5031b171af..0000000000 --- a/camlp4/compile/.depend +++ /dev/null @@ -1,4 +0,0 @@ -compile.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi -compile.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx -comp_trail.cmo: ../camlp4/pcaml.cmi -comp_trail.cmx: ../camlp4/pcaml.cmx diff --git a/camlp4/compile/Makefile b/camlp4/compile/Makefile deleted file mode 100644 index 277652b1c9..0000000000 --- a/camlp4/compile/Makefile +++ /dev/null @@ -1,45 +0,0 @@ -# $Id$ - -include ../config/Makefile - -INCLUDES=-I ../camlp4 -I ../boot -OCAMLCFLAGS=-warn-error A $(INCLUDES) -SRC=../etc/pa_o.ml ../etc/pa_op.ml -D=o -COMP_OPT=-strict_parsing -COMP_OPT=-e "Grammar.Entry.obj Pcaml.interf" -e "Grammar.Entry.obj Pcaml.implem" -e "Grammar.Entry.obj Pcaml.top_phrase" -e "Grammar.Entry.obj Pcaml.use_file" - -all: out - -out: camlp4$D.fast -opt: camlp4$D.fast.opt - -camlp4$D.fast: pa_$D_fast.cmo - rm -f camlp4$D.fast - cd ../camlp4; $(MAKE) CAMLP4=../compile/camlp4$D.fast CAMLP4M="../compile/pa_$D_fast.cmo ../meta/pr_dump.cmo" - -camlp4$D.fast.opt: pa_$D_fast.cmx - rm -f camlp4$D.fast.opt - cd ../camlp4; $(MAKE) optp4 CAMLP4OPT=../compile/camlp4$D.fast.opt CAMLP4M="../compile/pa_$D_fast.cmx ../meta/pr_dump.cmx" - -pa_$D_fast.ml: comp_head.ml $D_fast.ml comp_trail.ml - cat $(SRC) | sed -e "s/Plexer.gmake ()/P.lexer/" -e "/EXTEND/,/END/d" -e "/Grammar.Entry.of_parser/d" -e "/Grammar.Entry.gcreate/d" | cat comp_head.ml - $D_fast.ml comp_trail.ml > pa_$D_fast.ml - -$D_fast.ml: compile.cmo $(SRC) - OTOP=$(OTOP) EXE=$(EXE) ./compile.sh $(COMP_OPT) $(SRC) > $D_fast.ml - -install: - if test -f camlp4o.fast.opt; then cp camlp4o.fast.opt $(BINDIR)/camlp4o.opt$(EXE); fi - -clean:: - rm -f *.cm* *.pp[io] *.o *.bak .*.bak *.out *.opt - rm -f *.fast tmp.* pa_*_fast.ml *_fast.ml - -depend: - cp .depend .depend.bak - > .depend - @for i in *.mli *.ml; do \ - ../tools/apply.sh pr_depend.cmo -- $(INCLUDES) $$i >> .depend || : ; \ - done - -include .depend diff --git a/camlp4/compile/comp_head.ml b/camlp4/compile/comp_head.ml deleted file mode 100644 index 5efa064073..0000000000 --- a/camlp4/compile/comp_head.ml +++ /dev/null @@ -1,70 +0,0 @@ -(* camlp4r q_MLast.cmo pa_extend.cmo *) -(* $Id$ *) - -module P = - struct - value gloc bp strm = Grammar.loc_of_token_interval bp (Stream.count strm); - value list0 symb = - let rec loop al = - parser - [ [: a = symb; s :] -> loop [a :: al] s - | [: :] -> al ] - in - parser [: a = loop [] :] -> List.rev a - ; - value list0sep symb sep = - let rec kont al = - parser - [ [: v = sep; a = symb; s :] -> kont [a :: al] s - | [: :] -> al ] - in - parser - [ [: a = symb; s :] -> List.rev (kont [a] s) - | [: :] -> [] ] - ; - value list1 symb = - let rec loop al = - parser - [ [: a = symb; s :] -> loop [a :: al] s - | [: :] -> al ] - in - parser [: a = symb; s :] -> List.rev (loop [a] s) - ; - value list1sep symb sep = - let rec kont al = - parser - [ [: v = sep; a = symb; s :] -> kont [a :: al] s - | [: :] -> al ] - in - parser [: a = symb; s :] -> List.rev (kont [a] s) - ; - value option f = - parser - [ [: x = f :] -> Some x - | [: :] -> None ] - ; - value token (p_con, p_prm) = - if p_prm = "" then parser [: `(con, prm) when con = p_con :] -> prm - else parser [: `(con, prm) when con = p_con && prm = p_prm :] -> prm - ; - value orzero f f0 = - parser bp - [ [: x = f :] -> x - | [: x = f0 :] ep -> -(* -let (loc1, loc2) = Grammar.loc_of_token_interval bp ep in -let _ = do { Printf.eprintf "recovered or_zero at loc (%d, %d)\n" loc1 loc2; flush stderr } in -*) - x ] - ; - value error entry prev_symb symb = - symb ^ " expected" ^ - (if prev_symb = "" then "" else " after " ^ prev_symb) ^ - " (in [" ^ entry ^ "])" - ; - value lexer = Plexer.gmake (); - end -; - -(****************************************) - diff --git a/camlp4/compile/comp_trail.ml b/camlp4/compile/comp_trail.ml deleted file mode 100644 index 75f40abbf4..0000000000 --- a/camlp4/compile/comp_trail.ml +++ /dev/null @@ -1,33 +0,0 @@ -(* camlp4r pa_extend.cmo *) -(****************************************) - -value interf_p = - Grammar.Entry.of_parser Pcaml.gram "interf" interf_0 -; - -value implem_p = - Grammar.Entry.of_parser Pcaml.gram "implem" implem_0 -; - -value top_phrase_p = - Grammar.Entry.of_parser Pcaml.gram "top_phrase" top_phrase_0 -; - -value use_file_p = - Grammar.Entry.of_parser Pcaml.gram "use_file" use_file_0 -; - -EXTEND - interf: - [ [ x = interf_p -> x ] ] - ; - implem: - [ [ x = implem_p -> x ] ] - ; - top_phrase: - [ [ x = top_phrase_p -> x ] ] - ; - use_file: - [ [ x = use_file_p -> x ] ] - ; -END; diff --git a/camlp4/compile/compile.ml b/camlp4/compile/compile.ml deleted file mode 100644 index 5fff04b27d..0000000000 --- a/camlp4/compile/compile.ml +++ /dev/null @@ -1,571 +0,0 @@ -(* camlp4r *) -(* $Id$ *) - -#load "q_MLast.cmo"; - -open Gramext; - -value strict_parsing = ref False; -value keywords = ref []; - -value loc = (0, 0); - -(* Watch the segmentation faults here! the compiled file must have been - loaded in camlp4 with the option pa_extend.cmo -meta_action. *) -value magic_act (act : Obj.t) : MLast.expr = Obj.magic act; - -(* Names of symbols for error messages; code borrowed to grammar.ml *) - -value rec name_of_symbol entry = - fun - [ Snterm e -> "[" ^ e.ename ^ "]" - | Snterml e l -> "[" ^ e.ename ^ " level " ^ l ^ "]" - | Sself | Snext -> "[" ^ entry.ename ^ "]" - | Stoken tok -> entry.egram.glexer.Token.tok_text tok - | _ -> "???" ] -; - -value rec name_of_symbol_failed entry = - fun - [ Slist0 s -> name_of_symbol_failed entry s - | Slist0sep s _ -> name_of_symbol_failed entry s - | Slist1 s -> name_of_symbol_failed entry s - | Slist1sep s _ -> name_of_symbol_failed entry s - | Sopt 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 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 - | _ -> txt ^ " or " ^ name_of_tree_failed entry bro ] - in - txt - | DeadEnd | LocAct _ _ -> "???" ] -; - -value tree_failed entry prev_symb tree = - let (s2, s3) = - let txt = name_of_tree_failed entry tree in - match prev_symb with - [ Slist0 s -> - let txt1 = name_of_symbol_failed entry s in - ("", txt1 ^ " or " ^ txt) - | Slist1 s -> - let txt1 = name_of_symbol_failed entry s in - ("", txt1 ^ " or " ^ txt) - | Slist0sep s sep -> - let txt1 = name_of_symbol_failed entry s in - ("", txt1 ^ " or " ^ txt) - | Slist1sep s sep -> - let txt1 = name_of_symbol_failed entry s in - ("", txt1 ^ " or " ^ txt) - | Sopt _ | Stree _ -> ("", txt) - | _ -> (name_of_symbol entry prev_symb, txt) ] - in - <:expr< - P.error $str:entry.ename$ $str:String.escaped s2$ $str:String.escaped s3$ - >> -; - -(* Compilation *) - -value rec find_act = - fun - [ DeadEnd -> failwith "find_act" - | LocAct act _ -> (magic_act act, 0) - | Node {son = son; brother = bro} -> - let (act, n) = try find_act son with [ Failure _ -> find_act bro ] in - (act, n + 1) ] -; - -value level_number e l = - match e.edesc with - [ Dlevels elevs -> - loop 0 elevs where rec loop n = - fun - [ [lev :: levs] -> if lev.lname = Some l then n else loop (n + 1) levs - | [] -> failwith ("level " ^ l ^ " not found in entry " ^ e.ename) ] - | Dparser _ -> 0 ] -; - -value nth_patt_of_act (e, n) = - let patt_list = - loop e where rec loop = - fun - [ <:expr< fun (loc : (int * int)) -> $_$ >> -> [] - | <:expr< fun ($p$ : $_$) -> $e$ >> -> [p :: loop e] - | <:expr< fun $p$ -> $e$ >> -> [p :: loop e] - | _ -> failwith "nth_patt_of_act" ] - in - List.nth patt_list n -; - -value rec last_patt_of_act = - fun - [ <:expr< fun ($p$ : $_$) (loc : (int * int)) -> $_$ >> -> p - | <:expr< fun $_$ -> $e$ >> -> last_patt_of_act e - | _ -> failwith "last_patt_of_act" ] -; - -value rec final_action = - fun - [ <:expr< fun (loc : (int * int)) -> ($e$ : $_$) >> -> e - | <:expr< fun $_$ -> $e$ >> -> final_action e - | _ -> failwith "final_action" ] -; - -value parse_standard_symbol e rkont fkont ending_act = - <:expr< - match try Some ($e$ strm__) with [ Stream.Failure -> None ] with - [ Some $nth_patt_of_act ending_act$ -> $rkont$ - | _ -> $fkont$ ] - >> -; - -value parse_symbol_no_failure e rkont fkont ending_act = - <:expr< - let $nth_patt_of_act ending_act$ = - try $e$ strm__ with [ Stream.Failure -> raise (Stream.Error "") ] - in - $rkont$ - >> -; - -value rec contain_loc = - fun - [ <:expr< $lid:s$ >> -> s = "loc" - | <:expr< $uid:_$ >> -> False - | <:expr< $str:_$ >> -> False - | <:expr< ($list:el$) >> -> List.exists contain_loc el - | <:expr< $e1$ $e2$ >> -> contain_loc e1 || contain_loc e2 - | _ -> True ] -; - -value gen_let_loc loc e = - if contain_loc e then <:expr< let loc = P.gloc bp strm__ in $e$ >> else e -; - -value phony_entry = Grammar.Entry.obj Pcaml.implem; - -value rec parse_tree entry nlevn alevn (tree, fst_symb) act_kont kont = - match tree with - [ DeadEnd -> kont - | LocAct act _ -> - let act = magic_act act in - act_kont False act - | Node {node = Sself; son = LocAct act _; brother = bro} -> - let act = magic_act act in - let n = entry.ename ^ "_" ^ string_of_int alevn in - let e = - if strict_parsing.val || alevn = 0 || fst_symb then <:expr< $lid:n$ >> - else <:expr< P.orzero $lid:n$ $lid:entry.ename ^ "_0"$ >> - in - let p2 = - match bro with - [ DeadEnd -> kont - | _ -> parse_tree entry nlevn alevn (bro, fst_symb) act_kont kont ] - in - let p1 = act_kont True act in - parse_standard_symbol e p1 p2 (act, 0) - | Node {node = s; son = LocAct act _; brother = bro} -> - let act = magic_act act in - let p2 = parse_tree entry nlevn alevn (bro, fst_symb) act_kont kont in - let p1 = act_kont False act in - parse_symbol entry nlevn s p1 p2 (act, 0) - | Node {node = s; son = son; brother = bro} -> - let p2 = parse_tree entry nlevn alevn (bro, fst_symb) act_kont kont in - let p1 = - let err = - let txt = tree_failed entry s son in - <:expr< raise (Stream.Error $txt$) >> - in - match son with - [ Node {brother = DeadEnd} -> - parse_tree entry nlevn alevn (son, False) act_kont err - | _ -> - let p1 = - parse_tree entry nlevn alevn (son, True) act_kont - <:expr< raise Stream.Failure >> - in - <:expr< try $p1$ with [ Stream.Failure -> $err$ ] >> ] - in - parse_symbol entry nlevn s p1 p2 (find_act son) ] -and parse_symbol entry nlevn s rkont fkont ending_act = - match s with - [ Slist0 s -> - let e = <:expr< P.list0 $symbol_parser entry nlevn s$ >> in - parse_symbol_no_failure e rkont fkont ending_act - | Slist1 s -> - let e = <:expr< P.list1 $symbol_parser entry nlevn s$ >> in - parse_standard_symbol e rkont fkont ending_act - | Slist0sep s sep -> - let e = - <:expr< - P.list0sep $symbol_parser entry nlevn s$ - $symbol_parser entry nlevn sep$ >> - in - parse_symbol_no_failure e rkont fkont ending_act - | Slist1sep s sep -> - let e = - <:expr< - P.list1sep $symbol_parser entry nlevn s$ - $symbol_parser entry nlevn sep$ >> - in - parse_standard_symbol e rkont fkont ending_act - | Sopt s -> - let e = <:expr< P.option $symbol_parser entry nlevn s$ >> in - parse_symbol_no_failure e rkont fkont ending_act - | Stree tree -> - let kont = <:expr< raise Stream.Failure >> in - let act_kont _ act = gen_let_loc loc (final_action act) in - let e = parse_tree phony_entry 0 0 (tree, True) act_kont kont in - parse_standard_symbol <:expr< fun strm__ -> $e$ >> rkont fkont ending_act - | Snterm e -> - let n = - match e.edesc with - [ Dparser _ -> e.ename - | Dlevels _ -> e.ename ^ "_0" ] - in - parse_standard_symbol <:expr< $lid:n$ >> rkont fkont ending_act - | Snterml e l -> - let n = e.ename ^ "_" ^ string_of_int (level_number e l) in - parse_standard_symbol <:expr< $lid:n$ >> rkont fkont ending_act - | Sself -> - let n = entry.ename ^ "_0" in - parse_standard_symbol <:expr< $lid:n$ >> rkont fkont ending_act - | Snext -> - let n = entry.ename ^ "_" ^ string_of_int nlevn in - parse_standard_symbol <:expr< $lid:n$ >> rkont fkont ending_act - | Stoken tok -> - let _ = - do { - if fst tok = "" && not (List.mem (snd tok) keywords.val) then - keywords.val := [snd tok :: keywords.val] - else () - } - in - let p = - let patt = nth_patt_of_act ending_act in - let p_con = String.escaped (fst tok) in - let p_prm = String.escaped (snd tok) in - if snd tok = "" then - if fst tok = "ANY" then <:patt< (_, $patt$) >> - else <:patt< ($str:p_con$, $patt$) >> - else - let p = <:patt< ($str:p_con$, $str:p_prm$) >> in - match patt with - [ <:patt< _ >> -> <:patt< ($str:p_con$, $str:p_prm$) >> - | _ -> <:patt< ($str:p_con$, ($str:p_prm$ as $patt$)) >> ] - in - <:expr< - match Stream.peek strm__ with - [ Some $p$ -> do { Stream.junk strm__; $rkont$ } - | _ -> $fkont$ ] - >> - | _ -> - parse_standard_symbol <:expr< not_impl >> rkont fkont ending_act ] -and symbol_parser entry nlevn = - fun - [ Snterm e -> - let n = e.ename ^ "_0" in - <:expr< $lid:n$ >> - | Snterml e l -> - let n = e.ename ^ "_" ^ string_of_int (level_number e l) in - <:expr< $lid:n$ >> - | Snext -> - let n = entry.ename ^ "_" ^ string_of_int nlevn in - if strict_parsing.val then <:expr< $lid:n$ >> - else - let n0 = entry.ename ^ "_0" in - <:expr< P.orzero $lid:n$ $lid:n0$ >> - | Stoken tok -> - let _ = - do { - if fst tok = "" && not (List.mem (snd tok) keywords.val) then - keywords.val := [snd tok :: keywords.val] - else () - } - in - let p_con = String.escaped (fst tok) in - let p_prm = String.escaped (snd tok) in - <:expr< P.token ($str:p_con$, $str:p_prm$) >> - | Stree tree -> - let kont = <:expr< raise Stream.Failure >> in - let act_kont _ act = final_action act in - <:expr< - fun strm__ -> - $parse_tree phony_entry 0 0 (tree, True) act_kont kont$ - >> - | _ -> - <:expr< aaa >> ] -; - -value rec start_parser_of_levels entry clevn levs = - let n = entry.ename ^ "_" ^ string_of_int clevn in - let next = entry.ename ^ "_" ^ string_of_int (clevn + 1) in - let p = <:patt< $lid:n$ >> in - match levs with - [ [] -> [Some (p, <:expr< fun strm__ -> raise Stream.Failure >>)] - | [lev :: levs] -> - let pel = start_parser_of_levels entry (succ clevn) levs in - match lev.lprefix with - [ DeadEnd -> - let ncont = - if not strict_parsing.val && clevn = 0 then - entry.ename ^ "_gen_cont" - else entry.ename ^ "_" ^ string_of_int clevn ^ "_cont" - in - let curr = - <:expr< let a = $lid:next$ strm__ in $lid:ncont$ bp a strm__ >> - in - let curr = <:expr< let bp = Stream.count strm__ in $curr$ >> in - let e = <:expr< fun strm__ -> $curr$ >> in - let pel = if levs = [] then [] else pel in - [Some (p, e) :: pel] - | tree -> - let alevn = clevn in - let (kont, pel) = - match levs with - [ [] -> (<:expr< raise Stream.Failure >>, []) - | _ -> - let e = - match (lev.assoc, lev.lsuffix) with - [ (NonA, _) | (_, DeadEnd) -> <:expr< $lid:next$ strm__ >> - | _ -> - let ncont = - entry.ename ^ "_" ^ string_of_int clevn ^ "_cont" - in - <:expr< - let a = $lid:next$ strm__ in - $lid:ncont$ bp a strm__ - >> ] - in - (e, pel) ] - in - let act_kont end_with_self act = - if lev.lsuffix = DeadEnd then gen_let_loc loc (final_action act) - else - let ncont = entry.ename ^ "_" ^ string_of_int clevn ^ "_cont" in - gen_let_loc loc - <:expr< $lid:ncont$ bp $final_action act$ strm__ >> - in - let curr = - parse_tree entry (succ clevn) alevn (tree, True) act_kont kont - in - let curr = <:expr< let bp = Stream.count strm__ in $curr$ >> in - let e = <:expr< fun strm__ -> $curr$ >> in - [Some (p, e) :: pel] ] ] -; - -value rec continue_parser_of_levels entry clevn levs = - let n = entry.ename ^ "_" ^ string_of_int clevn ^ "_cont" in - let p = <:patt< $lid:n$ >> in - match levs with - [ [] -> [None] - | [lev :: levs] -> - let pel = continue_parser_of_levels entry (succ clevn) levs in - match lev.lsuffix with - [ DeadEnd -> - [None :: pel] - | tree -> - let alevn = - match lev.assoc with - [ LeftA | NonA -> succ clevn - | RightA -> clevn ] - in - let (kont, pel) = - match levs with - [ [] -> (<:expr< a__ >>, []) - | _ -> (<:expr< a__ >>, pel) ] - in - let act_kont end_with_self act = - let p = last_patt_of_act act in - match lev.assoc with - [ RightA | NonA -> - <:expr< - let $p$ = a__ in - $gen_let_loc loc (final_action act)$ - >> - | LeftA -> - let ncont = - entry.ename ^ "_" ^ string_of_int clevn ^ "_cont" - in - gen_let_loc loc - <:expr< - let $p$ = a__ in - $lid:ncont$ bp $final_action act$ strm__ - >> ] - in - let curr = - parse_tree entry (succ clevn) alevn (tree, True) act_kont kont - in - let e = <:expr< fun bp a__ strm__ -> $curr$ >> in - [Some (p, e) :: pel] ] ] -; - -value continue_parser_of_levels_again entry levs = - let n = entry.ename ^ "_gen_cont" in - let e = - loop <:expr< a__ >> 0 levs where rec loop var levn = - fun - [ [] -> <:expr< if x == a__ then x else $lid:n$ bp x strm__ >> - | [lev :: levs] -> - match lev.lsuffix with - [ DeadEnd -> loop var (levn + 1) levs - | _ -> - let n = entry.ename ^ "_" ^ string_of_int levn ^ "_cont" in - let rest = loop <:expr< x >> (levn + 1) levs in - <:expr< let x = $lid:n$ bp $var$ strm__ in $rest$ >> ] ] - in - (<:patt< $lid:n$ >>, <:expr< fun bp a__ strm__ -> $e$ >>) -; - -value empty_entry ename = - let p = <:patt< $lid:ename$ >> in - let e = - <:expr< - fun strm__ -> - raise (Stream.Error $str:"entry [" ^ ename ^ "] is empty"$) >> - in - [Some (p, e)] -; - -value start_parser_of_entry entry = - match entry.edesc with - [ Dlevels [] -> empty_entry entry.ename - | Dlevels elev -> start_parser_of_levels entry 0 elev - | Dparser p -> [] ] -; - -value continue_parser_of_entry entry = - match entry.edesc with - [ Dlevels elev -> continue_parser_of_levels entry 0 elev - | Dparser p -> [] ] -; - -value continue_parser_of_entry_again entry = - if strict_parsing.val then [] - else - match entry.edesc with - [ Dlevels ([_; _ :: _] as levs) -> - [continue_parser_of_levels_again entry levs] - | _ -> [] ] -; - -value rec list_alternate l1 l2 = - match (l1, l2) with - [ ([x1 :: l1], [x2 :: l2]) -> [x1; x2 :: list_alternate l1 l2] - | ([], l2) -> l2 - | (l1, []) -> l1 ] -; - -value compile_entry entry = - let pel1 = start_parser_of_entry entry in - let pel2 = continue_parser_of_entry entry in - let pel = list_alternate pel1 pel2 in - List.fold_right - (fun pe list -> - match pe with - [ Some pe -> [pe :: list] - | None -> list ]) - pel (continue_parser_of_entry_again entry) -; - -(* get all entries connected together *) - -value rec scan_tree list = - fun - [ Node {node = n; son = son; brother = bro} -> - let list = scan_symbol list n in - let list = scan_tree list son in - let list = scan_tree list bro in - list - | LocAct _ _ | DeadEnd -> list ] -and scan_symbol list = - fun - [ Snterm e -> scan_entry list e - | Snterml e l -> scan_entry list e - | Slist0 s -> scan_symbol list s - | Slist0sep s sep -> scan_symbol (scan_symbol list s) sep - | Slist1 s -> scan_symbol list s - | Slist1sep s sep -> scan_symbol (scan_symbol list s) sep - | Sopt s -> scan_symbol list s - | Stree t -> scan_tree list t - | Smeta _ _ _ | Sself | Snext | Stoken _ -> list ] -and scan_level list lev = - let list = scan_tree list lev.lsuffix in - let list = scan_tree list lev.lprefix in - list -and scan_levels list levs = List.fold_left scan_level list levs -and scan_entry list entry = - if List.memq entry list then list - else - match entry.edesc with - [ Dlevels levs -> scan_levels [entry :: list] levs - | Dparser _ -> list ] -; - -value all_entries_in_graph list entry = - List.rev (scan_entry list entry) -; - -(* main *) - -value entries = ref []; - -value rec list_mem_right_assoc x = - fun - [ [] -> False - | [(a, b) :: l] -> x = b || list_mem_right_assoc x l ] -; - -value rec expr_list = - fun - [ [] -> <:expr< [] >> - | [x :: l] -> <:expr< [$str:String.escaped x$ :: $expr_list l$] >> ] -; - -value compile () = - let _ = do { keywords.val := []; } in - let list = List.fold_left all_entries_in_graph [] entries.val in - let list = - List.filter (fun e -> List.memq e list) entries.val @ - List.filter (fun e -> not (List.memq e entries.val)) list - in - let list = - let set = ref [] in - List.fold_right - (fun entry list -> - if List.mem entry.ename set.val then - list - else do { set.val := [entry.ename :: set.val]; [entry :: list] }) - list [] - in - let pell = List.map compile_entry list in - let pel = List.flatten pell in - let si1 = <:str_item< value rec $list:pel$ >> in - let si2 = - let list = List.sort compare keywords.val in - <:str_item< - List.iter (fun kw -> P.lexer.Token.tok_using ("", kw)) - $expr_list list$ - >> - in - let loc = (1, 1) in - ([(si1, loc); (si2, loc)], False) -; - -Pcaml.parse_implem.val := fun _ -> compile (); - -Pcaml.add_option "-strict_parsing" (Arg.Set strict_parsing) - "Don't generate error recovering by trying continuations or first levels" -; diff --git a/camlp4/compile/compile.sh b/camlp4/compile/compile.sh deleted file mode 100755 index 1e86d6f7eb..0000000000 --- a/camlp4/compile/compile.sh +++ /dev/null @@ -1,27 +0,0 @@ -#!/bin/sh -e - -ARGS= -FILES= -ENTRIES= -while test "" != "$1"; do - case $1 in - -e) - shift; - if test "$ENTRIES" != ""; then ENTRIES="$ENTRIES; "; fi - ENTRIES="$ENTRIES$1";; - *.ml*) FILES="$FILES $1";; - *) ARGS="$ARGS $1";; - esac - shift -done - -cat $FILES | sed -e 's/Pcaml.parse_i.*$//' > tmp.ml -echo "Compile.entries.val := [$ENTRIES];" >> tmp.ml -> tmp.mli -$OTOP/boot/ocamlrun$EXE $OTOP/boot/ocamlc -I $OTOP/boot -c tmp.mli -$OTOP/boot/ocamlrun$EXE ../meta/camlp4r$EXE -I ../meta pa_extend.cmo q_MLast.cmo -meta_action tmp.ml -o tmp.ppo -$OTOP/boot/ocamlrun$EXE $OTOP/boot/ocamlc -I $OTOP/boot -I ../lib -I ../camlp4 -c -impl tmp.ppo -rm tmp.ppo -> tmp.null -$OTOP/boot/ocamlrun$EXE ../camlp4/camlp4$EXE ./compile.cmo ./tmp.cmo ../etc/pr_r.cmo ../etc/pr_rp.cmo $ARGS -sep "\n\n" -impl tmp.null -rm tmp.* diff --git a/camlp4/config/.cvsignore b/camlp4/config/.cvsignore deleted file mode 100644 index f9761cda36..0000000000 --- a/camlp4/config/.cvsignore +++ /dev/null @@ -1,2 +0,0 @@ -Makefile.cnf -Makefile diff --git a/camlp4/config/Makefile-nt.cnf b/camlp4/config/Makefile-nt.cnf deleted file mode 100644 index 379f338507..0000000000 --- a/camlp4/config/Makefile-nt.cnf +++ /dev/null @@ -1,7 +0,0 @@ -EXE=.exe -OPT= -OTOP=../.. -OLIBDIR=$(OTOP)/boot -BINDIR=C:/ocaml/bin -LIBDIR=C:/ocaml/lib -MANDIR=C:/ocaml/man diff --git a/camlp4/config/Makefile.tpl b/camlp4/config/Makefile.tpl deleted file mode 100644 index 0602525a62..0000000000 --- a/camlp4/config/Makefile.tpl +++ /dev/null @@ -1,28 +0,0 @@ -# $Id$ - -CAMLP4_COMM=OTOP=$(OTOP) OPT=$(OPT) EXE=$(EXE) ../tools/camlp4_comm.sh -OCAMLC=@OTOP=$(OTOP) OPT=$(OPT) EXE=$(EXE) ../tools/ocamlc.sh -OCAMLOPT=@OTOP=$(OTOP) OPT=$(OPT) EXE=$(EXE) ../tools/ocamlopt.sh -OCAMLCFLAGS= -MKDIR=mkdir -p - -.SUFFIXES: .cmx .cmo .cmi .ml .mli - -.mli.cmi: - @if test `basename $<` != $<; then echo "Bad directory"; exit 1; fi - @$(CAMLP4_COMM) $< -o $*.ppi - $(OCAMLC) $(OCAMLCFLAGS) -c -intf $*.ppi - rm -f $*.ppi - -.ml.cmo: - @if test `basename $<` != $<; then echo "Bad directory"; exit 1; fi - @$(CAMLP4_COMM) $< -o $*.ppo - $(OCAMLC) $(OCAMLCFLAGS) -c -impl $*.ppo - rm -f $*.ppo - -.ml.cmx: - @if test `basename $<` != $<; then echo "Bad directory"; exit 1; fi - @$(CAMLP4_COMM) $< -o $*.ppo - $(OCAMLOPT) $(OCAMLCFLAGS) -c -impl $*.ppo - rm -f $*.ppo - diff --git a/camlp4/config/config.mpw b/camlp4/config/config.mpw deleted file mode 100644 index 08fe278d4c..0000000000 --- a/camlp4/config/config.mpw +++ /dev/null @@ -1,50 +0,0 @@ -####################################################################### -# # -# Camlp4 # -# # -# Damien Doligez, projet Para, INRIA Rocquencourt # -# # -# Copyright 1999 Institut National de Recherche en Informatique et # -# en Automatique. Distributed only by permission. # -# # -####################################################################### - -# $Id$ - -set -e P4LIBDIR "{LIBDIR}camlp4:" -set -e MANDIR "{mpw}" -set -e OTOP "`directory `:" -set -e OLIBDIR "{OTOP}boot:" - -set -e CAMLP4_COMM ::tools:camlp4_comm.mpw -set -e OCAMLC ::tools:ocamlc.mpw - -set -e defrules "¶n¶ -.cmi Ä .mli ¶n¶ - ¶{CAMLP4_COMM¶} ¶{depdir¶}¶{default¶}.mli -o ¶{depdir¶}¶{default¶}.ppi ¶n¶ - ¶{OCAMLC¶} ¶{OCAMLCFLAGS¶} -c -intf ¶{depdir¶}¶{default¶}.ppi ¶n¶ - delete -y -i ¶{depdir¶}¶{default¶}.ppi ¶n¶ -¶n¶ -.cmo Ä .ml ¶n¶ - ¶{CAMLP4_COMM¶} ¶{depdir¶}¶{default¶}.ml -o ¶{depdir¶}¶{default¶}.ppo ¶n¶ - ¶{OCAMLC¶} ¶{OCAMLCFLAGS¶} -c -impl ¶{depdir¶}¶{default¶}.ppo ¶n¶ - delete -y -i ¶{depdir¶}¶{default¶}.ppo ¶n¶ -¶n¶ -.cmi Ä .cmo ¶n¶ - set status 0 ¶n¶ -¶n¶ -clean ÄÄ ¶n¶ - begin ¶n¶ - delete -i Å.cm[ioa] || set status 0 ¶n¶ - delete -i Å.pp[io] || set status 0 ¶n¶ - delete -i Å.bak || set status 0 ¶n¶ - end ³ dev:null ¶n¶ -" - -set -e dependrule "¶n¶ -depend Ķn¶ - duplicate -y Makefile.Mac.depend Makefile.Mac.depend.bak || set status 0¶n¶ - for i in Å.mliÇ0,1ȶn¶ - ::tools:apply.mpw pr_depend.cmo -- ¶{INCLUDES¶} ¶{i¶}¶n¶ - end > Makefile.Mac.depend¶n¶ -" diff --git a/camlp4/config/configure_batch b/camlp4/config/configure_batch deleted file mode 100755 index 49b3dafca5..0000000000 --- a/camlp4/config/configure_batch +++ /dev/null @@ -1,113 +0,0 @@ -#! /bin/sh -# $Id$ - -prefix=/usr/local -bindir='' -libdir='' -mandir='' -ocaml_top=../ocaml_stuff - -# Parse command-line arguments - -while : ; do - case "$1" in - "") break;; - -prefix|--prefix) - prefix=$2; shift;; - -bindir|--bindir) - bindir=$2; shift;; - -libdir|--libdir) - libdir=$2; shift;; - -mandir|--mandir) - mandir=$2; shift;; - -ocaml-top) - ocaml_top=$2; shift;; - *) echo "Unknown option \"$1\"." 1>&2; exit 2;; - esac - shift -done - -# Sanity checks - -case "$prefix" in - /*) ;; - *) echo "The -prefix directory must be absolute." 1>&2; exit 2;; -esac -case "$bindir" in - /*) ;; - "") ;; - *) echo "The -bindir directory must be absolute." 1>&2; exit 2;; -esac -case "$libdir" in - /*) ;; - "") ;; - *) echo "The -libdir directory must be absolute." 1>&2; exit 2;; -esac -case "$mandir" in - /*) ;; - "") ;; - *) echo "The -mandir directory must be absolute." 1>&2; exit 2;; -esac - -# Generate the files - -rm -f Makefile.cnf -touch Makefile.cnf - -# Check Ocaml - -for i in utils parsing otherlibs/dynlink; do - if test ! -d "$ocaml_top/$i"; then - echo "Bad value $ocaml_top for option -ocaml-top" - echo "There is no directory $ocaml_top/$i" - echo "Configuration script failed" - exit 1 - fi -done - -echo "EXE=$EXE" >> Makefile.cnf -echo "O=o" >> Makefile.cnf -echo "A=a" >> Makefile.cnf -echo "OPT=" >> Makefile.cnf -echo "OTOP=$ocaml_top" >> Makefile.cnf - -if test "$ocaml_top" = "../ocaml_stuff"; then - if ocamlc -v >/dev/null 2>&1; then - : - else - echo "You need the command ocamlc accessible in the path!" - echo "Configuration script failed!" - exit 1 - fi - OLIBDIR=`ocamlc -where` - echo "OLIBDIR=$OLIBDIR" >> Makefile.cnf -else - echo "OLIBDIR=\$(OTOP)/boot" >> Makefile.cnf -fi - -# Where to install - -echo "PREFIX=$prefix" >> Makefile.cnf -case "$bindir" in - "") echo 'BINDIR=$(PREFIX)/bin' >> Makefile.cnf - bindir="$prefix/bin";; - *) echo "BINDIR=$bindir" >> Makefile.cnf;; -esac -case "$libdir" in - "") echo 'LIBDIR=$(PREFIX)/lib/camlp4' >> Makefile.cnf - libdir="$prefix/lib/camlp4";; - *) echo "LIBDIR=$libdir" >> Makefile.cnf;; -esac -case "$mandir" in - "") echo 'MANDIR=$(PREFIX)/man/man1' >> Makefile.cnf - mandir="$prefix/man/man1";; - *) echo "MANDIR=$mandir" >> Makefile.cnf;; -esac - -rm -f Makefile -cat Makefile.tpl > Makefile -cat Makefile.cnf >> Makefile - -echo "Resulting configuration file (Makefile.cnf):" -echo -cat Makefile.cnf diff --git a/camlp4/etc/.cvsignore b/camlp4/etc/.cvsignore deleted file mode 100644 index 92c764cac9..0000000000 --- a/camlp4/etc/.cvsignore +++ /dev/null @@ -1,6 +0,0 @@ -*.cm[oia] -camlp4o -camlp4sch -camlp4o.opt -mkcamlp4.sh -mkcamlp4.mpw diff --git a/camlp4/etc/.depend b/camlp4/etc/.depend deleted file mode 100644 index 8191673978..0000000000 --- a/camlp4/etc/.depend +++ /dev/null @@ -1,73 +0,0 @@ -parserify.cmi: ../camlp4/mLast.cmi -pa_extfold.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi -pa_extfold.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx -pa_extfun.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi -pa_extfun.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx -pa_format.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi -pa_format.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx -pa_fstream.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi -pa_fstream.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx -pa_ifdef.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi -pa_ifdef.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx -pa_lefteval.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi -pa_lefteval.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx -pa_lisp.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi -pa_lisp.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx -pa_lispr.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi -pa_lispr.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx -pa_ocamllex.cmo: $(OTOP)/lex/compact.cmi $(OTOP)/lex/cset.cmi \ - $(OTOP)/lex/lexgen.cmi ../camlp4/mLast.cmi ../camlp4/pcaml.cmi \ - $(OTOP)/lex/syntax.cmi -pa_ocamllex.cmx: $(OTOP)/lex/compact.cmx $(OTOP)/lex/cset.cmx \ - $(OTOP)/lex/lexgen.cmx ../camlp4/mLast.cmi ../camlp4/pcaml.cmx \ - $(OTOP)/lex/syntax.cmx -pa_olabl.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi -pa_olabl.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx -pa_o.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi -pa_o.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx -pa_oop.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi -pa_oop.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx -pa_op.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi -pa_op.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx -parserify.cmo: ../camlp4/mLast.cmi parserify.cmi -parserify.cmx: ../camlp4/mLast.cmi parserify.cmi -pa_ru.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi -pa_ru.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx -pa_scheme.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi -pa_scheme.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx -pa_schemer.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi -pa_schemer.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx -pa_sml.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi -pa_sml.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx -pr_depend.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi -pr_depend.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx -pr_extend.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi ../camlp4/spretty.cmi -pr_extend.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx ../camlp4/spretty.cmx -pr_extfun.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi ../camlp4/spretty.cmi -pr_extfun.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx ../camlp4/spretty.cmx -pr_null.cmo: ../camlp4/pcaml.cmi -pr_null.cmx: ../camlp4/pcaml.cmx -pr_o.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi ../camlp4/spretty.cmi -pr_o.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx ../camlp4/spretty.cmx -pr_op_main.cmo: ../camlp4/mLast.cmi parserify.cmi ../camlp4/pcaml.cmi \ - ../camlp4/spretty.cmi -pr_op_main.cmx: ../camlp4/mLast.cmi parserify.cmx ../camlp4/pcaml.cmx \ - ../camlp4/spretty.cmx -pr_op.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi ../camlp4/spretty.cmi -pr_op.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx ../camlp4/spretty.cmx -pr_r.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi ../camlp4/spretty.cmi -pr_r.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx ../camlp4/spretty.cmx -pr_rp_main.cmo: ../camlp4/mLast.cmi parserify.cmi ../camlp4/pcaml.cmi \ - ../camlp4/spretty.cmi -pr_rp_main.cmx: ../camlp4/mLast.cmi parserify.cmx ../camlp4/pcaml.cmx \ - ../camlp4/spretty.cmx -pr_rp.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi ../camlp4/spretty.cmi -pr_rp.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx ../camlp4/spretty.cmx -pr_scheme.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi -pr_scheme.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx -pr_schp_main.cmo: ../camlp4/mLast.cmi parserify.cmi ../camlp4/pcaml.cmi \ - pr_scheme.cmo -pr_schp_main.cmx: ../camlp4/mLast.cmi parserify.cmx ../camlp4/pcaml.cmx \ - pr_scheme.cmx -q_phony.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi ../camlp4/quotation.cmi -q_phony.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx ../camlp4/quotation.cmx diff --git a/camlp4/etc/Makefile b/camlp4/etc/Makefile deleted file mode 100644 index 070fa00b47..0000000000 --- a/camlp4/etc/Makefile +++ /dev/null @@ -1,107 +0,0 @@ -# $Id$ - -include ../config/Makefile - -INCLUDES=-I ../camlp4 -I ../boot -I $(OTOP)/lex -OCAMLCFLAGS=-warn-error A $(INCLUDES) -OBJS=q_phony.cmo pa_o.cmo pa_op.cmo pa_oop.cmo pa_ru.cmo pa_format.cmo pa_olabl.cmo pa_sml.cmo pa_lisp.cmo pa_scheme.cmo pa_extfold.cmo pa_extfun.cmo pa_fstream.cmo pa_lefteval.cmo pa_ifdef.cmo pr_r.cmo pr_rp.cmo pr_o.cmo pr_op.cmo pr_scheme.cmo pr_schemep.cmo pr_extend.cmo pr_extfun.cmo pr_null.cmo pr_depend.cmo -OBJSX=$(OBJS:.cmo=.cmx) -INTF=pa_o.cmi -CAMLP4OM=pa_o.cmo pa_op.cmo ../meta/pr_dump.cmo -CAMLP4OMX=$(CAMLP4OM:.cmo=.cmx) -CAMLP4SCHM=pa_scheme.cmo ../meta/pr_dump.cmo -SHELL=/bin/sh -COUT=$(OBJS) camlp4o$(EXE) camlp4sch$(EXE) -COPT=$(OBJSX) camlp4o.opt - -all: $(COUT) mkcamlp4.sh -opt: $(COPT) - -pr_rp.cmo: parserify.cmo pr_rp_main.cmo - $(OCAMLC) parserify.cmo pr_rp_main.cmo -a -o $@ - -pr_op.cmo: parserify.cmo pr_op_main.cmo - $(OCAMLC) parserify.cmo pr_op_main.cmo -a -o $@ - -pr_schemep.cmo: parserify.cmo pr_schp_main.cmo - $(OCAMLC) parserify.cmo pr_schp_main.cmo -a -o $@ - -pr_rp.cmx: parserify.cmx pr_rp_main.cmx - $(OCAMLOPT) parserify.cmx pr_rp_main.cmx -a -o $@ - -pr_op.cmx: parserify.cmx pr_op_main.cmx - $(OCAMLOPT) parserify.cmx pr_op_main.cmx -a -o $@ - -pr_schemep.cmx: parserify.cmx pr_schp_main.cmx - $(OCAMLOPT) parserify.cmx pr_schp_main.cmx -a -o $@ - -camlp4o$(EXE): ../camlp4/camlp4$(EXE) $(CAMLP4OM) - rm -f camlp4o$(EXE) - cd ../camlp4; $(MAKE) CAMLP4=../etc/camlp4o$(EXE) CAMLP4M="-I ../etc $(CAMLP4OM)" - -camlp4sch$(EXE): ../camlp4/camlp4$(EXE) $(CAMLP4SCHM) - rm -f camlp4sch$(EXE) - cd ../camlp4; $(MAKE) CAMLP4=../etc/camlp4sch$(EXE) CAMLP4M="-I ../etc $(CAMLP4SCHM)" - -camlp4o.opt: $(CAMLP4OMX) - rm -f camlp4o.opt - cd ../camlp4; $(MAKE) optp4 CAMLP4OPT=../etc/camlp4o.opt CAMLP4M="-I ../etc $(CAMLP4OMX)" - -mkcamlp4.sh: mkcamlp4.sh.tpl - sed -e "s!LIBDIR!$(LIBDIR)!g" mkcamlp4.sh.tpl > mkcamlp4.sh - -pa_ocamllex.cma: pa_ocamllex.cmo - $(OCAMLC) -I $(OTOP)/lex cset.cmo syntax.cmo table.cmo lexgen.cmo compact.cmo pa_ocamllex.cmo -a -o pa_ocamllex.cma - -bootstrap_scheme: - @$(MAKE) bootstrap_l L=scheme | grep -v directory -compare_scheme: - @$(MAKE) compare_l L=scheme | grep -v directory -bootstrap_lisp: - @$(MAKE) bootstrap_l L=lisp | grep -v directory -compare_lisp: - @$(MAKE) compare_l L=lisp | grep -v directory - -bootstrap_l: - ../boot/camlp4 ./pa_$Lr.cmo ./q_phony.cmo -I ../boot pa_extend.cmo ./pr_r.cmo ./pr_extend.cmo ./pr_rp.cmo pa_$L.ml > tmp - mv pa_$Lr.ml pa_$Lr.ml.old - sed -e 's/^;; \(.*\)$$/(* \1 *)/' -e 's/^; \(.*\)$$/(* \1 *)/' -e 's|./pa_$Lr.cmo|pa_r.cmo pa_rp.cmo|' -e 's/$$Id.*\$$/File generated by pretty print; do not edit!/' tmp > pa_$Lr.ml - rm -f tmp - -compare_l: - ../boot/camlp4 ./pa_$Lr.cmo ./q_phony.cmo -I ../boot pa_extend.cmo ./pr_r.cmo ./pr_extend.cmo ./pr_rp.cmo pa_$L.ml | sed -e 's/^;; \(.*\)$$/(* \1 *)/' -e 's/^; \(.*\)$$/(* \1 *)/' -e 's|./pa_$Lr.cmo|pa_r.cmo pa_rp.cmo|' -e 's/$$Id.*\$$/File generated by pretty print; do not edit!/' | diff -c pa_$Lr.ml - - -clean:: - rm -f *.cm* *.pp[io] *.o *.bak .*.bak *.out *.opt - rm -f mkcamlp4.sh camlp4o$(EXE) camlp4sch$(EXE) - -depend: - cp .depend .depend.bak - > .depend - @for i in *.mli *.ml; do \ - ../tools/apply.sh pr_depend.cmo -- $(INCLUDES) $$i | \ - sed -e 's| \.\./\.\.| $$(OTOP)|g' >> .depend; \ - done - -get_promote: - -install: - -$(MKDIR) "$(LIBDIR)/camlp4" "$(BINDIR)" - cp $(OBJS) "$(LIBDIR)/camlp4/." - cp $(INTF) "$(LIBDIR)/camlp4/." - cp lib.sml "$(LIBDIR)/camlp4/." - cp camlp4o$(EXE) camlp4sch$(EXE) "$(BINDIR)/." - if test -f camlp4o.opt; then cp camlp4o.opt "$(BINDIR)/camlp4o.opt$(EXE)"; cp $(OBJSX) $(OBJSX:.cmx=.o) "$(LIBDIR)/camlp4/."; fi - cp mkcamlp4.sh "$(BINDIR)/mkcamlp4" - chmod a+x "$(BINDIR)/mkcamlp4" - -pa_lisp.cmo: pa_lispr.cmo -pa_scheme.cmo: pa_schemer.cmo -pa_ocamllex.cmo: pa_o.cmo -pr_extend.cmo: pa_extfun.cmo -pr_o.cmo: pa_extfun.cmo -pr_op.cmo: pa_extfun.cmo -pr_r.cmo: pa_extfun.cmo -pr_rp.cmo: pa_extfun.cmo - -include .depend diff --git a/camlp4/etc/Makefile.Mac b/camlp4/etc/Makefile.Mac deleted file mode 100644 index 27c793fe39..0000000000 --- a/camlp4/etc/Makefile.Mac +++ /dev/null @@ -1,71 +0,0 @@ -####################################################################### -# # -# Camlp4 # -# # -# Damien Doligez, projet Para, INRIA Rocquencourt # -# # -# Copyright 1999 Institut National de Recherche en Informatique et # -# en Automatique. Distributed only by permission. # -# # -####################################################################### - -# $Id$ - -INCLUDES = -I ::camlp4: -I ::boot: -OCAMLCFLAGS = {INCLUDES} -OBJS = q_phony.cmo pa_o.cmo pa_op.cmo pa_oop.cmo pa_ru.cmo pa_format.cmo ¶ - pa_olabl.cmo pa_sml.cmo pa_lisp.cmo pa_extfold.cmo pa_extfun.cmo pa_fstream.cmo spa_lefteval.cmo ¶ - pr_r.cmo pr_rp.cmo pr_o.cmo pr_op.cmo pr_extend.cmo ¶ - pr_extfun.cmo pr_null.cmo pr_depend.cmo -INTF = pa_o.cmi -CAMLP4OM = pa_o.cmo pa_op.cmo ::meta:pr_dump.cmo -OUT = {OBJS} camlp4o - -all Ä {OUT} mkcamlp4.mpw - -camlp4o Ä ::camlp4:camlp4 {CAMLP4OM} - delete -i camlp4o - directory ::camlp4: - domake -d CAMLP4=::etc:camlp4o -d CAMLP4M="-I ::etc: {CAMLP4OM}" - directory ::etc: - -mkcamlp4.mpw Ä mkcamlp4.mpw.tpl - streamedit -e "1,$ replace -c ° /OLIBDIR/ ¶"`quote "{OLIBDIR}"`¶"" ¶ - -e "1,$ replace -c ° /LIBDIR/ ¶"`quote "{P4LIBDIR}"`¶"" ¶ - mkcamlp4.mpw.tpl > mkcamlp4.mpw - -bootstrap_lisp Ä $OutOfDate - ::boot:camlp4 :pa_lispr.cmo -I ::boot: pa_extend.cmo q_MLast.cmo ¶ - :pr_r.cmo :pr_extend.cmo :pr_rp.cmo -phony_quot pa_lisp.ml ¶ - | streamedit -e '1,$ replace /¥;; (Å)¨0°/ "(* " ¨0 " *)"' ¶ - -e "1,$ replace /'./pa_lispr.cmo'/ 'pa_r.cmo pa_rp.cmo'" >tmp - rename -y pa_lispr.ml pa_lispr.ml.old - rename -y tmp pa_lispr.ml - -compare_lisp Ä $OutOfDate - set status 0 - -clean ÄÄ - delete -i mkcamlp4.mpw camlp4o - -{dependrule} - -get_promote Ä $OutOfDate - -install Ä - (newfolder "{P4LIBDIR}" || set status 0) ³ dev:null - (newfolder "{BINDIR}" || set status 0) ³ dev:null - duplicate -y {OBJS} "{P4LIBDIR}" - duplicate -y {INTF} "{P4LIBDIR}" - duplicate -y lib.sml "{P4LIBDIR}" - duplicate -y camlp4o "{BINDIR}" - duplicate -y mkcamlp4.mpw "{BINDIR}mkcamlp4" - -{defrules} - -pa_lisp.cmoÄ pa_lispr.cmo -pr_extend.cmoÄ pa_extfun.cmo -pr_o.cmoÄ pa_extfun.cmo -pr_op.cmoÄ pa_extfun.cmo -pr_r.cmoÄ pa_extfun.cmo -pr_rp.cmoÄ pa_extfun.cmo diff --git a/camlp4/etc/Makefile.Mac.depend b/camlp4/etc/Makefile.Mac.depend deleted file mode 100644 index c8007dcb7f..0000000000 --- a/camlp4/etc/Makefile.Mac.depend +++ /dev/null @@ -1,40 +0,0 @@ -pa_extfun.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi -pa_extfun.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx -pa_format.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi -pa_format.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx -pa_fstream.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi -pa_fstream.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx -pa_lisp.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi -pa_lisp.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx -pa_lispr.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi -pa_lispr.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx -pa_olabl.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi -pa_olabl.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx -pa_o.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi -pa_o.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx -pa_oop.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi -pa_oop.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx -pa_op.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi -pa_op.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx -pa_ru.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi -pa_ru.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx -pa_sml.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi -pa_sml.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx -pr_depend.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi -pr_depend.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx -pr_extend.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi ::camlp4:spretty.cmi -pr_extend.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx ::camlp4:spretty.cmx -pr_extfun.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi ::camlp4:spretty.cmi -pr_extfun.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx ::camlp4:spretty.cmx -pr_null.cmoÄ ::camlp4:pcaml.cmi -pr_null.cmxÄ ::camlp4:pcaml.cmx -pr_o.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi ::camlp4:spretty.cmi -pr_o.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx ::camlp4:spretty.cmx -pr_op.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi ::camlp4:spretty.cmi -pr_op.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx ::camlp4:spretty.cmx -pr_r.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi ::camlp4:spretty.cmi -pr_r.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx ::camlp4:spretty.cmx -pr_rp.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi ::camlp4:spretty.cmi -pr_rp.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx ::camlp4:spretty.cmx -q_phony.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi ::camlp4:quotation.cmi -q_phony.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx ::camlp4:quotation.cmx diff --git a/camlp4/etc/lib.sml b/camlp4/etc/lib.sml deleted file mode 100644 index a9d05fe04b..0000000000 --- a/camlp4/etc/lib.sml +++ /dev/null @@ -1,384 +0,0 @@ -(* $Id$ *) - -datatype 'a option = SOME of 'a | NONE -exception Fail of string -exception Domain -exception Subscript -type 'a vector = 'a array - -structure OCaml = - struct - structure List = List - structure String = String - end - -structure Time = - struct - datatype time = TIME of { sec : int, usec : int } - fun toString _ = failwith "not implemented Time.toString" - fun now _ = failwith "not implemented Time.now" - end - -datatype cpu_timer = - CPUT of { gc : Time.time, sys : Time.time, usr : Time.time } - -datatype real_timer = - RealT of Time.time - -structure Char = - struct - val ord = Char.code - end - -structure General = - struct - datatype order = LESS | EQUAL | GREATER - end -type order = General.order == LESS | EQUAL | GREATER - -structure OS = - struct - exception SysErr - structure Path = - struct - fun dir s = - let val r = Filename.dirname s in - if r = "." then "" else r - end - val file = Filename.basename - fun ext s = - let fun loop i = - if i < 0 then NONE - else if String.get s i = #"." then - let val len = String.length s - i - 1 in - if len = 0 then NONE else SOME (String.sub s (i + 1) len) - end - else loop (i - 1) - in - loop (String.length s - 1) - end - fun splitDirFile s = - {dir = Filename.dirname s, - file = Filename.basename s} - fun joinDirFile x = - let val {dir,file} = x in Filename.concat dir file end - end - structure FileSys = - struct - datatype access_mode = A_READ | A_WRITE | A_EXEC - val chDir = Sys.chdir - fun isDir s = - (Unix.stat s) ocaml_record_access Unix.st_kind = Unix.S_DIR - handle Unix.Unix_error _ => raise SysErr - fun access (s, accs) = - let val st = Unix.stat s - val prm = st ocaml_record_access Unix.st_perm - val prm = - if st ocaml_record_access Unix.st_uid = Unix.getuid () then - lsr prm 6 - else if st ocaml_record_access Unix.st_uid = Unix.getgid () - then - lsr prm 3 - else prm - val rf = - if List.mem A_READ accs then land prm 4 <> 0 else true - val wf = - if List.mem A_WRITE accs then land prm 2 <> 0 else true - val xf = - if List.mem A_EXEC accs then land prm 1 <> 0 else true - in - rf andalso wf andalso xf - end - handle Unix.Unix_error (_, f, _) => - if f = "stat" then false else raise SysErr - end - structure Process = - struct - fun system s = (flush stdout; flush stderr; Sys.command s) - fun getEnv s = SOME (Sys.getenv s) handle Not_found => NONE - val success = 0 - end - end - -exception SysErr = OS.SysErr - -structure IO = - struct - exception Io of {cause:exn, function:string, name:string} - end - -structure TextIO = - struct - type instream = in_channel * char option option ref - type outstream = out_channel - type elem = char - type vector = string - fun openIn fname = - (open_in fname, ref NONE) handle exn => - raise IO.Io {cause = exn, function = "openIn", name = fname} - val openOut = open_out - fun closeIn (ic, ahc) = (ahc := SOME NONE; close_in ic) - val closeOut = close_out - val stdIn = (stdin, ref NONE) - fun endOfStream (ic, _) = pos_in ic = in_channel_length ic - fun inputLine (ic, ahc) = - case !ahc of - NONE => - (input_line ic ^ "\n" handle End_of_file => (ahc := SOME NONE; "")) - | SOME NONE => "" - | SOME (SOME c) => - (ahc := NONE; - if c = #"\n" then "\n" - else - String.make 1 c ^ input_line ic ^ "\n" handle - End_of_file => (ahc := SOME NONE; "")) - fun input1 (ic, ahc) = - case !ahc of - NONE => - (SOME (input_char ic) handle End_of_file => (ahc := SOME NONE; NONE)) - | SOME NONE => NONE - | SOME x => (ahc := NONE; x) - fun inputN (ins, n) = - let fun loop n = - if n <= 0 then "" - else - case input1 ins of - SOME c => String.make 1 c ^ loop (n - 1) - | NONE => "" - in - loop n - end - fun output (oc, v) = output_string oc v - fun inputAll ic = failwith "not implemented TextIO.inputAll" - fun lookahead (ic, ahc) = - case !ahc of - NONE => let val r = SOME (input_char ic) in ahc := SOME r; r end - | SOME x => x - fun print s = (print_string s; flush stdout) - end - -structure Timer = - struct - fun startRealTimer () = failwith "not implemented Timer.startRealTimer" - fun startCPUTimer () = failwith "not implemented Timer.startCPUTimer" - fun checkRealTimer _ = failwith "not implemented Timer.checkRealTimer" - fun checkCPUTimer _ = failwith "not implemented Timer.checkCPUTimer" - end - -structure Date = - struct - datatype month = - Jan | Feb | Mar | Apr | May | Jun | Jul | Sep | Oct | Nov | Dec - datatype wday = Sun | Mon | Tue | Wed | Thu | Fri | Sat - datatype date = - DATE of - {day : int, hour : int, isDst : bool option, minute : int, - month : month, offset : int option, second : int, wday : wday, - yday : int, year : int} - fun fmt _ _ = failwith "not implemented Date.fmt" - fun fromTimeLocal _ = failwith "not implemented Date.fromTimeLocal" - end - -structure Posix = - struct - structure ProcEnv = - struct - fun getenv s = SOME (Sys.getenv s) handle Not_found => NONE - end - end - -structure SMLofNJ = - struct - fun exportML s = failwith ("not implemented exportML " ^ s) - end - -fun null x = x = [] -fun explode s = - let fun loop i = - if i = String.length s then [] - else String.get s i :: loop (i + 1) - in - loop 0 - end - -val app = List.iter -fun implode [] = "" - | implode (c :: l) = String.make 1 c ^ implode l - -fun ooo f g x = f (g x) - -structure Array = - struct - fun array (len, v) = Array.create len v - fun sub _ = failwith "not implemented Array.sub" - fun update _ = failwith "not implemented Array.update" - (* for make the profiler work *) - val set = Array.set - val get = Array.get - end - -structure Vector = - struct - fun tabulate _ = failwith "not implemented Vector.tabulate" - fun sub _ = failwith "not implemented Vector.sub" - end - -structure Bool = - struct - val toString = string_of_bool - end - -structure String = - struct - val size = String.length - fun substring (s, beg, len) = - String.sub s beg len handle Invalid_argument _ => raise Subscript - val concat = String.concat "" - fun sub (s, i) = String.get s i - val str = String.make 1 - fun compare (s1, s2) = - if s1 < s2 then LESS - else if s1 > s2 then GREATER - else EQUAL - fun isPrefix s1 s2 = - let fun loop i1 i2 = - if i1 >= String.length s1 then true - else if i2 >= String.length s2 then false - else if String.get s1 i1 = String.get s2 i2 then loop (i1 + 1) (i2 + 1) - else false - in - loop 0 0 - end - fun tokens p s = - let fun loop tok i = - if i >= String.length s then - if tok = "" then [] else [tok] - else if p (String.get s i) then - if tok <> "" then tok :: loop "" (i + 1) - else loop "" (i + 1) - else loop (tok ^ String.make 1 (String.get s i)) (i + 1) - in - loop "" 0 - end - fun extract _ = failwith "not implemented String.extract" - end - -structure Substring = - struct - type substring = string * int * int - fun string (s : substring) = String.substring s - fun all s : substring = (s, 0, String.size s) - fun splitl f ((s, beg, len) : substring) : substring * substring = - let fun loop di = - if di = len then ((s, beg, len), (s, 0, 0)) - else if f (String.sub (s, beg + di)) then loop (di + 1) - else ((s, beg, di), (s, beg + di, len - di)) - in - loop 0 - end - fun getc (s, i, len) = - if len > 0 andalso i < String.size s then - SOME (String.sub (s, i), (s, i+1, len-1)) - else NONE - fun slice _ = failwith "not implemented: Substring.slice" - fun isEmpty (s, beg, len) = len = 0 - fun concat sl = String.concat (List.map string sl) - end -type substring = Substring.substring - -structure StringCvt = - struct - datatype radix = BIN | OCT | DEC | HEX - type ('a, 'b) reader = 'b -> ('a * 'b) option - end - -structure ListPair = - struct - fun zip (a1::l1, a2::l2) = (a1, a2) :: zip (l1, l2) - | zip _ = [] - val unzip = List.split - fun all f (x1 :: l1, x2 :: l2) = f (x1, x2) andalso all f (l1, l2) - | all _ _ = true - fun map f (a1::l1, a2::l2) = - let val r = f (a1, a2) in r :: map f (l1, l2) end - | map _ _ = [] - end - -structure ListMergeSort = - struct - fun uniqueSort cmp l = - List.sort - (fn x => fn y => - case cmp (x, y) of - LESS => ~1 - | EQUAL => 0 - | GREATER => 1) - l - end - -structure List = - struct - exception Empty - fun hd [] = raise Empty - | hd (x :: l) = x - fun tl [] = raise Empty - | tl (x :: l) = l - fun foldr f a l = - let fun loop a [] = a - | loop a (x :: l) = loop (f (x, a)) l - in - loop a (List.rev l) - end - fun foldl f a l = List.fold_left (fn a => fn x => f (x, a)) a l - val concat = List.flatten - val exists = List.exists - val filter = List.filter - val length = List.length - val map = List.map - val rev = List.rev - val all = List.for_all - fun find f [] = NONE - | find f (x :: l) = if f x then SOME x else find f l - fun last s = - case List.rev s of - [] => raise Empty - | x :: _ => x - fun take _ = failwith "not implemented: List.take" - fun partition _ = failwith "not implemented: List.partition" - fun mapPartial f [] = [] - | mapPartial f (x :: l) = - case f x of - NONE => mapPartial f l - | SOME y => y :: mapPartial f l - fun op @ l1 l2 = List.rev_append (List.rev l1) l2 - end - -structure Int = - struct - type int1 = int - type int = int1 - val toString = string_of_int - fun fromString s = SOME (int_of_string s) handle Failure _ => NONE - fun min (x, y) = if x < y then x else y - fun max (x, y) = if x > y then x else y - fun scan radix getc src = failwith "not impl: Int.scan" - end - -val foldr = List.foldr -val exists = List.exists -val size = String.size -val substring = String.substring -val concat = String.concat -val length = List.length -val op @ = List.op @ -val hd = List.hd -val tl = List.tl -val map = List.map -val rev = List.rev -val use_hook = ref (fn (s : string) => failwith "no defined directive use") -fun use s = !use_hook s -fun isSome (SOME _) = true - | isSome NONE = false -fun valOf (SOME x) = x - | valOf NONE = failwith "valOf" -val print = TextIO.print diff --git a/camlp4/etc/mkcamlp4.mpw.tpl b/camlp4/etc/mkcamlp4.mpw.tpl deleted file mode 100644 index 6b174bf6a9..0000000000 --- a/camlp4/etc/mkcamlp4.mpw.tpl +++ /dev/null @@ -1,33 +0,0 @@ -####################################################################### -# # -# Camlp4 # -# # -# Damien Doligez, projet Para, INRIA Rocquencourt # -# # -# Copyright 1999 Institut National de Recherche en Informatique et # -# en Automatique. Distributed only by permission. # -# # -####################################################################### - -# $Id$ - -set OLIB OLIBDIR -set LIB LIBDIR - -set INTERFACES "" -set OPTS "" -set INCL "-I :" - -loop - exit if "{1}" == "" - if "{1}" == "-I" - set INCL "{INCL} -I `quote "{2}"`" - shift - else if "{1}" =~ /([Â:])¨0([Â:]*)¨1.cmi/ - set first `echo {¨0} | translate a-z A-Z` - set INTERFACES "{INTERFACES} {first}{¨1}" - else - set OPTS "{OPTS} `quote "{1}"`" - end - shift -end diff --git a/camlp4/etc/mkcamlp4.sh.tpl b/camlp4/etc/mkcamlp4.sh.tpl deleted file mode 100755 index 50c3ea61a7..0000000000 --- a/camlp4/etc/mkcamlp4.sh.tpl +++ /dev/null @@ -1,33 +0,0 @@ -#!/bin/sh -# $Id$ - -OLIB="`ocamlc -where`" -LIB="LIBDIR/camlp4" - -INTERFACES= -OPTS= -INCL="-I ." -while test "" != "$1"; do - case "$1" in - -I) INCL="$INCL -I $2"; shift;; - *) - j=`basename "$1" .cmi` - if test "$j.cmi" = "$1"; then - first="`expr "$j" : '\(.\)' | tr 'a-z' 'A-Z'`" - rest="`expr "$j" : '.\(.*\)'`" - INTERFACES="$INTERFACES $first$rest" - else - OPTS="$OPTS $1" - fi;; - esac - shift -done - -CRC=crc_$$ -set -e -trap 'rm -f $CRC.ml $CRC.cmi $CRC.cmo' 0 2 -$OLIB/extract_crc -I $OLIB $INCL $INTERFACES > $CRC.ml -echo "let _ = Dynlink.add_available_units crc_unit_list" >> $CRC.ml -ocamlc -I $LIB odyl.cma camlp4.cma $CRC.ml $INCL $OPTS odyl.cmo -linkall -rm -f $CRC.ml $CRC.cmi $CRC.cmo - diff --git a/camlp4/etc/pa_extfold.ml b/camlp4/etc/pa_extfold.ml deleted file mode 100644 index 0c272c4d0c..0000000000 --- a/camlp4/etc/pa_extfold.ml +++ /dev/null @@ -1,42 +0,0 @@ -(* camlp4r pa_extend.cmo q_MLast.cmo *) -(* $Id$ *) - -open Pcaml; -open Pa_extend; - -value sfold loc n foldfun f e s = - let styp = STquo loc (new_type_var ()) in - let e = <:expr< Extfold.$lid:foldfun$ $f$ $e$ >> in - let t = STapp loc (STapp loc (STtyp <:ctyp< Extfold.t _ >>) s.styp) styp in - {used = s.used; text = TXmeta loc n [s.text] e t; styp = styp} -; - -value sfoldsep loc n foldfun f e s sep = - let styp = STquo loc (new_type_var ()) in - let e = <:expr< Extfold.$lid:foldfun$ $f$ $e$ >> in - let t = - STapp loc (STapp loc (STtyp <:ctyp< Extfold.tsep _ >>) s.styp) styp - in - {used = s.used @ sep.used; text = TXmeta loc n [s.text; sep.text] e t; - styp = styp} -; - -EXTEND - 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 = LIDENT -> <:expr< $lid:i$ >> - | "("; e = expr; ")" -> e ] ] - ; -END; diff --git a/camlp4/etc/pa_extfun.ml b/camlp4/etc/pa_extfun.ml deleted file mode 100644 index 5cab09a2bb..0000000000 --- a/camlp4/etc/pa_extfun.ml +++ /dev/null @@ -1,123 +0,0 @@ -(* camlp4r q_MLast.cmo pa_extend.cmo *) -(* $Id$ *) - -open Pcaml; - -value not_impl name x = - let desc = - if Obj.is_block (Obj.repr x) then - "tag = " ^ string_of_int (Obj.tag (Obj.repr x)) - else "int_val = " ^ string_of_int (Obj.magic x) - in - do { - print_newline (); failwith ("pa_extfun: not impl " ^ name ^ " " ^ desc) - } -; - -value rec mexpr p = - let loc = MLast.loc_of_patt p in - match p with - [ <:patt< $p1$ $p2$ >> -> - loop <:expr< [$mexpr p2$] >> p1 where rec loop el = - fun - [ <:patt< $p1$ $p2$ >> -> loop <:expr< [$mexpr p2$ :: $el$] >> p1 - | p -> <:expr< Extfun.Eapp [$mexpr p$ :: $el$] >> ] - | <:patt< $p1$ . $p2$ >> -> - loop <:expr< [$mexpr p2$] >> p1 where rec loop el = - fun - [ <:patt< $p1$ . $p2$ >> -> loop <:expr< [$mexpr p2$ :: $el$] >> p1 - | p -> <:expr< Extfun.Eacc [$mexpr p$ :: $el$] >> ] - | <:patt< ($list:pl$) >> -> <:expr< Extfun.Etup $mexpr_list loc pl$ >> - | <:patt< $uid:id$ >> -> <:expr< Extfun.Econ $str:id$ >> - | <:patt< ` $id$ >> -> <:expr< Extfun.Econ $str:id$ >> - | <:patt< $int:s$ >> -> <:expr< Extfun.Eint $str:s$ >> - | <:patt< $str:s$ >> -> <:expr< Extfun.Estr $str:s$ >> - | <:patt< ($p1$ as $_$) >> -> mexpr p1 - | <:patt< $lid:_$ >> -> <:expr< Extfun.Evar () >> - | <:patt< _ >> -> <:expr< Extfun.Evar () >> - | <:patt< $p1$ | $p2$ >> -> - Stdpp.raise_with_loc loc (Failure "or patterns not allowed in extfun") - | p -> not_impl "mexpr" p ] -and mexpr_list loc = - fun - [ [] -> <:expr< [] >> - | [e :: el] -> <:expr< [$mexpr e$ :: $mexpr_list loc el$] >> ] -; - -value rec catch_any = - fun - [ <:patt< $uid:id$ >> -> False - | <:patt< ` $_$ >> -> False - | <:patt< $lid:_$ >> -> True - | <:patt< _ >> -> True - | <:patt< ($list:pl$) >> -> List.for_all catch_any pl - | <:patt< $p1$ $p2$ >> -> False - | <:patt< $p1$ | $p2$ >> -> False - | <:patt< $int:_$ >> -> False - | <:patt< $str:_$ >> -> False - | <:patt< ($p1$ as $_$) >> -> catch_any p1 - | p -> not_impl "catch_any" p ] -; - -value conv (p, wo, e) = - let tst = mexpr p in - let loc = (fst (MLast.loc_of_patt p), snd (MLast.loc_of_expr e)) in - let e = - if wo = None && catch_any p then <:expr< fun $p$ -> Some $e$ >> - else <:expr< fun [ $p$ $when:wo$ -> Some $e$ | _ -> None ] >> - in - let has_when = - match wo with - [ Some _ -> <:expr< True >> - | None -> <:expr< False >> ] - in - <:expr< ($tst$, $has_when$, $e$) >> -; - -value rec conv_list tl = - fun - [ [pe :: pel] -> - let loc = MLast.loc_of_expr tl in - <:expr< [$conv pe$ :: $conv_list tl pel$] >> - | [] -> tl ] -; - -value rec split_or = - fun - [ [(<:patt< $p1$ | $p2$ >>, wo, e) :: pel] -> - split_or [(p1, wo, e); (p2, wo, e) :: pel] - | [(<:patt< ($p1$ | $p2$ as $p$) >>, wo, e) :: pel] -> - let p1 = - let loc = MLast.loc_of_patt p1 in - <:patt< ($p1$ as $p$) >> - in - let p2 = - let loc = MLast.loc_of_patt p2 in - <:patt< ($p2$ as $p$) >> - in - split_or [(p1, wo, e); (p2, wo, e) :: pel] - | [pe :: pel] -> [pe :: split_or pel] - | [] -> [] ] -; - -EXTEND - GLOBAL: expr; - expr: LEVEL "top" - [ [ "extfun"; e = SELF; "with"; "["; list = match_case_list; "]" -> - <:expr< Extfun.extend $e$ $list$ >> ] ] - ; - match_case_list: - [ [ pel = LIST0 match_case SEP "|" -> - conv_list <:expr< [] >> (split_or pel) ] ] - ; - match_case: - [ [ p = patt; aso = OPT [ "as"; p = patt -> p ]; - w = OPT [ "when"; e = expr -> e ]; "->"; e = expr -> - let p = - match aso with - [ Some p2 -> <:patt< ($p$ as $p2$) >> - | _ -> p ] - in - (p, w, e) ] ] - ; -END; diff --git a/camlp4/etc/pa_format.ml b/camlp4/etc/pa_format.ml deleted file mode 100644 index 3c8deea472..0000000000 --- a/camlp4/etc/pa_format.ml +++ /dev/null @@ -1,39 +0,0 @@ -(* camlp4r pa_extend.cmo q_MLast.cmo *) -(* $Id$ *) - -open Pcaml; - -EXTEND - GLOBAL: expr; - expr: LEVEL "top" - [ [ n = box_type; d = SELF; "begin"; - el = LIST0 [ e = box_expr; ";" -> e ]; "end" -> - let el = [<:expr< Format.$lid:"open_" ^ n$ $d$ >> :: el] in - let el = el @ [<:expr< Format.close_box () >>] in - <:expr< do { $list:el$ } >> - | "hbox"; "begin"; el = LIST0 [ e = box_expr; ";" -> e ]; "end" -> - let el = [<:expr< Format.open_hbox () >> :: el] in - let el = el @ [<:expr< Format.close_box () >>] in - <:expr< do { $list:el$ } >> - | "nobox"; "begin"; el = LIST0 [ e = box_expr; ";" -> e ]; "end" -> - match el with - [ [e] -> e - | _ -> <:expr< do { $list:el$ } >> ] ] ] - ; - box_type: - [ [ n = "hovbox" -> n - | n = "hvbox" -> n - | n = "vbox" -> n - | n = "box" -> n ] ] - ; - box_expr: - [ [ s = STRING -> <:expr< Format.print_string $str:s$ >> - | UIDENT "STRING"; e = expr -> <:expr< Format.print_string $e$ >> - | UIDENT "INT"; e = expr -> <:expr< Format.print_int $e$ >> - | "/-" -> <:expr< Format.print_space () >> - | "//" -> <:expr< Format.print_cut () >> - | "!/" -> <:expr< Format.force_newline () >> - | "?/" -> <:expr< Format.print_if_newline () >> - | e = expr -> e ] ] - ; -END; diff --git a/camlp4/etc/pa_fstream.ml b/camlp4/etc/pa_fstream.ml deleted file mode 100644 index 9a2faebc80..0000000000 --- a/camlp4/etc/pa_fstream.ml +++ /dev/null @@ -1,163 +0,0 @@ -(* camlp4r pa_extend.cmo q_MLast.cmo *) -(* $Id$ *) - -open Pcaml; - -type spat_comp = - [ SpTrm of MLast.loc and MLast.patt and option MLast.expr - | SpNtr of MLast.loc and MLast.patt and MLast.expr - | SpStr of MLast.loc and MLast.patt ] -; -type sexp_comp = - [ SeTrm of MLast.loc and MLast.expr - | SeNtr of MLast.loc and MLast.expr ] -; - -(* parsers *) - -value strm_n = "strm__"; -value next_fun loc = <:expr< Fstream.next >>; - -value rec pattern_eq_expression p e = - match (p, e) with - [ (<:patt< $lid:a$ >>, <:expr< $lid:b$ >>) -> a = b - | (<:patt< $uid:a$ >>, <:expr< $uid:b$ >>) -> a = b - | (<:patt< $p1$ $p2$ >>, <:expr< $e1$ $e2$ >>) -> - pattern_eq_expression p1 e1 && pattern_eq_expression p2 e2 - | (<:patt< ($list:pl$) >>, <:expr< ($list:el$) >>) -> - loop pl el where rec loop pl el = - match (pl, el) with - [ ([p :: pl], [e :: el]) -> - pattern_eq_expression p e && loop pl el - | ([], []) -> True - | _ -> False ] - | _ -> False ] -; - -value stream_pattern_component skont = - fun - [ SpTrm loc p wo -> - let p = <:patt< Some ($p$, $lid:strm_n$) >> in - if wo = None && pattern_eq_expression p skont then - <:expr< $next_fun loc$ $lid:strm_n$ >> - else - <:expr< match $next_fun loc$ $lid:strm_n$ with - [ $p$ $when:wo$ -> $skont$ - | _ -> None ] >> - | SpNtr loc p e -> - let p = <:patt< Some ($p$, $lid:strm_n$) >> in - if pattern_eq_expression p skont then <:expr< $e$ $lid:strm_n$ >> - else - <:expr< match $e$ $lid:strm_n$ with - [ $p$ -> $skont$ - | _ -> None ] >> - | SpStr loc p -> - <:expr< let $p$ = $lid:strm_n$ in $skont$ >> ] -; - -value rec stream_pattern loc epo e = - fun - [ [] -> - let e = - match epo with - [ Some ep -> <:expr< let $ep$ = Fstream.count $lid:strm_n$ in $e$ >> - | None -> e ] - in - <:expr< Some ($e$, $lid:strm_n$) >> - | [spc :: spcl] -> - let skont = stream_pattern loc epo e spcl in - stream_pattern_component skont spc ] -; - -value rec parser_cases loc = - fun - [ [] -> <:expr< None >> - | [(spcl, epo, e) :: spel] -> - match parser_cases loc spel with - [ <:expr< None >> -> stream_pattern loc epo e spcl - | pc -> - <:expr< match $stream_pattern loc epo e spcl$ with - [ Some _ as x -> x - | None -> $pc$ ] >> ] ] -; - -value cparser_match loc me bpo pc = - let pc = parser_cases loc pc in - let e = - match bpo with - [ Some bp -> <:expr< let $bp$ = Stream.count $lid:strm_n$ in $pc$ >> - | None -> pc ] - in - <:expr< let ($lid:strm_n$ : Stream.t _) = $me$ in $e$ >> -; - -value cparser loc bpo pc = - let e = parser_cases loc pc in - let e = - match bpo with - [ Some bp -> <:expr< let $bp$ = Fstream.count $lid:strm_n$ in $e$ >> - | None -> e ] - in - let p = <:patt< ($lid:strm_n$ : Fstream.t _) >> in <:expr< fun $p$ -> $e$ >> -; - -(* streams *) - -value slazy loc x = <:expr< fun () -> $x$ >>; - -value rec cstream loc = - fun - [ [] -> <:expr< Fstream.nil >> - | [SeTrm loc e :: sel] -> - let e2 = cstream loc sel in - let x = <:expr< Fstream.cons $e$ $e2$ >> in - <:expr< Fstream.flazy $slazy loc x$ >> - | [SeNtr loc e] -> - e - | [SeNtr loc e :: sel] -> - let e2 = cstream loc sel in - let x = <:expr< Fstream.app $e$ $e2$ >> in - <:expr< Fstream.flazy $slazy loc x$ >> ] -; - -EXTEND - GLOBAL: expr; - expr: LEVEL "top" - [ [ "fparser"; po = OPT ipatt; "["; pcl = LIST0 parser_case SEP "|"; "]" -> - <:expr< $cparser loc po pcl$ >> - | "fparser"; po = OPT ipatt; pc = parser_case -> - <:expr< $cparser loc po [pc]$ >> - | "match"; e = SELF; "with"; "parser"; po = OPT ipatt; "["; - pcl = LIST0 parser_case SEP "|"; "]" -> - <:expr< $cparser_match loc e po pcl$ >> - | "match"; e = SELF; "with"; "parser"; po = OPT ipatt; - pc = parser_case -> - <:expr< $cparser_match loc e po [pc]$ >> ] ] - ; - parser_case: - [ [ "[:"; sp = stream_patt; ":]"; po = OPT ipatt; "->"; e = expr -> - (sp, po, e) ] ] - ; - stream_patt: - [ [ spc = stream_patt_comp -> [spc] - | spc = stream_patt_comp; ";"; sp = LIST1 stream_patt_comp SEP ";" -> - [spc :: sp] - | -> [] ] ] - ; - stream_patt_comp: - [ [ "`"; p = patt; eo = OPT [ "when"; e = expr -> e ] -> SpTrm loc p eo - | p = patt; "="; e = expr -> SpNtr loc p e - | p = patt -> SpStr loc p ] ] - ; - ipatt: - [ [ i = LIDENT -> <:patt< $lid:i$ >> ] ] - ; - expr: LEVEL "simple" - [ [ "fstream"; "[:"; se = LIST0 stream_expr_comp SEP ";"; ":]" -> - <:expr< $cstream loc se$ >> ] ] - ; - stream_expr_comp: - [ [ "`"; e = expr -> SeTrm loc e - | e = expr -> SeNtr loc e ] ] - ; -END; diff --git a/camlp4/etc/pa_ifdef.ml b/camlp4/etc/pa_ifdef.ml deleted file mode 100644 index bc80a7d557..0000000000 --- a/camlp4/etc/pa_ifdef.ml +++ /dev/null @@ -1,87 +0,0 @@ -(* camlp4r pa_extend.cmo q_MLast.cmo *) -(* $Id$ *) - -(* This module is deprecated since version 3.07; use pa_macro.ml instead *) - -type item_or_def 'a = - [ SdStr of 'a | SdDef of string | SdUnd of string | SdNop ] -; - -value list_remove x l = - List.fold_right (fun e l -> if e = x then l else [e :: l]) l [] -; - -value defined = ref ["OCAML_307"; "OCAML_305"; "CAMLP4_300"; "NEWSEQ"]; -value define x = defined.val := [x :: defined.val]; -value undef x = defined.val := list_remove x defined.val; - -EXTEND - GLOBAL: Pcaml.expr Pcaml.str_item Pcaml.sig_item; - Pcaml.expr: LEVEL "top" - [ [ "ifdef"; c = UIDENT; "then"; e1 = Pcaml.expr; "else"; - e2 = Pcaml.expr -> - if List.mem c defined.val then e1 else e2 - | "ifndef"; c = UIDENT; "then"; e1 = Pcaml.expr; "else"; - e2 = Pcaml.expr -> - if List.mem c defined.val then e2 else e1 ] ] - ; - Pcaml.str_item: FIRST - [ [ x = def_undef_str -> - match x with - [ SdStr si -> si - | SdDef x -> do { define x; <:str_item< declare end >> } - | SdUnd x -> do { undef x; <:str_item< declare end >> } - | SdNop -> <:str_item< declare end >> ] ] ] - ; - def_undef_str: - [ [ "ifdef"; c = UIDENT; "then"; e1 = str_item_def_undef; - "else"; e2 = str_item_def_undef -> - if List.mem c defined.val then e1 else e2 - | "ifdef"; c = UIDENT; "then"; e1 = str_item_def_undef -> - if List.mem c defined.val then e1 else SdNop - | "ifndef"; c = UIDENT; "then"; e1 = str_item_def_undef; - "else"; e2 = str_item_def_undef -> - if List.mem c defined.val then e2 else e1 - | "ifndef"; c = UIDENT; "then"; e1 = str_item_def_undef -> - if List.mem c defined.val then SdNop else e1 - | "define"; c = UIDENT -> SdDef c - | "undef"; c = UIDENT -> SdUnd c ] ] - ; - str_item_def_undef: - [ [ d = def_undef_str -> d - | si = Pcaml.str_item -> SdStr si ] ] - ; - Pcaml.sig_item: FIRST - [ [ x = def_undef_sig -> - match x with - [ SdStr si -> si - | SdDef x -> do { define x; <:sig_item< declare end >> } - | SdUnd x -> do { undef x; <:sig_item< declare end >> } - | SdNop -> <:sig_item< declare end >> ] ] ] - ; - def_undef_sig: - [ [ "ifdef"; c = UIDENT; "then"; e1 = sig_item_def_undef; - "else"; e2 = sig_item_def_undef -> - if List.mem c defined.val then e1 else e2 - | "ifdef"; c = UIDENT; "then"; e1 = sig_item_def_undef -> - if List.mem c defined.val then e1 else SdNop - | "ifndef"; c = UIDENT; "then"; e1 = sig_item_def_undef; - "else"; e2 = sig_item_def_undef -> - if List.mem c defined.val then e2 else e1 - | "ifndef"; c = UIDENT; "then"; e1 = sig_item_def_undef -> - if List.mem c defined.val then SdNop else e1 - | "define"; c = UIDENT -> SdDef c - | "undef"; c = UIDENT -> SdUnd c ] ] - ; - sig_item_def_undef: - [ [ d = def_undef_sig -> d - | si = Pcaml.sig_item -> SdStr si ] ] - ; -END; - -Pcaml.add_option "-D" (Arg.String define) - " Define for ifdef instruction." -; -Pcaml.add_option "-U" (Arg.String undef) - " Undefine for ifdef instruction." -; diff --git a/camlp4/etc/pa_lefteval.ml b/camlp4/etc/pa_lefteval.ml deleted file mode 100644 index e96e8d34f5..0000000000 --- a/camlp4/etc/pa_lefteval.ml +++ /dev/null @@ -1,239 +0,0 @@ -(* camlp4r q_MLast.cmo *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -value not_impl name x = - let desc = - if Obj.is_block (Obj.repr x) then - "tag = " ^ string_of_int (Obj.tag (Obj.repr x)) - else "int_val = " ^ string_of_int (Obj.magic x) - in - failwith ("pa_lefteval: not impl: " ^ name ^ "; " ^ desc ^ ">") -; - -value rec expr_fa al = - fun - [ <:expr< $f$ $a$ >> -> expr_fa [a :: al] f - | f -> (f, al) ] -; - -(* generating let..in before functions calls which evaluates - several (more than one) of their arguments *) - -value no_side_effects_ht = - let ht = Hashtbl.create 73 in - do { - List.iter (fun s -> Hashtbl.add ht s True) - ["<"; "="; "@"; "^"; "+"; "-"; "ref"]; - ht - } -; - -value no_side_effects = - fun - [ <:expr< $uid:_$ >> -> True - | <:expr< $uid:_$ . $uid:_$ >> -> True - | <:expr< $lid:s$ >> -> - try Hashtbl.find no_side_effects_ht s with [ Not_found -> False ] - | _ -> False ] -; - -value rec may_side_effect = - fun - [ <:expr< $lid:_$ >> | <:expr< $uid:_$ >> | <:expr< $str:_$ >> | - <:expr< $chr:_$ >> | <:expr< $int:_$ >> | <:expr< $flo:_$ >> | - <:expr< $_$ . $_$ >> | <:expr< fun [ $list:_$ ] >> -> - False - | <:expr< ($list:el$) >> -> List.exists may_side_effect el - | <:expr< $_$ $_$ >> as e -> - let (f, el) = expr_fa [] e in - not (no_side_effects f) || List.exists may_side_effect el - | _ -> True ] -; - -value rec may_be_side_effect_victim = - fun - [ <:expr< $lid:_$ . $_$ >> -> True - | <:expr< $uid:_$ . $e$ >> -> may_be_side_effect_victim e - | _ -> False ] -; - -value rec may_depend_on_order el = - loop False False el where rec loop - side_effect_found side_effect_victim_found = - fun - [ [e :: el] -> - if may_side_effect e then - if side_effect_found || side_effect_victim_found then True - else loop True True el - else if may_be_side_effect_victim e then - if side_effect_found then True else loop False True el - else loop side_effect_found side_effect_victim_found el - | [] -> False ] -; - -value gen_let_in loc expr el = - let (pel, el) = - loop 0 (List.rev el) where rec loop n = - fun - [ [e :: el] -> - if may_side_effect e || may_be_side_effect_victim e then - if n = 0 then - let (pel, el) = loop 1 el in - (pel, [expr e :: el]) - else - let id = "xxx" ^ string_of_int n in - let (pel, el) = loop (n + 1) el in - ([(<:patt< $lid:id$ >>, expr e) :: pel], - [<:expr< $lid:id$ >> :: el]) - else - let (pel, el) = loop n el in - (pel, [expr e :: el]) - | [] -> ([], []) ] - in - match List.rev el with - [ [e :: el] -> (pel, e, el) - | _ -> assert False ] -; - -value left_eval_apply loc expr e1 e2 = - let (f, el) = expr_fa [] <:expr< $e1$ $e2$ >> in - if not (may_depend_on_order [f :: el]) then <:expr< $expr e1$ $expr e2$ >> - else - let (pel, e, el) = gen_let_in loc expr [f :: el] in - let e = List.fold_left (fun e e1 -> <:expr< $e$ $e1$ >>) e el in - List.fold_left (fun e (p1, e1) -> <:expr< let $p1$ = $e1$ in $e$ >>) e pel -; - -value left_eval_tuple loc expr el = - if not (may_depend_on_order el) then <:expr< ($list:List.map expr el$) >> - else - let (pel, e, el) = gen_let_in loc expr el in - List.fold_left (fun e (p1, e1) -> <:expr< let $p1$ = $e1$ in $e$ >>) - <:expr< ($list:[e :: el]$) >> pel -; - -value left_eval_record loc expr lel = - let el = List.map snd lel in - if not (may_depend_on_order el) then - let lel = List.map (fun (p, e) -> (p, expr e)) lel in - <:expr< { $list:lel$ } >> - else - let (pel, e, el) = gen_let_in loc expr el in - let e = - let lel = List.combine (List.map fst lel) [e :: el] in - <:expr< { $list:lel$ } >> - in - List.fold_left (fun e (p1, e1) -> <:expr< let $p1$ = $e1$ in $e$ >>) e pel -; - -value left_eval_assign loc expr e1 e2 = <:expr< $e1$ := $expr e2$ >>; - -(* scanning the input tree, calling "left_eval_*" functions if necessary *) - -value map_option f = - fun - [ Some x -> Some (f x) - | None -> None ] -; - -value class_infos f ci = - {MLast.ciLoc = ci.MLast.ciLoc; MLast.ciVir = ci.MLast.ciVir; - MLast.ciPrm = ci.MLast.ciPrm; MLast.ciNam = ci.MLast.ciNam; - MLast.ciExp = f ci.MLast.ciExp} -; - -value rec expr x = - let loc = MLast.loc_of_expr x in - match x with - [ <:expr< fun [ $list:pwel$ ] >> -> - <:expr< fun [ $list:List.map match_assoc pwel$ ] >> - | <:expr< match $e$ with [ $list:pwel$ ] >> -> - <:expr< match $expr e$ with [ $list:List.map match_assoc pwel$ ] >> - | <:expr< try $e$ with [ $list:pwel$ ] >> -> - <:expr< try $expr e$ with [ $list:List.map match_assoc pwel$ ] >> - | <:expr< let $opt:rf$ $list:pel$ in $e$ >> -> - <:expr< let $opt:rf$ $list:List.map let_binding pel$ in $expr e$ >> - | <:expr< let module $s$ = $me$ in $e$ >> -> - <:expr< let module $s$ = $module_expr me$ in $expr e$ >> - | <:expr< if $e1$ then $e2$ else $e3$ >> -> - <:expr< if $expr e1$ then $expr e2$ else $expr e3$ >> - | <:expr< while $e$ do { $list:el$ } >> -> - <:expr< while $expr e$ do { $list:List.map expr el$ } >> - | <:expr< do { $list:el$ } >> -> <:expr< do { $list:List.map expr el$ } >> - | <:expr< $e$ # $s$ >> -> <:expr< $expr e$ # $s$ >> - | <:expr< ($e$ : $t$) >> -> <:expr< ($expr e$ : $t$) >> - | <:expr< $e1$ || $e2$ >> -> <:expr< $expr e1$ || $expr e2$ >> - | <:expr< $e1$ && $e2$ >> -> <:expr< $expr e1$ && $expr e2$ >> - | <:expr< $e1$ $e2$ >> -> left_eval_apply loc expr e1 e2 - | <:expr< ($list:el$) >> -> left_eval_tuple loc expr el - | <:expr< { $list:lel$ } >> -> left_eval_record loc expr lel - | <:expr< $e1$ := $e2$ >> -> left_eval_assign loc expr e1 e2 - | <:expr< $_$ . $_$ >> | <:expr< $uid:_$ >> | <:expr< $lid:_$ >> | - <:expr< $str:_$ >> | <:expr< $chr:_$ >> | <:expr< $int:_$ >> | - <:expr< $flo:_$ >> | <:expr< new $list:_$ >> -> - x - | x -> not_impl "expr" x ] -and let_binding (p, e) = (p, expr e) -and match_assoc (p, eo, e) = (p, map_option expr eo, expr e) -and module_expr x = - let loc = MLast.loc_of_module_expr x in - match x with - [ <:module_expr< functor ($s$ : $mt$) -> $me$ >> -> - <:module_expr< functor ($s$ : $mt$) -> $module_expr me$ >> - | <:module_expr< ($me$ : $mt$) >> -> - <:module_expr< ($module_expr me$ : $mt$) >> - | <:module_expr< struct $list:sil$ end >> -> - <:module_expr< struct $list:List.map str_item sil$ end >> - | <:module_expr< $_$ . $_$ >> | <:module_expr< $_$ $_$ >> | - <:module_expr< $uid:_$ >> -> - x ] -and str_item x = - let loc = MLast.loc_of_str_item x in - match x with - [ <:str_item< module $s$ = $me$ >> -> - <:str_item< module $s$ = $module_expr me$ >> - | <:str_item< value $opt:rf$ $list:pel$ >> -> - <:str_item< value $opt:rf$ $list:List.map let_binding pel$ >> - | <:str_item< declare $list:sil$ end >> -> - <:str_item< declare $list:List.map str_item sil$ end >> - | <:str_item< class $list:ce$ >> -> - <:str_item< class $list:List.map (class_infos class_expr) ce$ >> - | <:str_item< $exp:e$ >> -> <:str_item< $exp:expr e$ >> - | <:str_item< open $_$ >> | <:str_item< type $list:_$ >> | - <:str_item< exception $_$ of $list:_$ = $_$ >> | - <:str_item< module type $_$ = $_$ >> | <:str_item< # $_$ $opt:_$ >> -> - x - | x -> not_impl "str_item" x ] -and class_expr x = - let loc = MLast.loc_of_class_expr x in - match x with - [ <:class_expr< object $opt:p$ $list:csil$ end >> -> - <:class_expr< object $opt:p$ $list:List.map class_str_item csil$ end >> - | x -> not_impl "class_expr" x ] -and class_str_item x = - let loc = MLast.loc_of_class_str_item x in - match x with - [ <:class_str_item< value $opt:mf$ $s$ = $e$ >> -> - <:class_str_item< value $opt:mf$ $s$ = $expr e$ >> - | <:class_str_item< method $s$ = $e$ >> -> - <:class_str_item< method $s$ = $expr e$ >> - | x -> not_impl "class_str_item" x ] -; - -value parse_implem = Pcaml.parse_implem.val; -value parse_implem_with_left_eval strm = - let (r, b) = parse_implem strm in - (List.map (fun (si, loc) -> (str_item si, loc)) r, b) -; -Pcaml.parse_implem.val := parse_implem_with_left_eval; diff --git a/camlp4/etc/pa_lisp.ml b/camlp4/etc/pa_lisp.ml deleted file mode 100644 index 653baf1ed6..0000000000 --- a/camlp4/etc/pa_lisp.ml +++ /dev/null @@ -1,684 +0,0 @@ -;; camlp4 ./pa_lispr.cmo pa_extend.cmo q_MLast.cmo pr_dump.cmo -;; $Id$ - -(open Pcaml) -(open Stdpp) - -(type (choice 'a 'b) (sum (Left 'a) (Right 'b))) - -;; Buffer - -(module Buff - (struct - (value buff (ref (String.create 80))) - (value store (lambda (len x) - (if (>= len (String.length buff.val)) - (:= buff.val - (^ buff.val - (String.create (String.length buff.val))))) - (:= ([] buff.val len) x) - (succ len))) - (value get (lambda len (String.sub buff.val 0 len))))) - -;; Lexer - -(value rec skip_to_eol - (parser - (((` (or '\n' '\r'))) ()) - (((` _) s) (skip_to_eol s)))) - -(value no_ident (list '(' ')' ' ' '\t' '\n' '\r' ';')) - -(value rec ident - (lambda len - (parser - (((` x (not (List.mem x no_ident))) s) - (ident (Buff.store len x) s)) - (() - (Buff.get len))))) - -(value rec - string (lambda len - (parser - (((` '"')) (Buff.get len)) - (((` '\\') (` c) s) - (string (Buff.store (Buff.store len '\\') c) s)) - (((` x) s) (string (Buff.store len x) s))))) - -(value rec - number (lambda len - (parser - (((` (as (range '0' '9') c)) s) - (number (Buff.store len c) s)) - (() - (, "INT" (Buff.get len)))))) - -(value char_or_quote_id - (lambda x - (parser - (((` ''')) (, "CHAR" (String.make 1 x))) - ((s) - (let ((len (Buff.store (Buff.store 0 ''') x))) - (, "LIDENT" (ident len s))))))) - -(value rec char - (lambda len - (parser - (((` ''')) len) - (((` x) s) (char (Buff.store len x) s))))) - -(value quote - (parser - (((` '\\') (len (char (Buff.store 0 '\\')))) (, "CHAR" (Buff.get len))) - (((` x) s) (char_or_quote_id x s)))) - -(value rec - lexer - (lambda kwt - (parser bp - (((` (or ' ' '\t' '\n' '\r')) s) (lexer kwt s)) - (((` ';') (a (semi kwt bp))) a) - (((` '(')) (, (, "" "(") (, bp (+ bp 1)))) - (((` ')')) (, (, "" ")") (, bp (+ bp 1)))) - (((` '"') (s (string 0))) ep (, (, "STRING" s) (, bp ep))) - (((` ''') (tok quote)) ep (, tok (, bp ep))) - (((` '<') (tok less)) ep (, tok (, bp ep))) - (((` (as (range '0' '9') c)) (n (number (Buff.store 0 c)))) ep - (, n (, bp ep))) - (((` x) (s (ident (Buff.store 0 x)))) ep - (let ((con (try (progn (: (Hashtbl.find kwt s) unit) "") - (Not_found - (match x - ((range 'A' 'Z') "UIDENT") - ((_) "LIDENT")))))) - (, (, con s) (, bp ep)))) - (() (, (, "EOI" "") (, bp (+ bp 1)))))) - semi - (lambda (kwt bp) - (parser - (((` ';') (_ skip_to_eol) s) (lexer kwt s)) - (() ep (, (, "" ";") (, bp ep))))) - less - (parser - (((` ':') (lab (label 0)) (? (` '<') "'<' expected") (q (quotation 0))) - (, "QUOT" (^ lab (^ ":" q)))) - (() (, "LIDENT" "<"))) - label - (lambda len - (parser - (((` (as (or (range 'a' 'z') (range 'A' 'Z') '_') c)) s) - (label (Buff.store len c) s)) - (() (Buff.get len)))) - quotation - (lambda len - (parser - (((` '>') s) (quotation_greater len s)) - (((` x) s) (quotation (Buff.store len x) s)) - (() (failwith "quotation not terminated")))) - quotation_greater - (lambda len - (parser - (((` '>')) (Buff.get len)) - (((a (quotation (Buff.store len '>')))) a)))) - -(value lexer_using - (lambda (kwt (, con prm)) - (match con - ((or "CHAR" "EOI" "INT" "LIDENT" "QUOT" "STRING" "UIDENT") ()) - (("ANTIQUOT") ()) - (("") - (try (Hashtbl.find kwt prm) - (Not_found (Hashtbl.add kwt prm ())))) - (_ (raise - (Token.Error - (^ "the constructor \"" - (^ con "\" is not recognized by Plexer")))))))) - -(value lexer_text - (lambda (, con prm) - (if (= con "") (^ "'" (^ prm "'")) - (if (= prm "") con - (^ con (^ " \"" (^ prm "\""))))))) - -(value lexer_gmake - (lambda () - (let ((kwt (Hashtbl.create 89))) - ({} - (Token.tok_func (Token.lexer_func_of_parser (lexer kwt))) - (Token.tok_using (lexer_using kwt)) - (Token.tok_removing (lambda)) - (Token.tok_match Token.default_match) - (Token.tok_text lexer_text) - (Token.tok_comm None))))) - -;; Building AST - -(type sexpr (sum - (Sexpr MLast.loc (list sexpr)) - (Satom MLast.loc atom string) - (Squot MLast.loc string string)) - atom (sum (Alid) (Auid) (Aint) (Achar) (Astring))) - -(value error_loc - (lambda (loc err) - (raise_with_loc loc (Stream.Error (^ err " expected"))))) -(value error - (lambda (se err) - (let ((loc (match se - ((or (Satom loc _ _) (Sexpr loc _) (Squot loc _ _)) - loc)))) - (error_loc loc err)))) - -(value expr_id - (lambda (loc s) - (match ([] s 0) - ((range 'A' 'Z') <:expr< $uid:s$ >>) - (_ <:expr< $lid:s$ >>)))) - -(value patt_id - (lambda (loc s) - (match ([] s 0) - ((range 'A' 'Z') <:patt< $uid:s$ >>) - (_ <:patt< $lid:s$ >>)))) - -(value ctyp_id - (lambda (loc s) - (match ([] s 0) - (''' (let ((s (String.sub s 1 (- (String.length s) 1)))) - <:ctyp< '$s$ >>)) - ((range 'A' 'Z') <:ctyp< $uid:s$ >>) - (_ <:ctyp< $lid:s$ >>)))) - -(value strm_n "strm__") -(value peek_fun (lambda loc <:expr< Stream.peek >>)) -(value junk_fun (lambda loc <:expr< Stream.junk >>)) - -(value rec - module_expr_se - (lambda_match - ((Sexpr loc (list (Satom _ Alid "struct") :: sl)) - (let ((mel (List.map str_item_se sl))) - <:module_expr< struct $list:mel$ end >>)) - ((Satom loc Auid s) - <:module_expr< $uid:s$ >>) - ((se) - (error se "module expr"))) - str_item_se - (lambda se - (match se - ((or (Satom loc _ _) (Squot loc _ _)) - (let ((e (expr_se se))) <:str_item< $exp:e$ >>)) - ((Sexpr loc (list (Satom _ Alid "module") (Satom _ Auid i) se)) - (let ((mb (module_binding_se se))) - <:str_item< module $i$ = $mb$ >>)) - ((Sexpr loc (list (Satom _ Alid "open") (Satom _ Auid s))) - (let ((s (list s))) - <:str_item< open $s$ >>)) - ((Sexpr loc (list (Satom _ Alid "type") :: sel)) - (let ((tdl (type_declaration_list_se sel))) - <:str_item< type $list:tdl$ >>)) - ((Sexpr loc (list (Satom _ Alid "value") :: sel)) - (let* (((, r sel) - (match sel - ((list (Satom _ Alid "rec") :: sel) (, True sel)) - ((_) (, False sel)))) - (lbs (value_binding_se sel))) - <:str_item< value $opt:r$ $list:lbs$ >>)) - ((Sexpr loc _) - (let ((e (expr_se se))) - <:str_item< $exp:e$ >>)))) - value_binding_se - (lambda_match - ((list se1 se2 :: sel) - (list (, (ipatt_se se1) (expr_se se2)) :: (value_binding_se sel))) - ((list) (list)) - ((list se :: _) (error se "value_binding"))) - module_binding_se - (lambda se (module_expr_se se)) - expr_se - (lambda_match - ((Satom loc (or Alid Auid) s) - (expr_ident_se loc s)) - ((Satom loc Aint s) - <:expr< $int:s$ >>) - ((Satom loc Achar s) - (<:expr< $chr:s$ >>)) - ((Satom loc Astring s) - <:expr< $str:s$ >>) - ((Sexpr loc (list)) - <:expr< () >>) - ((Sexpr loc (list (Satom _ Alid "if") se se1)) - (let* ((e (expr_se se)) - (e1 (expr_se se1))) - <:expr< if $e$ then $e1$ else () >>)) - ((Sexpr loc (list (Satom _ Alid "if") se se1 se2)) - (let* ((e (expr_se se)) - (e1 (expr_se se1)) - (e2 (expr_se se2))) - <:expr< if $e$ then $e1$ else $e2$ >>)) - ((Sexpr loc (list (Satom loc1 Alid "lambda"))) <:expr< fun [] >>) - ((Sexpr loc (list (Satom loc1 Alid "lambda") sep :: sel)) - (let ((e (progn_se loc1 sel))) - (match (ipatt_opt_se sep) - ((Left p) <:expr< fun $p$ -> $e$ >>) - ((Right (, se sel)) - (List.fold_right - (lambda (se e) - (let ((p (ipatt_se se))) <:expr< fun $p$ -> $e$ >>)) - (list se :: sel) e))))) - ((Sexpr loc (list (Satom _ Alid "lambda_match") :: sel)) - (let ((pel (List.map (match_case loc) sel))) - <:expr< fun [ $list:pel$ ] >>)) - ((Sexpr loc (list (Satom _ Alid "let") :: sel)) - (let (((, r sel) - (match sel - ((list (Satom _ Alid "rec") :: sel) (, True sel)) - ((_) (, False sel))))) - (match sel - ((list (Sexpr _ sel1) :: sel2) - (let* ((lbs (List.map let_binding_se sel1)) - (e (progn_se loc sel2))) - <:expr< let $opt:r$ $list:lbs$ in $e$ >>)) - ((list se :: _) (error se "let_binding")) - ((_) (error_loc loc "let_binding"))))) - ((Sexpr loc (list (Satom _ Alid "let*") :: sel)) - (match sel - ((list (Sexpr _ sel1) :: sel2) - (List.fold_right - (lambda (se ek) - (let (((, p e) (let_binding_se se))) - <:expr< let $p$ = $e$ in $ek$ >>)) - sel1 (progn_se loc sel2))) - ((list se :: _) (error se "let_binding")) - ((_) (error_loc loc "let_binding")))) - ((Sexpr loc (list (Satom _ Alid "match") se :: sel)) - (let* ((e (expr_se se)) - (pel (List.map (match_case loc) sel))) - <:expr< match $e$ with [ $list:pel$ ] >>)) - ((Sexpr loc (list (Satom _ Alid "parser") :: sel)) - (let ((e (match sel - ((list (as (Satom _ _ _) se) :: sel) - (let* ((p (patt_se se)) - (pc (parser_cases_se loc sel))) - <:expr< let $p$ = Stream.count $lid:strm_n$ in $pc$ >>)) - (_ (parser_cases_se loc sel))))) - <:expr< fun ($lid:strm_n$ : Stream.t _) -> $e$ >>)) - ((Sexpr loc (list (Satom _ Alid "try") se :: sel)) - (let* ((e (expr_se se)) - (pel (List.map (match_case loc) sel))) - <:expr< try $e$ with [ $list:pel$ ] >>)) - ((Sexpr loc (list (Satom _ Alid "progn") :: sel)) - (let ((el (List.map expr_se sel))) - <:expr< do { $list:el$ } >>)) - ((Sexpr loc (list (Satom _ Alid "while") se :: sel)) - (let* ((e (expr_se se)) - (el (List.map expr_se sel))) - <:expr< while $e$ do { $list:el$ } >>)) - ((Sexpr loc (list (Satom _ Alid ":=") se1 se2)) - (let ((e2 (expr_se se2))) - (match (expr_se se1) - (<:expr< $uid:"()"$ $e1$ $i$ >> <:expr< $e1$.($i$) := $e2$ >>) - (e1 <:expr< $e1$ := $e2$ >>)))) - ((Sexpr loc (list (Satom _ Alid "[]") se1 se2)) - (let* ((e1 (expr_se se1)) (e2 (expr_se se2))) <:expr< $e1$.[$e2$] >>)) - ((Sexpr loc (list (Satom _ Alid ",") :: sel)) - (let ((el (List.map expr_se sel))) <:expr< ( $list:el$ ) >>)) - ((Sexpr loc (list (Satom _ Alid "{}") :: sel)) - (let ((lel (List.map (label_expr_se loc) sel))) <:expr< { $list:lel$ } >>)) - ((Sexpr loc (list (Satom _ Alid ":") se1 se2)) - (let* ((e (expr_se se1)) - (t (ctyp_se se2))) - <:expr< ( $e$ : $t$ ) >>)) - ((Sexpr loc (list (Satom _ Alid "list") :: sel)) - (let rec ((loop - (lambda_match - ((list) <:expr< [] >>) - ((list se1 (Satom _ Alid "::") se2) - (let* ((e (expr_se se1)) - (el (expr_se se2))) - <:expr< [$e$ :: $el$] >>)) - ((list se :: sel) - (let* ((e (expr_se se)) - (el (loop sel))) - <:expr< [$e$ :: $el$] >>))))) - (loop sel))) - ((Sexpr loc (list se :: sel)) - (List.fold_left - (lambda (e se) (let ((e1 (expr_se se))) <:expr< $e$ $e1$ >>)) - (expr_se se) sel)) - ((Squot loc typ txt) - (Pcaml.handle_expr_quotation loc (, typ txt)))) - progn_se - (lambda loc - (lambda_match - ((list) <:expr< () >>) - ((list se) (expr_se se)) - ((sel) (let ((el (List.map expr_se sel))) <:expr< do { $list:el$ } >>)))) - let_binding_se - (lambda_match - ((Sexpr loc (list se1 se2)) (, (ipatt_se se1) (expr_se se2))) - (se (error se "let_binding"))) - match_case - (lambda loc - (lambda_match - ((Sexpr _ (list se1 se2)) - (, (patt_se se1) None (expr_se se2))) - ((Sexpr _ (list se1 sew se2)) - (, (patt_se se1) (Some (expr_se sew)) (expr_se se2))) - (se (error se "match_case")))) - label_expr_se - (lambda loc - (lambda_match - ((Sexpr _ (list se1 se2)) (, (patt_se se1) (expr_se se2))) - (se (error se ("label_expr"))))) - expr_ident_se - (lambda (loc s) - (if (= ([] s 0) '<') - <:expr< $lid:s$ >> - (let rec - ((loop - (lambda (ibeg i) - (if (= i (String.length s)) - (if (> i ibeg) - (expr_id loc (String.sub s ibeg (- i ibeg))) - (raise_with_loc (, (- (+ (fst loc) i) 1) - (+ (fst loc) i)) - (Stream.Error "expr expected"))) - (if (= ([] s i) '.') - (if (> i ibeg) - (let* ((e1 (expr_id - loc - (String.sub s ibeg (- i ibeg)))) - (e2 (loop (+ i 1) (+ i 1)))) - <:expr< $e1$ . $e2$ >>) - (raise_with_loc (, (- (+ (fst loc) i) 1) - (+ (+ (fst loc) i) 1)) - (Stream.Error "expr expected"))) - (loop ibeg (+ i 1))))))) - (loop 0 0)))) - parser_cases_se - (lambda loc - (lambda_match - ((list) <:expr< raise Stream.Failure >>) - ((list (Sexpr loc (list (Sexpr _ spsel) :: act)) :: sel) - (let* ((ekont (lambda _ (parser_cases_se loc sel))) - (act (match act - ((list se) (expr_se se)) - ((list sep se) - (let* ((p (patt_se sep)) - (e (expr_se se))) - <:expr< let $p$ = Stream.count $lid:strm_n$ in $e$ >>)) - (_ (error_loc loc "parser_case"))))) - (stream_pattern_se loc act ekont spsel))) - ((list se :: _) - (error se "parser_case")))) - stream_pattern_se - (lambda (loc act ekont) - (lambda_match - ((list) act) - ((list se :: sel) - (let* ((ckont (lambda err <:expr< raise (Stream.Error $err$) >>)) - (skont (stream_pattern_se loc act ckont sel))) - (stream_pattern_component skont ekont <:expr< "" >> se))))) - stream_pattern_component - (lambda (skont ekont err) - (lambda_match - ((Sexpr loc (list (Satom _ Alid "`") se :: wol)) - (let* ((wo (match wol - ((list se) (Some (expr_se se))) - ((list) None) - (_ (error_loc loc "stream_pattern_component")))) - (e (peek_fun loc)) - (p (patt_se se)) - (j (junk_fun loc)) - (k (ekont err))) - <:expr< match $e$ $lid:strm_n$ with - [ Some $p$ $when:wo$ -> do { $j$ $lid:strm_n$ ; $skont$ } - | _ -> $k$ ] >>)) - ((Sexpr loc (list se1 se2)) - (let* ((p (patt_se se1)) - (e (let ((e (expr_se se2))) - <:expr< try Some ($e$ $lid:strm_n$) with [ Stream.Failure -> None ] >>)) - (k (ekont err))) - <:expr< match $e$ with [ Some $p$ -> $skont$ | _ -> $k$ ] >>)) - ((Sexpr loc (list (Satom _ Alid "?") se1 se2)) - (stream_pattern_component skont ekont (expr_se se2) se1)) - ((Satom loc Alid s) - <:expr< let $lid:s$ = $lid:strm_n$ in $skont$ >>) - (se - (error se "stream_pattern_component")))) - patt_se - (lambda_match - ((Satom loc Alid "_") <:patt< _ >>) - ((Satom loc (or Alid Auid) s) (patt_ident_se loc s)) - ((Satom loc Aint s) - <:patt< $int:s$ >>) - ((Satom loc Achar s) - (<:patt< $chr:s$ >>)) - ((Satom loc Astring s) - <:patt< $str:s$ >>) - ((Sexpr loc (list (Satom _ Alid "or") se :: sel)) - (List.fold_left - (lambda (p se) (let ((p1 (patt_se se))) <:patt< $p$ | $p1$ >>)) - (patt_se se) sel)) - ((Sexpr loc (list (Satom _ Alid "range") se1 se2)) - (let* ((p1 (patt_se se1)) - (p2 (patt_se se2))) - <:patt< $p1$ .. $p2$ >>)) - ((Sexpr loc (list (Satom _ Alid ",") :: sel)) - (let ((pl (List.map patt_se sel))) <:patt< ( $list:pl$ ) >>)) - ((Sexpr loc (list (Satom _ Alid "as") se1 se2)) - (let* ((p1 (patt_se se1)) - (p2 (patt_se se2))) - <:patt< ($p1$ as $p2$) >>)) - ((Sexpr loc (list (Satom _ Alid "list") :: sel)) - (let rec ((loop - (lambda_match - ((list) <:patt< [] >>) - ((list se1 (Satom _ Alid "::") se2) - (let* ((p (patt_se se1)) - (pl (patt_se se2))) - <:patt< [$p$ :: $pl$] >>)) - ((list se :: sel) - (let* ((p (patt_se se)) - (pl (loop sel))) - <:patt< [$p$ :: $pl$] >>))))) - (loop sel))) - ((Sexpr loc (list se :: sel)) - (List.fold_left - (lambda (p se) (let ((p1 (patt_se se))) <:patt< $p$ $p1$ >>)) - (patt_se se) sel)) - ((Sexpr loc (list)) <:patt< () >>) - ((Squot loc typ txt) (Pcaml.handle_patt_quotation loc (, typ txt)))) - patt_ident_se - (lambda (loc s) - (let rec - ((loop - (lambda (ibeg i) - (if (= i (String.length s)) - (if (> i ibeg) - (patt_id loc (String.sub s ibeg (- i ibeg))) - (raise_with_loc (, (- (+ (fst loc) i) 1) - (+ (fst loc) i)) - (Stream.Error "patt expected"))) - (if (= ([] s i) '.') - (if (> i ibeg) - (let* ((p1 (patt_id - loc - (String.sub s ibeg (- i ibeg)))) - (p2 (loop (+ i 1) (+ i 1)))) - <:patt< $p1$ . $p2$ >>) - (raise_with_loc (, (- (+ (fst loc) i) 1) - (+ (+ (fst loc) i) 1)) - (Stream.Error "patt expected"))) - (loop ibeg (+ i 1))))))) - (loop 0 0))) - ipatt_se - (lambda se - (match (ipatt_opt_se se) - ((Left p) p) - ((Right (, se _)) - (error se "ipatt")))) - ipatt_opt_se - (lambda_match - ((Satom loc Alid "_") (Left <:patt< _ >>)) - ((Satom loc Alid s) (Left <:patt< $lid:s$ >>)) - ((Sexpr loc (list (Satom _ Alid ",") :: sel)) - (let ((pl (List.map ipatt_se sel))) (Left <:patt< ( $list:pl$ ) >>))) - ((Sexpr loc (list)) (Left <:patt< () >>)) - ((Sexpr loc (list se :: sel)) (Right (, se sel))) - (se (error se "ipatt"))) - type_declaration_list_se - (lambda_match - ((list se1 se2 :: sel) - (let (((, n1 loc1 tpl) - (match se1 - ((Sexpr _ (list (Satom loc Alid n) :: sel)) - (, n loc (List.map type_parameter_se sel))) - ((Satom loc Alid n) - (, n loc (list))) - ((se) - (error se "type declaration"))))) - (list (, (, loc1 n1) tpl (ctyp_se se2) (list)) :: - (type_declaration_list_se sel)))) - ((list) (list)) - ((list se :: _) (error se "type_declaration"))) - type_parameter_se - (lambda_match - ((Satom _ Alid s) (&& (>= (String.length s) 2) (= ([] s 0) ''')) - (, (String.sub s 1 (- (String.length s) 1)) (, False False))) - (se - (error se "type_parameter"))) - ctyp_se - (lambda_match - ((Sexpr loc (list (Satom _ Alid "sum") :: sel)) - (let ((cdl (List.map constructor_declaration_se sel))) - <:ctyp< [ $list:cdl$ ] >>)) - ((Sexpr loc (list se :: sel)) - (List.fold_left - (lambda (t se) (let ((t2 (ctyp_se se))) <:ctyp< $t$ $t2$ >>)) - (ctyp_se se) sel)) - ((Satom loc (or Alid Auid) s) - (ctyp_ident_se loc s)) - (se - (error se "ctyp"))) - ctyp_ident_se - (lambda (loc s) - (let rec - ((loop (lambda (ibeg i) - (if (= i (String.length s)) - (if (> i ibeg) - (ctyp_id loc (String.sub s ibeg (- i ibeg))) - (raise_with_loc (, (- (+ (fst loc) i) 1) - (+ (fst loc) i)) - (Stream.Error "ctyp expected"))) - (if (= ([] s i) '.') - (if (> i ibeg) - (let* ((t1 (ctyp_id - loc (String.sub s ibeg (- i ibeg)))) - (t2 (loop (+ i 1) (+ i 1)))) - <:ctyp< $t1$ . $t2$ >>) - (raise_with_loc (, (- (+ (fst loc) i) 1) - (+ (+ (fst loc) i) 1)) - (Stream.Error "ctyp expected"))) - (loop ibeg (+ i 1))))))) - (loop 0 0))) - constructor_declaration_se - (lambda_match - ((Sexpr loc (list (Satom _ Auid ci) :: sel)) - (, loc ci (List.map ctyp_se sel))) - (se - (error se "constructor_declaration")))) - -(value top_phrase_se - (lambda se - (match se - ((or (Satom loc _ _) (Squot loc _ _)) (str_item_se se)) - ((Sexpr loc (list (Satom _ Alid s) :: sl)) - (if (= ([] s 0) '#') - (let ((n (String.sub s 1 (- (String.length s) 1)))) - (match sl - ((list (Satom _ Astring s)) - (MLast.StDir loc n (Some <:expr< $str:s$ >>))) - (_ (match ())))) - (str_item_se se))) - ((Sexpr loc _) (str_item_se se))))) - -;; Parser - -(value phony_quot (ref False)) -(Pcaml.add_option "-phony_quot" (Arg.Set phony_quot) "phony quotations") - -(:= Pcaml.no_constructors_arity.val False) - -(progn - (Grammar.Unsafe.gram_reinit gram (lexer_gmake ())) - (Grammar.Unsafe.clear_entry interf) - (Grammar.Unsafe.clear_entry implem) - (Grammar.Unsafe.clear_entry top_phrase) - (Grammar.Unsafe.clear_entry use_file) - (Grammar.Unsafe.clear_entry module_type) - (Grammar.Unsafe.clear_entry module_expr) - (Grammar.Unsafe.clear_entry sig_item) - (Grammar.Unsafe.clear_entry str_item) - (Grammar.Unsafe.clear_entry expr) - (Grammar.Unsafe.clear_entry patt) - (Grammar.Unsafe.clear_entry ctyp) - (Grammar.Unsafe.clear_entry let_binding) - (Grammar.Unsafe.clear_entry class_type) - (Grammar.Unsafe.clear_entry class_expr) - (Grammar.Unsafe.clear_entry class_sig_item) - (Grammar.Unsafe.clear_entry class_str_item)) - -(:= Pcaml.parse_interf.val (Grammar.Entry.parse interf)) -(:= Pcaml.parse_implem.val (Grammar.Entry.parse implem)) - -(value sexpr (Grammar.Entry.create gram "sexpr")) -(value atom (Grammar.Entry.create gram "atom")) - -EXTEND - implem : - [ [ st = LIST0 [ s = str_item -> (, s loc) ]; EOI -> (, st False) ] ] - ; - top_phrase : - [ [ se = sexpr -> (Some (top_phrase_se se)) - | EOI -> None ] ] - ; - use_file : - [ [ l = LIST0 sexpr; EOI -> (, (List.map top_phrase_se l) False) ] ] - ; - str_item : - [ [ se = sexpr -> (str_item_se se) - | e = expr -> <:str_item< $exp:e$ >> ] ] - ; - expr : - [ "top" - [ se = sexpr -> (expr_se se) ] ] - ; - patt : - [ [ se = sexpr -> (patt_se se) ] ] - ; - sexpr : - [ [ "("; sl = LIST0 sexpr; ")" -> (Sexpr loc sl) - | a = atom -> (Satom loc Alid a) - | s = LIDENT -> (Satom loc Alid s) - | s = UIDENT -> (Satom loc Auid s) - | s = INT -> (Satom loc Aint s) - | s = CHAR -> (Satom loc Achar s) - | s = STRING -> (Satom loc Astring s) - | s = QUOT -> - (let* ((i (String.index s ':')) - (typ (String.sub s 0 i)) - (txt (String.sub s (+ i 1) (- (- (String.length s) i) 1)))) - (if phony_quot.val - (Satom loc Alid (^ "<:" (^ typ (^ "<" (^ txt ">>"))))) - (Squot loc typ txt))) ] ] - ; - atom : - [ [ "_" -> "_" - | "," -> "," - | "=" -> "=" - | ":" -> ":" - | "." -> "." ] ] - ; -END diff --git a/camlp4/etc/pa_lispr.ml b/camlp4/etc/pa_lispr.ml deleted file mode 100644 index fb150e2096..0000000000 --- a/camlp4/etc/pa_lispr.ml +++ /dev/null @@ -1,665 +0,0 @@ -(* camlp4 pa_r.cmo pa_rp.cmo pa_extend.cmo q_MLast.cmo pr_dump.cmo *) -(* File generated by pretty print; do not edit! *) - -open Pcaml; -open Stdpp; - -type choice 'a 'b = - [ Left of 'a - | Right of 'b ] -; - -(* Buffer *) - -module Buff = - struct - value buff = ref (String.create 80); - value store len x = - do { - if len >= String.length buff.val then - buff.val := buff.val ^ String.create (String.length buff.val) - else (); - buff.val.[len] := x; - succ len - } - ; - value get len = String.sub buff.val 0 len; - end -; - -(* Lexer *) - -value rec skip_to_eol = - parser - [ [: `'\n' | '\r' :] -> () - | [: `_; s :] -> skip_to_eol s ] -; - -value no_ident = ['('; ')'; ' '; '\t'; '\n'; '\r'; ';']; - -value rec ident len = - parser - [ [: `x when not (List.mem x no_ident); s :] -> ident (Buff.store len x) s - | [: :] -> Buff.get len ] -; - -value rec string len = - parser - [ [: `'"' :] -> Buff.get len - | [: `'\\'; `c; s :] -> string (Buff.store (Buff.store len '\\') c) s - | [: `x; s :] -> string (Buff.store len x) s ] -; - -value rec number len = - parser - [ [: `('0'..'9' as c); s :] -> number (Buff.store len c) s - | [: :] -> ("INT", Buff.get len) ] -; - -value char_or_quote_id x = - parser - [ [: `''' :] -> ("CHAR", String.make 1 x) - | [: s :] -> - let len = Buff.store (Buff.store 0 ''') x in - ("LIDENT", ident len s) ] -; - -value rec char len = - parser - [ [: `''' :] -> len - | [: `x; s :] -> char (Buff.store len x) s ] -; - -value quote = - parser - [ [: `'\\'; len = char (Buff.store 0 '\\') :] -> ("CHAR", Buff.get len) - | [: `x; s :] -> char_or_quote_id x s ] -; - -value rec lexer kwt = - parser bp - [ [: `' ' | '\t' | '\n' | '\r'; s :] -> lexer kwt s - | [: `';'; a = semi kwt bp :] -> a - | [: `'(' :] -> (("", "("), (bp, bp + 1)) - | [: `')' :] -> (("", ")"), (bp, bp + 1)) - | [: `'"'; s = string 0 :] ep -> (("STRING", s), (bp, ep)) - | [: `'''; tok = quote :] ep -> (tok, (bp, ep)) - | [: `'<'; tok = less :] ep -> (tok, (bp, ep)) - | [: `('0'..'9' as c); n = number (Buff.store 0 c) :] ep -> (n, (bp, ep)) - | [: `x; s = ident (Buff.store 0 x) :] ep -> - let con = - try do { (Hashtbl.find kwt s : unit); "" } with - [ Not_found -> - match x with - [ 'A'..'Z' -> "UIDENT" - | _ -> "LIDENT" ] ] - in - ((con, s), (bp, ep)) - | [: :] -> (("EOI", ""), (bp, bp + 1)) ] -and semi kwt bp = - parser - [ [: `';'; _ = skip_to_eol; s :] -> lexer kwt s - | [: :] ep -> (("", ";"), (bp, ep)) ] -and less = - parser - [ [: `':'; lab = label 0; `'<' ? "'<' expected"; q = quotation 0 :] -> - ("QUOT", lab ^ ":" ^ q) - | [: :] -> ("LIDENT", "<") ] -and label len = - parser - [ [: `('a'..'z' | 'A'..'Z' | '_' as c); s :] -> label (Buff.store len c) s - | [: :] -> Buff.get len ] -and quotation len = - parser - [ [: `'>'; s :] -> quotation_greater len s - | [: `x; s :] -> quotation (Buff.store len x) s - | [: :] -> failwith "quotation not terminated" ] -and quotation_greater len = - parser - [ [: `'>' :] -> Buff.get len - | [: a = quotation (Buff.store len '>') :] -> a ] -; - -value lexer_using kwt (con, prm) = - match con with - [ "CHAR" | "EOI" | "INT" | "LIDENT" | "QUOT" | "STRING" | "UIDENT" -> () - | "ANTIQUOT" -> () - | "" -> - try Hashtbl.find kwt prm with [ Not_found -> Hashtbl.add kwt prm () ] - | _ -> - raise - (Token.Error - ("the constructor \"" ^ con ^ "\" is not recognized by Plexer")) ] -; - -value lexer_text (con, prm) = - if con = "" then "'" ^ prm ^ "'" - else if prm = "" then con - else con ^ " \"" ^ prm ^ "\"" -; - -value lexer_gmake () = - let kwt = Hashtbl.create 89 in - {Token.tok_func = Token.lexer_func_of_parser (lexer kwt); - Token.tok_using = lexer_using kwt; Token.tok_removing = fun []; - Token.tok_match = Token.default_match; Token.tok_text = lexer_text; - Token.tok_comm = None} -; - -(* Building AST *) - -type sexpr = - [ Sexpr of MLast.loc and list sexpr - | Satom of MLast.loc and atom and string - | Squot of MLast.loc and string and string ] -and atom = - [ Alid - | Auid - | Aint - | Achar - | Astring ] -; - -value error_loc loc err = - raise_with_loc loc (Stream.Error (err ^ " expected")) -; -value error se err = - let loc = - match se with [ Satom loc _ _ | Sexpr loc _ | Squot loc _ _ -> loc ] - in - error_loc loc err -; - -value expr_id loc s = - match s.[0] with - [ 'A'..'Z' -> <:expr< $uid:s$ >> - | _ -> <:expr< $lid:s$ >> ] -; - -value patt_id loc s = - match s.[0] with - [ 'A'..'Z' -> <:patt< $uid:s$ >> - | _ -> <:patt< $lid:s$ >> ] -; - -value ctyp_id loc s = - match s.[0] with - [ ''' -> - let s = String.sub s 1 (String.length s - 1) in - <:ctyp< '$s$ >> - | 'A'..'Z' -> <:ctyp< $uid:s$ >> - | _ -> <:ctyp< $lid:s$ >> ] -; - -value strm_n = "strm__"; -value peek_fun loc = <:expr< Stream.peek >>; -value junk_fun loc = <:expr< Stream.junk >>; - -value rec module_expr_se = - fun - [ Sexpr loc [Satom _ Alid "struct" :: sl] -> - let mel = List.map str_item_se sl in - <:module_expr< struct $list:mel$ end >> - | Satom loc Auid s -> <:module_expr< $uid:s$ >> - | se -> error se "module expr" ] -and str_item_se se = - match se with - [ Satom loc _ _ | Squot loc _ _ -> - let e = expr_se se in - <:str_item< $exp:e$ >> - | Sexpr loc [Satom _ Alid "module"; Satom _ Auid i; se] -> - let mb = module_binding_se se in - <:str_item< module $i$ = $mb$ >> - | Sexpr loc [Satom _ Alid "open"; Satom _ Auid s] -> - let s = [s] in - <:str_item< open $s$ >> - | Sexpr loc [Satom _ Alid "type" :: sel] -> - let tdl = type_declaration_list_se sel in - <:str_item< type $list:tdl$ >> - | Sexpr loc [Satom _ Alid "value" :: sel] -> - let (r, sel) = - match sel with - [ [Satom _ Alid "rec" :: sel] -> (True, sel) - | _ -> (False, sel) ] - in - let lbs = value_binding_se sel in - <:str_item< value $opt:r$ $list:lbs$ >> - | Sexpr loc _ -> - let e = expr_se se in - <:str_item< $exp:e$ >> ] -and value_binding_se = - fun - [ [se1; se2 :: sel] -> [(ipatt_se se1, expr_se se2) :: value_binding_se sel] - | [] -> [] - | [se :: _] -> error se "value_binding" ] -and module_binding_se se = module_expr_se se -and expr_se = - fun - [ Satom loc (Alid | Auid) s -> expr_ident_se loc s - | Satom loc Aint s -> <:expr< $int:s$ >> - | Satom loc Achar s -> <:expr< $chr:s$ >> - | Satom loc Astring s -> <:expr< $str:s$ >> - | Sexpr loc [] -> <:expr< () >> - | Sexpr loc [Satom _ Alid "if"; se; se1] -> - let e = expr_se se in - let e1 = expr_se se1 in - <:expr< if $e$ then $e1$ else () >> - | Sexpr loc [Satom _ Alid "if"; se; se1; se2] -> - let e = expr_se se in - let e1 = expr_se se1 in - let e2 = expr_se se2 in - <:expr< if $e$ then $e1$ else $e2$ >> - | Sexpr loc [Satom loc1 Alid "lambda"] -> <:expr< fun [] >> - | Sexpr loc [Satom loc1 Alid "lambda"; sep :: sel] -> - let e = progn_se loc1 sel in - match ipatt_opt_se sep with - [ Left p -> <:expr< fun $p$ -> $e$ >> - | Right (se, sel) -> - List.fold_right - (fun se e -> - let p = ipatt_se se in - <:expr< fun $p$ -> $e$ >>) - [se :: sel] e ] - | Sexpr loc [Satom _ Alid "lambda_match" :: sel] -> - let pel = List.map (match_case loc) sel in - <:expr< fun [ $list:pel$ ] >> - | Sexpr loc [Satom _ Alid "let" :: sel] -> - let (r, sel) = - match sel with - [ [Satom _ Alid "rec" :: sel] -> (True, sel) - | _ -> (False, sel) ] - in - match sel with - [ [Sexpr _ sel1 :: sel2] -> - let lbs = List.map let_binding_se sel1 in - let e = progn_se loc sel2 in - <:expr< let $opt:r$ $list:lbs$ in $e$ >> - | [se :: _] -> error se "let_binding" - | _ -> error_loc loc "let_binding" ] - | Sexpr loc [Satom _ Alid "let*" :: sel] -> - match sel with - [ [Sexpr _ sel1 :: sel2] -> - List.fold_right - (fun se ek -> - let (p, e) = let_binding_se se in - <:expr< let $p$ = $e$ in $ek$ >>) - sel1 (progn_se loc sel2) - | [se :: _] -> error se "let_binding" - | _ -> error_loc loc "let_binding" ] - | Sexpr loc [Satom _ Alid "match"; se :: sel] -> - let e = expr_se se in - let pel = List.map (match_case loc) sel in - <:expr< match $e$ with [ $list:pel$ ] >> - | Sexpr loc [Satom _ Alid "parser" :: sel] -> - let e = - match sel with - [ [(Satom _ _ _ as se) :: sel] -> - let p = patt_se se in - let pc = parser_cases_se loc sel in - <:expr< let $p$ = Stream.count $lid:strm_n$ in $pc$ >> - | _ -> parser_cases_se loc sel ] - in - <:expr< fun ($lid:strm_n$ : Stream.t _) -> $e$ >> - | Sexpr loc [Satom _ Alid "try"; se :: sel] -> - let e = expr_se se in - let pel = List.map (match_case loc) sel in - <:expr< try $e$ with [ $list:pel$ ] >> - | Sexpr loc [Satom _ Alid "progn" :: sel] -> - let el = List.map expr_se sel in - <:expr< do { $list:el$ } >> - | Sexpr loc [Satom _ Alid "while"; se :: sel] -> - let e = expr_se se in - let el = List.map expr_se sel in - <:expr< while $e$ do { $list:el$ } >> - | Sexpr loc [Satom _ Alid ":="; se1; se2] -> - let e2 = expr_se se2 in - match expr_se se1 with - [ <:expr< $uid:"()"$ $e1$ $i$ >> -> <:expr< $e1$.($i$) := $e2$ >> - | e1 -> <:expr< $e1$ := $e2$ >> ] - | Sexpr loc [Satom _ Alid "[]"; se1; se2] -> - let e1 = expr_se se1 in - let e2 = expr_se se2 in - <:expr< $e1$.[$e2$] >> - | Sexpr loc [Satom _ Alid "," :: sel] -> - let el = List.map expr_se sel in - <:expr< ( $list:el$ ) >> - | Sexpr loc [Satom _ Alid "{}" :: sel] -> - let lel = List.map (label_expr_se loc) sel in - <:expr< { $list:lel$ } >> - | Sexpr loc [Satom _ Alid ":"; se1; se2] -> - let e = expr_se se1 in - let t = ctyp_se se2 in - <:expr< ( $e$ : $t$ ) >> - | Sexpr loc [Satom _ Alid "list" :: sel] -> - let rec loop = - fun - [ [] -> <:expr< [] >> - | [se1; Satom _ Alid "::"; se2] -> - let e = expr_se se1 in - let el = expr_se se2 in - <:expr< [$e$ :: $el$] >> - | [se :: sel] -> - let e = expr_se se in - let el = loop sel in - <:expr< [$e$ :: $el$] >> ] - in - loop sel - | Sexpr loc [se :: sel] -> - List.fold_left - (fun e se -> - let e1 = expr_se se in - <:expr< $e$ $e1$ >>) - (expr_se se) sel - | Squot loc typ txt -> Pcaml.handle_expr_quotation loc (typ, txt) ] -and progn_se loc = - fun - [ [] -> <:expr< () >> - | [se] -> expr_se se - | sel -> - let el = List.map expr_se sel in - <:expr< do { $list:el$ } >> ] -and let_binding_se = - fun - [ Sexpr loc [se1; se2] -> (ipatt_se se1, expr_se se2) - | se -> error se "let_binding" ] -and match_case loc = - fun - [ Sexpr _ [se1; se2] -> (patt_se se1, None, expr_se se2) - | Sexpr _ [se1; sew; se2] -> (patt_se se1, Some (expr_se sew), expr_se se2) - | se -> error se "match_case" ] -and label_expr_se loc = - fun - [ Sexpr _ [se1; se2] -> (patt_se se1, expr_se se2) - | se -> error se "label_expr" ] -and expr_ident_se loc s = - if s.[0] = '<' then <:expr< $lid:s$ >> - else - let rec loop ibeg i = - if i = String.length s then - if i > ibeg then expr_id loc (String.sub s ibeg (i - ibeg)) - else - raise_with_loc (fst loc + i - 1, fst loc + i) - (Stream.Error "expr expected") - else if s.[i] = '.' then - if i > ibeg then - let e1 = expr_id loc (String.sub s ibeg (i - ibeg)) in - let e2 = loop (i + 1) (i + 1) in - <:expr< $e1$ . $e2$ >> - else - raise_with_loc (fst loc + i - 1, fst loc + i + 1) - (Stream.Error "expr expected") - else loop ibeg (i + 1) - in - loop 0 0 -and parser_cases_se loc = - fun - [ [] -> <:expr< raise Stream.Failure >> - | [Sexpr loc [Sexpr _ spsel :: act] :: sel] -> - let ekont _ = parser_cases_se loc sel in - let act = - match act with - [ [se] -> expr_se se - | [sep; se] -> - let p = patt_se sep in - let e = expr_se se in - <:expr< let $p$ = Stream.count $lid:strm_n$ in $e$ >> - | _ -> error_loc loc "parser_case" ] - in - stream_pattern_se loc act ekont spsel - | [se :: _] -> error se "parser_case" ] -and stream_pattern_se loc act ekont = - fun - [ [] -> act - | [se :: sel] -> - let ckont err = <:expr< raise (Stream.Error $err$) >> in - let skont = stream_pattern_se loc act ckont sel in - stream_pattern_component skont ekont <:expr< "" >> se ] -and stream_pattern_component skont ekont err = - fun - [ Sexpr loc [Satom _ Alid "`"; se :: wol] -> - let wo = - match wol with - [ [se] -> Some (expr_se se) - | [] -> None - | _ -> error_loc loc "stream_pattern_component" ] - in - let e = peek_fun loc in - let p = patt_se se in - let j = junk_fun loc in - let k = ekont err in - <:expr< match $e$ $lid:strm_n$ with - [ Some $p$ $when:wo$ -> do { $j$ $lid:strm_n$ ; $skont$ } - | _ -> $k$ ] >> - | Sexpr loc [se1; se2] -> - let p = patt_se se1 in - let e = - let e = expr_se se2 in - <:expr< try Some ($e$ $lid:strm_n$) with [ Stream.Failure -> None ] >> - in - let k = ekont err in - <:expr< match $e$ with [ Some $p$ -> $skont$ | _ -> $k$ ] >> - | Sexpr loc [Satom _ Alid "?"; se1; se2] -> - stream_pattern_component skont ekont (expr_se se2) se1 - | Satom loc Alid s -> <:expr< let $lid:s$ = $lid:strm_n$ in $skont$ >> - | se -> error se "stream_pattern_component" ] -and patt_se = - fun - [ Satom loc Alid "_" -> <:patt< _ >> - | Satom loc (Alid | Auid) s -> patt_ident_se loc s - | Satom loc Aint s -> <:patt< $int:s$ >> - | Satom loc Achar s -> <:patt< $chr:s$ >> - | Satom loc Astring s -> <:patt< $str:s$ >> - | Sexpr loc [Satom _ Alid "or"; se :: sel] -> - List.fold_left - (fun p se -> - let p1 = patt_se se in - <:patt< $p$ | $p1$ >>) - (patt_se se) sel - | Sexpr loc [Satom _ Alid "range"; se1; se2] -> - let p1 = patt_se se1 in - let p2 = patt_se se2 in - <:patt< $p1$ .. $p2$ >> - | Sexpr loc [Satom _ Alid "," :: sel] -> - let pl = List.map patt_se sel in - <:patt< ( $list:pl$ ) >> - | Sexpr loc [Satom _ Alid "as"; se1; se2] -> - let p1 = patt_se se1 in - let p2 = patt_se se2 in - <:patt< ($p1$ as $p2$) >> - | Sexpr loc [Satom _ Alid "list" :: sel] -> - let rec loop = - fun - [ [] -> <:patt< [] >> - | [se1; Satom _ Alid "::"; se2] -> - let p = patt_se se1 in - let pl = patt_se se2 in - <:patt< [$p$ :: $pl$] >> - | [se :: sel] -> - let p = patt_se se in - let pl = loop sel in - <:patt< [$p$ :: $pl$] >> ] - in - loop sel - | Sexpr loc [se :: sel] -> - List.fold_left - (fun p se -> - let p1 = patt_se se in - <:patt< $p$ $p1$ >>) - (patt_se se) sel - | Sexpr loc [] -> <:patt< () >> - | Squot loc typ txt -> Pcaml.handle_patt_quotation loc (typ, txt) ] -and patt_ident_se loc s = - loop 0 0 where rec loop ibeg i = - if i = String.length s then - if i > ibeg then patt_id loc (String.sub s ibeg (i - ibeg)) - else - raise_with_loc (fst loc + i - 1, fst loc + i) - (Stream.Error "patt expected") - else if s.[i] = '.' then - if i > ibeg then - let p1 = patt_id loc (String.sub s ibeg (i - ibeg)) in - let p2 = loop (i + 1) (i + 1) in - <:patt< $p1$ . $p2$ >> - else - raise_with_loc (fst loc + i - 1, fst loc + i + 1) - (Stream.Error "patt expected") - else loop ibeg (i + 1) -and ipatt_se se = - match ipatt_opt_se se with - [ Left p -> p - | Right (se, _) -> error se "ipatt" ] -and ipatt_opt_se = - fun - [ Satom loc Alid "_" -> Left <:patt< _ >> - | Satom loc Alid s -> Left <:patt< $lid:s$ >> - | Sexpr loc [Satom _ Alid "," :: sel] -> - let pl = List.map ipatt_se sel in - Left <:patt< ( $list:pl$ ) >> - | Sexpr loc [] -> Left <:patt< () >> - | Sexpr loc [se :: sel] -> Right (se, sel) - | se -> error se "ipatt" ] -and type_declaration_list_se = - fun - [ [se1; se2 :: sel] -> - let (n1, loc1, tpl) = - match se1 with - [ Sexpr _ [Satom loc Alid n :: sel] -> - (n, loc, List.map type_parameter_se sel) - | Satom loc Alid n -> (n, loc, []) - | se -> error se "type declaration" ] - in - [((loc1, n1), tpl, ctyp_se se2, []) :: type_declaration_list_se sel] - | [] -> [] - | [se :: _] -> error se "type_declaration" ] -and type_parameter_se = - fun - [ Satom _ Alid s when String.length s >= 2 && s.[0] = ''' -> - (String.sub s 1 (String.length s - 1), (False, False)) - | se -> error se "type_parameter" ] -and ctyp_se = - fun - [ Sexpr loc [Satom _ Alid "sum" :: sel] -> - let cdl = List.map constructor_declaration_se sel in - <:ctyp< [ $list:cdl$ ] >> - | Sexpr loc [se :: sel] -> - List.fold_left - (fun t se -> - let t2 = ctyp_se se in - <:ctyp< $t$ $t2$ >>) - (ctyp_se se) sel - | Satom loc (Alid | Auid) s -> ctyp_ident_se loc s - | se -> error se "ctyp" ] -and ctyp_ident_se loc s = - loop 0 0 where rec loop ibeg i = - if i = String.length s then - if i > ibeg then ctyp_id loc (String.sub s ibeg (i - ibeg)) - else - raise_with_loc (fst loc + i - 1, fst loc + i) - (Stream.Error "ctyp expected") - else if s.[i] = '.' then - if i > ibeg then - let t1 = ctyp_id loc (String.sub s ibeg (i - ibeg)) in - let t2 = loop (i + 1) (i + 1) in - <:ctyp< $t1$ . $t2$ >> - else - raise_with_loc (fst loc + i - 1, fst loc + i + 1) - (Stream.Error "ctyp expected") - else loop ibeg (i + 1) -and constructor_declaration_se = - fun - [ Sexpr loc [Satom _ Auid ci :: sel] -> (loc, ci, List.map ctyp_se sel) - | se -> error se "constructor_declaration" ] -; - -value top_phrase_se se = - match se with - [ Satom loc _ _ | Squot loc _ _ -> str_item_se se - | Sexpr loc [Satom _ Alid s :: sl] -> - if s.[0] = '#' then - let n = String.sub s 1 (String.length s - 1) in - match sl with - [ [Satom _ Astring s] -> MLast.StDir loc n (Some <:expr< $str:s$ >>) - | _ -> match () with [] ] - else str_item_se se - | Sexpr loc _ -> str_item_se se ] -; - -(* Parser *) - -value phony_quot = ref False; -Pcaml.add_option "-phony_quot" (Arg.Set phony_quot) "phony quotations"; - -Pcaml.no_constructors_arity.val := False; - -do { - Grammar.Unsafe.gram_reinit gram (lexer_gmake ()); - Grammar.Unsafe.clear_entry interf; - Grammar.Unsafe.clear_entry implem; - Grammar.Unsafe.clear_entry top_phrase; - Grammar.Unsafe.clear_entry use_file; - Grammar.Unsafe.clear_entry module_type; - Grammar.Unsafe.clear_entry module_expr; - Grammar.Unsafe.clear_entry sig_item; - Grammar.Unsafe.clear_entry str_item; - Grammar.Unsafe.clear_entry expr; - Grammar.Unsafe.clear_entry patt; - Grammar.Unsafe.clear_entry ctyp; - Grammar.Unsafe.clear_entry let_binding; - Grammar.Unsafe.clear_entry class_type; - Grammar.Unsafe.clear_entry class_expr; - Grammar.Unsafe.clear_entry class_sig_item; - Grammar.Unsafe.clear_entry class_str_item -}; - -Pcaml.parse_interf.val := Grammar.Entry.parse interf; -Pcaml.parse_implem.val := Grammar.Entry.parse implem; - -value sexpr = Grammar.Entry.create gram "sexpr"; -value atom = Grammar.Entry.create gram "atom"; - -EXTEND - implem: - [ [ st = LIST0 [ s = str_item -> (s, loc) ]; EOI -> (st, False) ] ] - ; - top_phrase: - [ [ se = sexpr -> Some (top_phrase_se se) - | EOI -> None ] ] - ; - use_file: - [ [ l = LIST0 sexpr; EOI -> (List.map top_phrase_se l, False) ] ] - ; - str_item: - [ [ se = sexpr -> str_item_se se - | e = expr -> <:str_item< $exp:e$ >> ] ] - ; - expr: - [ "top" - [ se = sexpr -> expr_se se ] ] - ; - patt: - [ [ se = sexpr -> patt_se se ] ] - ; - sexpr: - [ [ "("; sl = LIST0 sexpr; ")" -> Sexpr loc sl - | a = atom -> Satom loc Alid a - | s = LIDENT -> Satom loc Alid s - | s = UIDENT -> Satom loc Auid s - | s = INT -> Satom loc Aint s - | s = CHAR -> Satom loc Achar s - | s = STRING -> Satom loc Astring s - | s = QUOT -> - let i = String.index s ':' in - let typ = String.sub s 0 i in - let txt = String.sub s (i + 1) (String.length s - i - 1) in - if phony_quot.val then - Satom loc Alid ("<:" ^ typ ^ "<" ^ txt ^ ">>") - else Squot loc typ txt ] ] - ; - atom: - [ [ "_" -> "_" - | "," -> "," - | "=" -> "=" - | ":" -> ":" - | "." -> "." ] ] - ; -END; diff --git a/camlp4/etc/pa_o.ml b/camlp4/etc/pa_o.ml deleted file mode 100644 index 4f27f5ecc6..0000000000 --- a/camlp4/etc/pa_o.ml +++ /dev/null @@ -1,1293 +0,0 @@ -(* camlp4r pa_extend.cmo q_MLast.cmo *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -open Stdpp; -open Pcaml; - -Pcaml.syntax_name.val := "OCaml"; -Pcaml.no_constructors_arity.val := True; - -do { - let odfa = Plexer.dollar_for_antiquotation.val in - Plexer.dollar_for_antiquotation.val := False; - Grammar.Unsafe.gram_reinit gram (Plexer.gmake ()); - Plexer.dollar_for_antiquotation.val := odfa; - Grammar.Unsafe.clear_entry interf; - Grammar.Unsafe.clear_entry implem; - Grammar.Unsafe.clear_entry top_phrase; - Grammar.Unsafe.clear_entry use_file; - Grammar.Unsafe.clear_entry module_type; - Grammar.Unsafe.clear_entry module_expr; - Grammar.Unsafe.clear_entry sig_item; - Grammar.Unsafe.clear_entry str_item; - Grammar.Unsafe.clear_entry expr; - Grammar.Unsafe.clear_entry patt; - Grammar.Unsafe.clear_entry ctyp; - Grammar.Unsafe.clear_entry let_binding; - Grammar.Unsafe.clear_entry type_declaration; - Grammar.Unsafe.clear_entry class_type; - Grammar.Unsafe.clear_entry class_expr; - Grammar.Unsafe.clear_entry class_sig_item; - Grammar.Unsafe.clear_entry class_str_item -}; - -Pcaml.parse_interf.val := Grammar.Entry.parse interf; -Pcaml.parse_implem.val := Grammar.Entry.parse implem; - -value o2b = - fun - [ Some _ -> True - | None -> False ] -; - -value mkumin loc f arg = - match (f, arg) with - [ ("-", <:expr< $int:n$ >>) when int_of_string n > 0 -> - let n = "-" ^ n in - <:expr< $int:n$ >> - | ("-", MLast.ExInt32 loc n) when (Int32.of_string n) > 0l -> - MLast.ExInt32 loc ("-" ^ n) - | ("-", MLast.ExInt64 loc n) when (Int64.of_string n) > 0L -> - MLast.ExInt64 loc ("-" ^ n) - | ("-", MLast.ExNativeInt loc n) when (Nativeint.of_string n) > 0n -> - MLast.ExNativeInt loc ("-" ^ n) - | (_, <:expr< $flo:n$ >>) when float_of_string n > 0.0 -> - let n = "-" ^ n in - <:expr< $flo:n$ >> - | _ -> - let f = "~" ^ f in - <:expr< $lid:f$ $arg$ >> ] -; - -value mklistexp loc last = - loop True where rec loop top = - fun - [ [] -> - match last with - [ Some e -> e - | None -> <:expr< [] >> ] - | [e1 :: el] -> - let loc = if top then loc else (fst (MLast.loc_of_expr e1), snd loc) in - <:expr< [$e1$ :: $loop False el$] >> ] -; - -value mklistpat loc last = - loop True where rec loop top = - fun - [ [] -> - match last with - [ Some p -> p - | None -> <:patt< [] >> ] - | [p1 :: pl] -> - let loc = if top then loc else (fst (MLast.loc_of_patt p1), snd loc) in - <:patt< [$p1$ :: $loop False pl$] >> ] -; - -value is_operator = - let ht = Hashtbl.create 73 in - let ct = Hashtbl.create 73 in - do { - List.iter (fun x -> Hashtbl.add ht x True) - ["asr"; "land"; "lor"; "lsl"; "lsr"; "lxor"; "mod"; "or"]; - List.iter (fun x -> Hashtbl.add ct x True) - ['!'; '&'; '*'; '+'; '-'; '/'; ':'; '<'; '='; '>'; '@'; '^'; '|'; '~'; - '?'; '%'; '.'; '$']; - fun x -> - try Hashtbl.find ht x with - [ Not_found -> try Hashtbl.find ct x.[0] with _ -> False ] - } -; - -value operator_rparen = - Grammar.Entry.of_parser gram "operator_rparen" - (fun strm -> - match Stream.npeek 2 strm with - [ [("", s); ("", ")")] when is_operator s -> - do { Stream.junk strm; Stream.junk strm; s } - | _ -> raise Stream.Failure ]) -; - -value lident_colon = - Grammar.Entry.of_parser gram "lident_colon" - (fun strm -> - match Stream.npeek 2 strm with - [ [("LIDENT", i); ("", ":")] -> - do { Stream.junk strm; Stream.junk strm; i } - | _ -> raise Stream.Failure ]) -; - -value symbolchar = - let list = - ['!'; '$'; '%'; '&'; '*'; '+'; '-'; '.'; '/'; ':'; '<'; '='; '>'; '?'; - '@'; '^'; '|'; '~'] - in - let rec loop s i = - if i == String.length s then True - else if List.mem s.[i] list then loop s (i + 1) - else False - in - loop -; - -value prefixop = - let list = ['!'; '?'; '~'] in - let excl = ["!="; "??"] in - Grammar.Entry.of_parser gram "prefixop" - (parser - [: `("", x) - when - not (List.mem x excl) && String.length x >= 2 && - List.mem x.[0] list && symbolchar x 1 :] -> - x) -; - -value infixop0 = - let list = ['='; '<'; '>'; '|'; '&'; '$'] in - let excl = ["<-"; "||"; "&&"] in - Grammar.Entry.of_parser gram "infixop0" - (parser - [: `("", x) - when - not (List.mem x excl) && String.length x >= 2 && - List.mem x.[0] list && symbolchar x 1 :] -> - x) -; - -value infixop1 = - let list = ['@'; '^'] in - Grammar.Entry.of_parser gram "infixop1" - (parser - [: `("", x) - when - String.length x >= 2 && List.mem x.[0] list && - symbolchar x 1 :] -> - x) -; - -value infixop2 = - let list = ['+'; '-'] in - Grammar.Entry.of_parser gram "infixop2" - (parser - [: `("", x) - when - x <> "->" && String.length x >= 2 && List.mem x.[0] list && - symbolchar x 1 :] -> - x) -; - -value infixop3 = - let list = ['*'; '/'; '%'] in - Grammar.Entry.of_parser gram "infixop3" - (parser - [: `("", x) - when - String.length x >= 2 && List.mem x.[0] list && - symbolchar x 1 :] -> - x) -; - -value infixop4 = - Grammar.Entry.of_parser gram "infixop4" - (parser - [: `("", x) - when - String.length x >= 3 && x.[0] == '*' && x.[1] == '*' && - symbolchar x 2 :] -> - x) -; - -value test_constr_decl = - Grammar.Entry.of_parser gram "test_constr_decl" - (fun strm -> - match Stream.npeek 1 strm with - [ [("UIDENT", _)] -> - match Stream.npeek 2 strm with - [ [_; ("", ".")] -> raise Stream.Failure - | [_; ("", "(")] -> raise Stream.Failure - | [_ :: _] -> () - | _ -> raise Stream.Failure ] - | [("", "|")] -> () - | _ -> raise Stream.Failure ]) -; - -value stream_peek_nth n strm = - loop n (Stream.npeek n strm) where rec loop n = - fun - [ [] -> None - | [x] -> if n == 1 then Some x else None - | [_ :: l] -> loop (n - 1) l ] -; - -(* horrible hack to be able to parse class_types *) - -value test_ctyp_minusgreater = - Grammar.Entry.of_parser gram "test_ctyp_minusgreater" - (fun strm -> - let rec skip_simple_ctyp n = - match stream_peek_nth n strm with - [ Some ("", "->") -> n - | Some ("", "[" | "[<") -> - skip_simple_ctyp (ignore_upto "]" (n + 1) + 1) - | Some ("", "(") -> skip_simple_ctyp (ignore_upto ")" (n + 1) + 1) - | Some - ("", - "as" | "'" | ":" | "*" | "." | "#" | "<" | ">" | ".." | ";" | - "_") -> - skip_simple_ctyp (n + 1) - | Some ("QUESTIONIDENT" | "LIDENT" | "UIDENT", _) -> - skip_simple_ctyp (n + 1) - | Some _ | None -> raise Stream.Failure ] - and ignore_upto end_kwd n = - match stream_peek_nth n strm with - [ Some ("", prm) when prm = end_kwd -> n - | Some ("", "[" | "[<") -> - ignore_upto end_kwd (ignore_upto "]" (n + 1) + 1) - | Some ("", "(") -> ignore_upto end_kwd (ignore_upto ")" (n + 1) + 1) - | Some _ -> ignore_upto end_kwd (n + 1) - | None -> raise Stream.Failure ] - in - match Stream.peek strm with - [ Some (("", "[") | ("LIDENT" | "UIDENT", _)) -> skip_simple_ctyp 1 - | Some ("", "object") -> raise Stream.Failure - | _ -> 1 ]) -; - -value test_label_eq = - Grammar.Entry.of_parser gram "test_label_eq" - (test 1 where rec test lev strm = - match stream_peek_nth lev strm with - [ Some (("UIDENT", _) | ("LIDENT", _) | ("", ".")) -> - test (lev + 1) strm - | Some ("", "=") -> () - | _ -> raise Stream.Failure ]) -; - -value test_typevar_list_dot = - Grammar.Entry.of_parser gram "test_typevar_list_dot" - (let rec test lev strm = - match stream_peek_nth lev strm with - [ Some ("", "'") -> test2 (lev + 1) strm - | Some ("", ".") -> () - | _ -> raise Stream.Failure ] - and test2 lev strm = - match stream_peek_nth lev strm with - [ Some ("UIDENT" | "LIDENT", _) -> test (lev + 1) strm - | _ -> raise Stream.Failure ] - in - test 1) -; - -value constr_arity = ref [("Some", 1); ("Match_Failure", 1)]; - -value rec is_expr_constr_call = - fun - [ <:expr< $uid:_$ >> -> True - | <:expr< $uid:_$.$e$ >> -> is_expr_constr_call e - | <:expr< $e$ $_$ >> -> is_expr_constr_call e - | _ -> False ] -; - -value rec constr_expr_arity loc = - fun - [ <:expr< $uid:c$ >> -> - try List.assoc c constr_arity.val with [ Not_found -> 0 ] - | <:expr< $uid:_$.$e$ >> -> constr_expr_arity loc e - | <:expr< $e$ $_$ >> -> - if is_expr_constr_call e then - Stdpp.raise_with_loc loc (Stream.Error "currified constructor") - else 1 - | _ -> 1 ] -; - -value rec is_patt_constr_call = - fun - [ <:patt< $uid:_$ >> -> True - | <:patt< $uid:_$.$p$ >> -> is_patt_constr_call p - | <:patt< $p$ $_$ >> -> is_patt_constr_call p - | _ -> False ] -; - -value rec constr_patt_arity loc = - fun - [ <:patt< $uid:c$ >> -> - try List.assoc c constr_arity.val with [ Not_found -> 0 ] - | <:patt< $uid:_$.$p$ >> -> constr_patt_arity loc p - | <:patt< $p$ $_$ >> -> - if is_patt_constr_call p then - Stdpp.raise_with_loc loc (Stream.Error "currified constructor") - else 1 - | _ -> 1 ] -; - -value get_seq = - fun - [ <:expr< do { $list:el$ } >> -> el - | e -> [e] ] -; - -value choose_tvar tpl = - let rec find_alpha v = - let s = String.make 1 v in - if List.mem_assoc s tpl then - if v = 'z' then None else find_alpha (Char.chr (Char.code v + 1)) - else Some (String.make 1 v) - in - let rec make_n n = - let v = "a" ^ string_of_int n in - if List.mem_assoc v tpl then make_n (succ n) else v - in - match find_alpha 'a' with - [ Some x -> x - | None -> make_n 1 ] -; - -value rec patt_lid = - fun - [ <:patt< $p1$ $p2$ >> -> - match p1 with - [ <:patt< $lid:i$ >> -> Some (MLast.loc_of_patt p1, i, [p2]) - | _ -> - match patt_lid p1 with - [ Some (loc, i, pl) -> Some (loc, i, [p2 :: pl]) - | None -> None ] ] - | _ -> None ] -; - -value bigarray_get loc arr arg = - let coords = - match arg with - [ <:expr< ($list:el$) >> -> el - | _ -> [arg] ] - in - match coords with - [ [c1] -> <:expr< Bigarray.Array1.get $arr$ $c1$ >> - | [c1; c2] -> <:expr< Bigarray.Array2.get $arr$ $c1$ $c2$ >> - | [c1; c2; c3] -> <:expr< Bigarray.Array3.get $arr$ $c1$ $c2$ $c3$ >> - | coords -> <:expr< Bigarray.Genarray.get $arr$ [| $list:coords$ |] >> ] -; - -value bigarray_set loc var newval = - match var with - [ <:expr< Bigarray.Array1.get $arr$ $c1$ >> -> - Some <:expr< Bigarray.Array1.set $arr$ $c1$ $newval$ >> - | <:expr< Bigarray.Array2.get $arr$ $c1$ $c2$ >> -> - Some <:expr< Bigarray.Array2.set $arr$ $c1$ $c2$ $newval$ >> - | <:expr< Bigarray.Array3.get $arr$ $c1$ $c2$ $c3$ >> -> - Some <:expr< Bigarray.Array3.set $arr$ $c1$ $c2$ $c3$ $newval$ >> - | <:expr< Bigarray.Genarray.get $arr$ [| $list:coords$ |] >> -> - Some <:expr< Bigarray.Genarray.set $arr$ [| $list:coords$ |] $newval$ >> - | _ -> None ] -; - -(* ...works bad... -value rec sync cs = - match cs with parser - [ [: `';' :] -> sync_semi cs - | [: `_ :] -> sync cs ] -and sync_semi cs = - match cs with parser - [ [: `';' :] -> sync_semisemi cs - | [: :] -> sync cs ] -and sync_semisemi cs = - match Stream.peek cs with - [ Some ('\010' | '\013') -> () - | _ -> sync_semi cs ] -; -Pcaml.sync.val := sync; -*) - -EXTEND - GLOBAL: sig_item str_item ctyp patt expr module_type module_expr class_type - class_expr class_sig_item class_str_item let_binding type_declaration; - module_expr: - [ [ "functor"; "("; i = UIDENT; ":"; t = module_type; ")"; "->"; - me = SELF -> - <:module_expr< functor ( $i$ : $t$ ) -> $me$ >> - | "struct"; st = LIST0 [ s = str_item; OPT ";;" -> s ]; "end" -> - <:module_expr< struct $list:st$ end >> ] - | [ me1 = SELF; me2 = SELF -> <:module_expr< $me1$ $me2$ >> ] - | [ i = mod_expr_ident -> i - | "("; me = SELF; ":"; mt = module_type; ")" -> - <:module_expr< ( $me$ : $mt$ ) >> - | "("; me = SELF; ")" -> <:module_expr< $me$ >> ] ] - ; - mod_expr_ident: - [ LEFTA - [ i = SELF; "."; j = SELF -> <:module_expr< $i$ . $j$ >> ] - | [ i = UIDENT -> <:module_expr< $uid:i$ >> ] ] - ; - str_item: - [ "top" - [ "exception"; (_, c, tl) = constructor_declaration; b = rebind_exn -> - <:str_item< exception $c$ of $list:tl$ = $b$ >> - | "external"; i = LIDENT; ":"; t = ctyp; "="; pd = LIST1 STRING -> - <:str_item< external $i$ : $t$ = $list:pd$ >> - | "external"; "("; i = operator_rparen; ":"; t = ctyp; "="; - pd = LIST1 STRING -> - <:str_item< external $i$ : $t$ = $list:pd$ >> - | "include"; me = module_expr -> <:str_item< include $me$ >> - | "module"; i = UIDENT; mb = module_binding -> - <:str_item< module $i$ = $mb$ >> - | "module"; "rec"; nmtmes = LIST1 module_rec_binding SEP "and" -> - MLast.StRecMod loc nmtmes - | "module"; "type"; i = UIDENT; "="; mt = module_type -> - <:str_item< module type $i$ = $mt$ >> - | "open"; i = mod_ident -> <:str_item< open $i$ >> - | "type"; tdl = LIST1 type_declaration SEP "and" -> - <:str_item< type $list:tdl$ >> - | "let"; r = OPT "rec"; l = LIST1 let_binding SEP "and"; "in"; - x = expr -> - let e = <:expr< let $opt:o2b r$ $list:l$ in $x$ >> in - <:str_item< $exp:e$ >> - | "let"; r = OPT "rec"; l = LIST1 let_binding SEP "and" -> - match l with - [ [(<:patt< _ >>, e)] -> <:str_item< $exp:e$ >> - | _ -> <:str_item< value $opt:o2b r$ $list:l$ >> ] - | "let"; "module"; m = UIDENT; mb = module_binding; "in"; e = expr -> - <:str_item< let module $m$ = $mb$ in $e$ >> - | e = expr -> <:str_item< $exp:e$ >> ] ] - ; - rebind_exn: - [ [ "="; sl = mod_ident -> sl - | -> [] ] ] - ; - module_binding: - [ RIGHTA - [ "("; m = UIDENT; ":"; mt = module_type; ")"; mb = SELF -> - <:module_expr< functor ( $m$ : $mt$ ) -> $mb$ >> - | ":"; mt = module_type; "="; me = module_expr -> - <:module_expr< ( $me$ : $mt$ ) >> - | "="; me = module_expr -> <:module_expr< $me$ >> ] ] - ; - module_rec_binding: - [ [ m = UIDENT; ":"; mt = module_type; "="; me = module_expr -> - (m, mt, me) ] ] - ; - (* Module types *) - module_type: - [ [ "functor"; "("; i = UIDENT; ":"; t = SELF; ")"; "->"; mt = SELF -> - <:module_type< functor ( $i$ : $t$ ) -> $mt$ >> ] - | [ mt = SELF; "with"; wcl = LIST1 with_constr SEP "and" -> - <:module_type< $mt$ with $list:wcl$ >> ] - | [ "sig"; sg = LIST0 [ s = sig_item; OPT ";;" -> s ]; "end" -> - <:module_type< sig $list:sg$ end >> - | i = mod_type_ident -> i - | "("; mt = SELF; ")" -> <:module_type< $mt$ >> ] ] - ; - mod_type_ident: - [ LEFTA - [ m1 = SELF; "."; m2 = SELF -> <:module_type< $m1$ . $m2$ >> - | m1 = SELF; "("; m2 = SELF; ")" -> <:module_type< $m1$ $m2$ >> ] - | [ m = UIDENT -> <:module_type< $uid:m$ >> - | m = LIDENT -> <:module_type< $lid:m$ >> ] ] - ; - sig_item: - [ "top" - [ "exception"; (_, c, tl) = constructor_declaration -> - <:sig_item< exception $c$ of $list:tl$ >> - | "external"; i = LIDENT; ":"; t = ctyp; "="; pd = LIST1 STRING -> - <:sig_item< external $i$ : $t$ = $list:pd$ >> - | "external"; "("; i = operator_rparen; ":"; t = ctyp; "="; - pd = LIST1 STRING -> - <:sig_item< external $i$ : $t$ = $list:pd$ >> - | "include"; mt = module_type -> <:sig_item< include $mt$ >> - | "module"; i = UIDENT; mt = module_declaration -> - <:sig_item< module $i$ : $mt$ >> - | "module"; "rec"; mds = LIST1 module_rec_declaration SEP "and" -> - MLast.SgRecMod loc mds - | "module"; "type"; i = UIDENT; "="; mt = module_type -> - <:sig_item< module type $i$ = $mt$ >> - | "module"; "type"; i = UIDENT -> - <:sig_item< module type $i$ = 'abstract >> - | "open"; i = mod_ident -> <:sig_item< open $i$ >> - | "type"; tdl = LIST1 type_declaration SEP "and" -> - <:sig_item< type $list:tdl$ >> - | "val"; i = LIDENT; ":"; t = ctyp -> <:sig_item< value $i$ : $t$ >> - | "val"; "("; i = operator_rparen; ":"; t = ctyp -> - <:sig_item< value $i$ : $t$ >> ] ] - ; - module_declaration: - [ RIGHTA - [ ":"; mt = module_type -> <:module_type< $mt$ >> - | "("; i = UIDENT; ":"; t = module_type; ")"; mt = SELF -> - <:module_type< functor ( $i$ : $t$ ) -> $mt$ >> ] ] - ; - module_rec_declaration: - [ [ m = UIDENT; ":"; mt = module_type -> (m, mt)] ] - ; - (* "with" constraints (additional type equations over signature - components) *) - with_constr: - [ [ "type"; tpl = type_parameters; i = mod_ident; "="; t = ctyp -> - MLast.WcTyp loc i tpl t - | "module"; i = mod_ident; "="; me = module_expr -> - MLast.WcMod loc i me ] ] - ; - (* Core expressions *) - expr: - [ "top" RIGHTA - [ e1 = SELF; ";"; e2 = SELF -> - <:expr< do { $list:[e1 :: get_seq e2]$ } >> - | e1 = SELF; ";" -> e1 ] - | "expr1" - [ "let"; o = OPT "rec"; l = LIST1 let_binding SEP "and"; "in"; - x = expr LEVEL "top" -> - <:expr< let $opt:o2b o$ $list:l$ in $x$ >> - | "let"; "module"; m = UIDENT; mb = module_binding; "in"; - e = expr LEVEL "top" -> - <:expr< let module $m$ = $mb$ in $e$ >> - | "function"; OPT "|"; l = LIST1 match_case SEP "|" -> - <:expr< fun [ $list:l$ ] >> - | "fun"; p = patt LEVEL "simple"; e = fun_def -> - <:expr< fun [$p$ -> $e$] >> - | "match"; e = SELF; "with"; OPT "|"; l = LIST1 match_case SEP "|" -> - <:expr< match $e$ with [ $list:l$ ] >> - | "try"; e = SELF; "with"; OPT "|"; l = LIST1 match_case SEP "|" -> - <:expr< try $e$ with [ $list:l$ ] >> - | "if"; e1 = SELF; "then"; e2 = expr LEVEL "expr1"; - "else"; e3 = expr LEVEL "expr1" -> - <:expr< if $e1$ then $e2$ else $e3$ >> - | "if"; e1 = SELF; "then"; e2 = expr LEVEL "expr1" -> - <:expr< if $e1$ then $e2$ else () >> - | "for"; i = LIDENT; "="; e1 = SELF; df = direction_flag; e2 = SELF; - "do"; e = SELF; "done" -> - <:expr< for $i$ = $e1$ $to:df$ $e2$ do { $list:get_seq e$ } >> - | "while"; e1 = SELF; "do"; e2 = SELF; "done" -> - <:expr< while $e1$ do { $list:get_seq e2$ } >> ] - | [ e = SELF; ","; el = LIST1 NEXT SEP "," -> - <:expr< ( $list:[e :: el]$ ) >> ] - | ":=" NONA - [ e1 = SELF; ":="; e2 = expr LEVEL "expr1" -> - <:expr< $e1$.val := $e2$ >> - | e1 = SELF; "<-"; e2 = expr LEVEL "expr1" -> - match bigarray_set loc e1 e2 with - [ Some e -> e - | None -> <:expr< $e1$ := $e2$ >> ] ] - | "||" RIGHTA - [ e1 = SELF; "or"; e2 = SELF -> <:expr< $lid:"or"$ $e1$ $e2$ >> - | e1 = SELF; "||"; e2 = SELF -> <:expr< $e1$ || $e2$ >> ] - | "&&" RIGHTA - [ e1 = SELF; "&"; e2 = SELF -> <:expr< $lid:"&"$ $e1$ $e2$ >> - | e1 = SELF; "&&"; e2 = SELF -> <:expr< $e1$ && $e2$ >> ] - | "<" LEFTA - [ e1 = SELF; "<"; e2 = SELF -> <:expr< $e1$ < $e2$ >> - | e1 = SELF; ">"; e2 = SELF -> <:expr< $e1$ > $e2$ >> - | e1 = SELF; "<="; e2 = SELF -> <:expr< $e1$ <= $e2$ >> - | e1 = SELF; ">="; e2 = SELF -> <:expr< $e1$ >= $e2$ >> - | e1 = SELF; "="; e2 = SELF -> <:expr< $e1$ = $e2$ >> - | e1 = SELF; "<>"; e2 = SELF -> <:expr< $e1$ <> $e2$ >> - | e1 = SELF; "=="; e2 = SELF -> <:expr< $e1$ == $e2$ >> - | e1 = SELF; "!="; e2 = SELF -> <:expr< $e1$ != $e2$ >> - | e1 = SELF; "$"; e2 = SELF -> <:expr< $lid:"\$"$ $e1$ $e2$ >> - | e1 = SELF; op = infixop0; e2 = SELF -> <:expr< $lid:op$ $e1$ $e2$ >> ] - | "^" RIGHTA - [ e1 = SELF; "^"; e2 = SELF -> <:expr< $e1$ ^ $e2$ >> - | e1 = SELF; "@"; e2 = SELF -> <:expr< $e1$ @ $e2$ >> - | e1 = SELF; op = infixop1; e2 = SELF -> <:expr< $lid:op$ $e1$ $e2$ >> ] - | RIGHTA - [ e1 = SELF; "::"; e2 = SELF -> <:expr< [$e1$ :: $e2$] >> ] - | "+" LEFTA - [ e1 = SELF; "+"; e2 = SELF -> <:expr< $e1$ + $e2$ >> - | e1 = SELF; "-"; e2 = SELF -> <:expr< $e1$ - $e2$ >> - | e1 = SELF; op = infixop2; e2 = SELF -> <:expr< $lid:op$ $e1$ $e2$ >> ] - | "*" LEFTA - [ e1 = SELF; "*"; e2 = SELF -> <:expr< $e1$ * $e2$ >> - | e1 = SELF; "/"; e2 = SELF -> <:expr< $e1$ / $e2$ >> - | e1 = SELF; "%"; e2 = SELF -> <:expr< $lid:"%"$ $e1$ $e2$ >> - | e1 = SELF; "land"; e2 = SELF -> <:expr< $e1$ land $e2$ >> - | e1 = SELF; "lor"; e2 = SELF -> <:expr< $e1$ lor $e2$ >> - | e1 = SELF; "lxor"; e2 = SELF -> <:expr< $e1$ lxor $e2$ >> - | e1 = SELF; "mod"; e2 = SELF -> <:expr< $e1$ mod $e2$ >> - | e1 = SELF; op = infixop3; e2 = SELF -> <:expr< $lid:op$ $e1$ $e2$ >> ] - | "**" RIGHTA - [ e1 = SELF; "**"; e2 = SELF -> <:expr< $e1$ ** $e2$ >> - | e1 = SELF; "asr"; e2 = SELF -> <:expr< $e1$ asr $e2$ >> - | e1 = SELF; "lsl"; e2 = SELF -> <:expr< $e1$ lsl $e2$ >> - | e1 = SELF; "lsr"; e2 = SELF -> <:expr< $e1$ lsr $e2$ >> - | e1 = SELF; op = infixop4; e2 = SELF -> <:expr< $lid:op$ $e1$ $e2$ >> ] - | "unary minus" NONA - [ "-"; e = SELF -> <:expr< $mkumin loc "-" e$ >> - | "-."; e = SELF -> <:expr< $mkumin loc "-." e$ >> ] - | "apply" LEFTA - [ e1 = SELF; e2 = SELF -> - match constr_expr_arity loc e1 with - [ 1 -> <:expr< $e1$ $e2$ >> - | _ -> - match e2 with - [ <:expr< ( $list:el$ ) >> -> - List.fold_left (fun e1 e2 -> <:expr< $e1$ $e2$ >>) e1 el - | _ -> <:expr< $e1$ $e2$ >> ] ] - | "assert"; e = SELF -> - match e with - [ <:expr< False >> -> <:expr< assert False >> - | _ -> <:expr< assert ($e$) >> ] - | "lazy"; e = SELF -> - <:expr< lazy ($e$) >> ] - | "." LEFTA - [ e1 = SELF; "."; "("; e2 = SELF; ")" -> <:expr< $e1$ .( $e2$ ) >> - | e1 = SELF; "."; "["; e2 = SELF; "]" -> <:expr< $e1$ .[ $e2$ ] >> - | e1 = SELF; "."; "{"; e2 = SELF; "}" -> bigarray_get loc e1 e2 - | e1 = SELF; "."; e2 = SELF -> <:expr< $e1$ . $e2$ >> ] - | "~-" NONA - [ "!"; e = SELF -> <:expr< $e$ . val>> - | "~-"; e = SELF -> <:expr< ~- $e$ >> - | "~-."; e = SELF -> <:expr< ~-. $e$ >> - | f = prefixop; e = SELF -> <:expr< $lid:f$ $e$ >> ] - | "simple" LEFTA - [ s = INT -> <:expr< $int:s$ >> - | s = INT32 -> MLast.ExInt32 loc s - | s = INT64 -> MLast.ExInt64 loc s - | s = NATIVEINT -> MLast.ExNativeInt loc s - | s = FLOAT -> <:expr< $flo:s$ >> - | s = STRING -> <:expr< $str:s$ >> - | c = CHAR -> <:expr< $chr:c$ >> - | UIDENT "True" -> <:expr< $uid:" True"$ >> - | UIDENT "False" -> <:expr< $uid:" False"$ >> - | i = expr_ident -> i - | s = "false" -> <:expr< False >> - | s = "true" -> <:expr< True >> - | "["; "]" -> <:expr< [] >> - | "["; el = expr1_semi_list; "]" -> <:expr< $mklistexp loc None el$ >> - | "[|"; "|]" -> <:expr< [| |] >> - | "[|"; el = expr1_semi_list; "|]" -> <:expr< [| $list:el$ |] >> - | "{"; test_label_eq; lel = lbl_expr_list; "}" -> - <:expr< { $list:lel$ } >> - | "{"; e = expr LEVEL "."; "with"; lel = lbl_expr_list; "}" -> - <:expr< { ($e$) with $list:lel$ } >> - | "("; ")" -> <:expr< () >> - | "("; op = operator_rparen -> <:expr< $lid:op$ >> - | "("; e = SELF; ":"; t = ctyp; ")" -> <:expr< ($e$ : $t$) >> - | "("; e = SELF; ")" -> <:expr< $e$ >> - | "begin"; e = SELF; "end" -> <:expr< $e$ >> - | "begin"; "end" -> <:expr< () >> - | x = LOCATE -> - let x = - try - let i = String.index x ':' in - (int_of_string (String.sub x 0 i), - String.sub x (i + 1) (String.length x - i - 1)) - with - [ Not_found | Failure _ -> (0, x) ] - in - Pcaml.handle_expr_locate loc x - | x = QUOTATION -> - let x = - try - let i = String.index x ':' in - (String.sub x 0 i, - String.sub x (i + 1) (String.length x - i - 1)) - with - [ Not_found -> ("", x) ] - in - Pcaml.handle_expr_quotation loc x ] ] - ; - let_binding: - [ [ p = patt; e = fun_binding -> - match patt_lid p with - [ Some (loc, i, pl) -> - let e = - List.fold_left (fun e p -> <:expr< fun $p$ -> $e$ >>) e pl - in - (<:patt< $lid:i$ >>, e) - | None -> (p, e) ] ] ] - ; - fun_binding: - [ RIGHTA - [ p = patt LEVEL "simple"; e = SELF -> <:expr< fun $p$ -> $e$ >> - | "="; e = expr -> <:expr< $e$ >> - | ":"; t = ctyp; "="; e = expr -> <:expr< ($e$ : $t$) >> ] ] - ; - match_case: - [ [ x1 = patt; w = OPT [ "when"; e = expr -> e ]; "->"; x2 = expr -> - (x1, w, x2) ] ] - ; - lbl_expr_list: - [ [ le = lbl_expr; ";"; lel = SELF -> [le :: lel] - | le = lbl_expr; ";" -> [le] - | le = lbl_expr -> [le] ] ] - ; - lbl_expr: - [ [ i = patt_label_ident; "="; e = expr LEVEL "expr1" -> (i, e) ] ] - ; - expr1_semi_list: - [ [ e = expr LEVEL "expr1"; ";"; el = SELF -> [e :: el] - | e = expr LEVEL "expr1"; ";" -> [e] - | e = expr LEVEL "expr1" -> [e] ] ] - ; - fun_def: - [ RIGHTA - [ p = patt LEVEL "simple"; e = SELF -> <:expr< fun $p$ -> $e$ >> - | "->"; e = expr -> <:expr< $e$ >> ] ] - ; - expr_ident: - [ RIGHTA - [ i = LIDENT -> <:expr< $lid:i$ >> - | i = UIDENT -> <:expr< $uid:i$ >> - | i = UIDENT; "."; j = SELF -> - let rec loop m = - fun - [ <:expr< $x$ . $y$ >> -> loop <:expr< $m$ . $x$ >> y - | e -> <:expr< $m$ . $e$ >> ] - in - loop <:expr< $uid:i$ >> j - | i = UIDENT; "."; "("; j = operator_rparen -> - <:expr< $uid:i$ . $lid:j$ >> ] ] - ; - (* Patterns *) - patt: - [ LEFTA - [ p1 = SELF; "as"; i = LIDENT -> <:patt< ($p1$ as $lid:i$) >> ] - | LEFTA - [ p1 = SELF; "|"; p2 = SELF -> <:patt< $p1$ | $p2$ >> ] - | [ p = SELF; ","; pl = LIST1 NEXT SEP "," -> - <:patt< ( $list:[p :: pl]$) >> ] - | NONA - [ p1 = SELF; ".."; p2 = SELF -> <:patt< $p1$ .. $p2$ >> ] - | RIGHTA - [ p1 = SELF; "::"; p2 = SELF -> <:patt< [$p1$ :: $p2$] >> ] - | LEFTA - [ p1 = SELF; p2 = SELF -> - match constr_patt_arity loc p1 with - [ 1 -> <:patt< $p1$ $p2$ >> - | n -> - let p2 = - match p2 with - [ <:patt< _ >> when n > 1 -> - let pl = - loop n where rec loop n = - if n = 0 then [] else [<:patt< _ >> :: loop (n - 1)] - in - <:patt< ( $list:pl$ ) >> - | _ -> p2 ] - in - match p2 with - [ <:patt< ( $list:pl$ ) >> -> - List.fold_left (fun p1 p2 -> <:patt< $p1$ $p2$ >>) p1 pl - | _ -> <:patt< $p1$ $p2$ >> ] ] ] - | LEFTA - [ p1 = SELF; "."; p2 = SELF -> <:patt< $p1$ . $p2$ >> ] - | "simple" - [ s = LIDENT -> <:patt< $lid:s$ >> - | s = UIDENT -> <:patt< $uid:s$ >> - | s = INT -> <:patt< $int:s$ >> - | s = INT32 -> MLast.PaInt32 loc s - | s = INT64 -> MLast.PaInt64 loc s - | s = NATIVEINT -> MLast.PaNativeInt loc s - | "-"; s = INT -> <:patt< $int:"-" ^ s$ >> - | "-"; s = INT32 -> MLast.PaInt32 loc ("-" ^ s) - | "-"; s = INT64 -> MLast.PaInt64 loc ("-" ^ s) - | "-"; s = NATIVEINT -> MLast.PaNativeInt loc ("-" ^ s) - | "-"; s = FLOAT -> <:patt< $flo:"-" ^ s$ >> - | s = FLOAT -> <:patt< $flo:s$ >> - | s = STRING -> <:patt< $str:s$ >> - | s = CHAR -> <:patt< $chr:s$ >> - | UIDENT "True" -> <:patt< $uid:" True"$ >> - | UIDENT "False" -> <:patt< $uid:" False"$ >> - | s = "false" -> <:patt< False >> - | s = "true" -> <:patt< True >> - | "["; "]" -> <:patt< [] >> - | "["; pl = patt_semi_list; "]" -> <:patt< $mklistpat loc None pl$ >> - | "[|"; "|]" -> <:patt< [| |] >> - | "[|"; pl = patt_semi_list; "|]" -> <:patt< [| $list:pl$ |] >> - | "{"; lpl = lbl_patt_list; "}" -> <:patt< { $list:lpl$ } >> - | "("; ")" -> <:patt< () >> - | "("; op = operator_rparen -> <:patt< $lid:op$ >> - | "("; p = SELF; ":"; t = ctyp; ")" -> <:patt< ($p$ : $t$) >> - | "("; p = SELF; ")" -> <:patt< $p$ >> - | "_" -> <:patt< _ >> - | x = LOCATE -> - let x = - try - let i = String.index x ':' in - (int_of_string (String.sub x 0 i), - String.sub x (i + 1) (String.length x - i - 1)) - with - [ Not_found | Failure _ -> (0, x) ] - in - Pcaml.handle_patt_locate loc x - | x = QUOTATION -> - let x = - try - let i = String.index x ':' in - (String.sub x 0 i, - String.sub x (i + 1) (String.length x - i - 1)) - with - [ Not_found -> ("", x) ] - in - Pcaml.handle_patt_quotation loc x ] ] - ; - patt_semi_list: - [ [ p = patt; ";"; pl = SELF -> [p :: pl] - | p = patt; ";" -> [p] - | p = patt -> [p] ] ] - ; - lbl_patt_list: - [ [ le = lbl_patt; ";"; lel = SELF -> [le :: lel] - | le = lbl_patt; ";" -> [le] - | le = lbl_patt -> [le] ] ] - ; - lbl_patt: - [ [ i = patt_label_ident; "="; p = patt -> (i, p) ] ] - ; - patt_label_ident: - [ LEFTA - [ p1 = SELF; "."; p2 = SELF -> <:patt< $p1$ . $p2$ >> ] - | RIGHTA - [ i = UIDENT -> <:patt< $uid:i$ >> - | i = LIDENT -> <:patt< $lid:i$ >> ] ] - ; - (* Type declaration *) - type_declaration: - [ [ tpl = type_parameters; n = type_patt; "="; tk = type_kind; - cl = LIST0 constrain -> - (n, tpl, tk, cl) - | tpl = type_parameters; n = type_patt; cl = LIST0 constrain -> - (n, tpl, <:ctyp< '$choose_tvar tpl$ >>, cl) ] ] - ; - type_patt: - [ [ n = LIDENT -> (loc, n) ] ] - ; - constrain: - [ [ "constraint"; t1 = ctyp; "="; t2 = ctyp -> (t1, t2) ] ] - ; - type_kind: - [ [ "private"; "{"; ldl = label_declarations; "}" -> - <:ctyp< private { $list:ldl$ } >> - | "private"; OPT "|"; - cdl = LIST1 constructor_declaration SEP "|" -> <:ctyp< private [ $list:cdl$ ] >> - | test_constr_decl; OPT "|"; - cdl = LIST1 constructor_declaration SEP "|" -> <:ctyp< [ $list:cdl$ ] >> - | t = ctyp -> <:ctyp< $t$ >> - | t = ctyp; "="; "private"; "{"; ldl = label_declarations; "}" -> - <:ctyp< $t$ == private { $list:ldl$ } >> - | t = ctyp; "="; "{"; ldl = label_declarations; "}" -> - <:ctyp< $t$ == { $list:ldl$ } >> - | t = ctyp; "="; "private"; OPT "|"; cdl = LIST1 constructor_declaration SEP "|" -> - <:ctyp< $t$ == private [ $list:cdl$ ] >> - | t = ctyp; "="; OPT "|"; cdl = LIST1 constructor_declaration SEP "|" -> - <:ctyp< $t$ == [ $list:cdl$ ] >> - | "{"; ldl = label_declarations; "}" -> - <:ctyp< { $list:ldl$ } >> ] ] - ; - type_parameters: - [ [ -> (* empty *) [] - | tp = type_parameter -> [tp] - | "("; tpl = LIST1 type_parameter SEP ","; ")" -> tpl ] ] - ; - type_parameter: - [ [ "'"; i = ident -> (i, (False, False)) - | "+"; "'"; i = ident -> (i, (True, False)) - | "-"; "'"; i = ident -> (i, (False, True)) ] ] - ; - constructor_declaration: - [ [ ci = UIDENT; "of"; cal = LIST1 ctyp LEVEL "ctyp1" SEP "*" -> - (loc, ci, cal) - | ci = UIDENT -> (loc, ci, []) ] ] - ; - label_declarations: - [ [ ld = label_declaration; ";"; ldl = SELF -> [ld :: ldl] - | ld = label_declaration; ";" -> [ld] - | ld = label_declaration -> [ld] ] ] - ; - label_declaration: - [ [ i = LIDENT; ":"; t = poly_type -> (loc, i, False, t) - | "mutable"; i = LIDENT; ":"; t = poly_type -> (loc, i, True, t) ] ] - ; - (* Core types *) - ctyp: - [ [ t1 = SELF; "as"; "'"; i = ident -> <:ctyp< $t1$ as '$i$ >> ] - | "arrow" RIGHTA - [ t1 = SELF; "->"; t2 = SELF -> <:ctyp< $t1$ -> $t2$ >> ] - | "star" - [ t = SELF; "*"; tl = LIST1 (ctyp LEVEL "ctyp1") SEP "*" -> - <:ctyp< ( $list:[t :: tl]$ ) >> ] - | "ctyp1" - [ t1 = SELF; t2 = SELF -> <:ctyp< $t2$ $t1$ >> ] - | "ctyp2" - [ t1 = SELF; "."; t2 = SELF -> <:ctyp< $t1$ . $t2$ >> - | t1 = SELF; "("; t2 = SELF; ")" -> <:ctyp< $t1$ $t2$ >> ] - | "simple" - [ "'"; i = ident -> <:ctyp< '$i$ >> - | "_" -> <:ctyp< _ >> - | i = LIDENT -> <:ctyp< $lid:i$ >> - | i = UIDENT -> <:ctyp< $uid:i$ >> - | "("; t = SELF; ","; tl = LIST1 ctyp SEP ","; ")"; - i = ctyp LEVEL "ctyp2" -> - List.fold_left (fun c a -> <:ctyp< $c$ $a$ >>) i [t :: tl] - | "("; t = SELF; ")" -> <:ctyp< $t$ >> ] ] - ; - (* Identifiers *) - ident: - [ [ i = LIDENT -> i - | i = UIDENT -> i ] ] - ; - mod_ident: - [ RIGHTA - [ i = UIDENT -> [i] - | i = LIDENT -> [i] - | i = UIDENT; "."; j = SELF -> [i :: j] ] ] - ; - (* Miscellaneous *) - direction_flag: - [ [ "to" -> True - | "downto" -> False ] ] - ; - (* Objects and Classes *) - str_item: - [ [ "class"; cd = LIST1 class_declaration SEP "and" -> - <:str_item< class $list:cd$ >> - | "class"; "type"; ctd = LIST1 class_type_declaration SEP "and" -> - <:str_item< class type $list:ctd$ >> ] ] - ; - sig_item: - [ [ "class"; cd = LIST1 class_description SEP "and" -> - <:sig_item< class $list:cd$ >> - | "class"; "type"; ctd = LIST1 class_type_declaration SEP "and" -> - <:sig_item< class type $list:ctd$ >> ] ] - ; - (* Class expressions *) - class_declaration: - [ [ vf = OPT "virtual"; ctp = class_type_parameters; i = LIDENT; - cfb = class_fun_binding -> - {MLast.ciLoc = loc; MLast.ciVir = o2b vf; MLast.ciPrm = ctp; - MLast.ciNam = i; MLast.ciExp = cfb} ] ] - ; - class_fun_binding: - [ [ "="; ce = class_expr -> ce - | ":"; ct = class_type; "="; ce = class_expr -> - <:class_expr< ($ce$ : $ct$) >> - | p = patt LEVEL "simple"; cfb = SELF -> - <:class_expr< fun $p$ -> $cfb$ >> ] ] - ; - class_type_parameters: - [ [ -> (loc, []) - | "["; tpl = LIST1 type_parameter SEP ","; "]" -> (loc, tpl) ] ] - ; - class_fun_def: - [ [ p = patt LEVEL "simple"; "->"; ce = class_expr -> - <:class_expr< fun $p$ -> $ce$ >> - | p = labeled_patt; "->"; ce = class_expr -> - <:class_expr< fun $p$ -> $ce$ >> - | p = patt LEVEL "simple"; cfd = SELF -> - <:class_expr< fun $p$ -> $cfd$ >> - | p = labeled_patt; cfd = SELF -> - <:class_expr< fun $p$ -> $cfd$ >> ] ] - ; - class_expr: - [ "top" - [ "fun"; cfd = class_fun_def -> cfd - | "let"; rf = OPT "rec"; lb = LIST1 let_binding SEP "and"; "in"; - ce = SELF -> - <:class_expr< let $opt:o2b rf$ $list:lb$ in $ce$ >> ] - | "apply" LEFTA - [ ce = SELF; e = expr LEVEL "label" -> - <:class_expr< $ce$ $e$ >> ] - | "simple" - [ "["; ct = ctyp; ","; ctcl = LIST1 ctyp SEP ","; "]"; - ci = class_longident -> - <:class_expr< $list:ci$ [ $list:[ct :: ctcl]$ ] >> - | "["; ct = ctyp; "]"; ci = class_longident -> - <:class_expr< $list:ci$ [ $ct$ ] >> - | ci = class_longident -> <:class_expr< $list:ci$ >> - | "object"; cspo = OPT class_self_patt; cf = class_structure; "end" -> - <:class_expr< object $opt:cspo$ $list:cf$ end >> - | "("; ce = SELF; ":"; ct = class_type; ")" -> - <:class_expr< ($ce$ : $ct$) >> - | "("; ce = SELF; ")" -> ce ] ] - ; - class_structure: - [ [ cf = LIST0 class_str_item -> cf ] ] - ; - class_self_patt: - [ [ "("; p = patt; ")" -> p - | "("; p = patt; ":"; t = ctyp; ")" -> <:patt< ($p$ : $t$) >> ] ] - ; - class_str_item: - [ [ "inherit"; ce = class_expr; pb = OPT [ "as"; i = LIDENT -> i ] -> - <:class_str_item< inherit $ce$ $opt:pb$ >> - | "val"; mf = OPT "mutable"; lab = label; e = cvalue_binding -> - <:class_str_item< value $opt:o2b mf$ $lab$ = $e$ >> - | "method"; "private"; "virtual"; l = label; ":"; t = poly_type -> - <:class_str_item< method virtual private $l$ : $t$ >> - | "method"; "virtual"; "private"; l = label; ":"; t = poly_type -> - <:class_str_item< method virtual private $l$ : $t$ >> - | "method"; "virtual"; l = label; ":"; t = poly_type -> - <:class_str_item< method virtual $l$ : $t$ >> - | "method"; "private"; l = label; ":"; t = poly_type; "="; e = expr -> - MLast.CrMth loc l True e (Some t) - | "method"; "private"; l = label; sb = fun_binding -> - MLast.CrMth loc l True sb None - | "method"; l = label; ":"; t = poly_type; "="; e = expr -> - MLast.CrMth loc l False e (Some t) - | "method"; l = label; sb = fun_binding -> - MLast.CrMth loc l False sb None - | "constraint"; t1 = ctyp; "="; t2 = ctyp -> - <:class_str_item< type $t1$ = $t2$ >> - | "initializer"; se = expr -> <:class_str_item< initializer $se$ >> ] ] - ; - cvalue_binding: - [ [ "="; e = expr -> e - | ":"; t = ctyp; "="; e = expr -> <:expr< ($e$ : $t$) >> - | ":"; t = ctyp; ":>"; t2 = ctyp; "="; e = expr -> - <:expr< ($e$ : $t$ :> $t2$) >> - | ":>"; t = ctyp; "="; e = expr -> - <:expr< ($e$ :> $t$) >> ] ] - ; - label: - [ [ i = LIDENT -> i ] ] - ; - (* Class types *) - class_type: - [ [ test_ctyp_minusgreater; t = ctyp LEVEL "star"; "->"; ct = SELF -> - <:class_type< [ $t$ ] -> $ct$ >> - | cs = class_signature -> cs ] ] - ; - class_signature: - [ [ "["; tl = LIST1 ctyp SEP ","; "]"; id = clty_longident -> - <:class_type< $list:id$ [ $list:tl$ ] >> - | id = clty_longident -> <:class_type< $list:id$ >> - | "object"; cst = OPT class_self_type; csf = LIST0 class_sig_item; - "end" -> - <:class_type< object $opt:cst$ $list:csf$ end >> ] ] - ; - class_self_type: - [ [ "("; t = ctyp; ")" -> t ] ] - ; - class_sig_item: - [ [ "inherit"; cs = class_signature -> <:class_sig_item< inherit $cs$ >> - | "val"; mf = OPT "mutable"; l = label; ":"; t = ctyp -> - <:class_sig_item< value $opt:o2b mf$ $l$ : $t$ >> - | "method"; "private"; "virtual"; l = label; ":"; t = poly_type -> - <:class_sig_item< method virtual private $l$ : $t$ >> - | "method"; "virtual"; "private"; l = label; ":"; t = poly_type -> - <:class_sig_item< method virtual private $l$ : $t$ >> - | "method"; "virtual"; l = label; ":"; t = poly_type -> - <:class_sig_item< method virtual $l$ : $t$ >> - | "method"; "private"; l = label; ":"; t = poly_type -> - <:class_sig_item< method private $l$ : $t$ >> - | "method"; l = label; ":"; t = poly_type -> - <:class_sig_item< method $l$ : $t$ >> - | "constraint"; t1 = ctyp; "="; t2 = ctyp -> - <:class_sig_item< type $t1$ = $t2$ >> ] ] - ; - class_description: - [ [ vf = OPT "virtual"; ctp = class_type_parameters; n = LIDENT; ":"; - ct = class_type -> - {MLast.ciLoc = loc; MLast.ciVir = o2b vf; MLast.ciPrm = ctp; - MLast.ciNam = n; MLast.ciExp = ct} ] ] - ; - class_type_declaration: - [ [ vf = OPT "virtual"; ctp = class_type_parameters; n = LIDENT; "="; - cs = class_signature -> - {MLast.ciLoc = loc; MLast.ciVir = o2b vf; MLast.ciPrm = ctp; - MLast.ciNam = n; MLast.ciExp = cs} ] ] - ; - (* Expressions *) - expr: LEVEL "simple" - [ LEFTA - [ "new"; i = class_longident -> <:expr< new $list:i$ >> ] ] - ; - expr: LEVEL "." - [ [ e = SELF; "#"; lab = label -> <:expr< $e$ # $lab$ >> ] ] - ; - expr: LEVEL "simple" - [ [ "("; e = SELF; ":"; t = ctyp; ":>"; t2 = ctyp; ")" -> - <:expr< ($e$ : $t$ :> $t2$) >> - | "("; e = SELF; ":>"; t = ctyp; ")" -> <:expr< ($e$ :> $t$) >> - | "{<"; ">}" -> <:expr< {< >} >> - | "{<"; fel = field_expr_list; ">}" -> <:expr< {< $list:fel$ >} >> ] ] - ; - field_expr_list: - [ [ l = label; "="; e = expr LEVEL "expr1"; ";"; fel = SELF -> - [(l, e) :: fel] - | l = label; "="; e = expr LEVEL "expr1"; ";" -> [(l, e)] - | l = label; "="; e = expr LEVEL "expr1" -> [(l, e)] ] ] - ; - (* Core types *) - ctyp: LEVEL "simple" - [ [ "#"; id = class_longident -> <:ctyp< # $list:id$ >> - | "<"; (ml, v) = meth_list; ">" -> <:ctyp< < $list:ml$ $opt:v$ > >> - | "<"; ">" -> <:ctyp< < > >> ] ] - ; - meth_list: - [ [ f = field; ";"; (ml, v) = SELF -> ([f :: ml], v) - | f = field; ";" -> ([f], False) - | f = field -> ([f], False) - | ".." -> ([], True) ] ] - ; - field: - [ [ lab = LIDENT; ":"; t = poly_type -> (lab, t) ] ] - ; - (* Polymorphic types *) - typevar: - [ [ "'"; i = ident -> i ] ] - ; - poly_type: - [ [ test_typevar_list_dot; tpl = LIST1 typevar; "."; t2 = ctyp -> - <:ctyp< ! $list:tpl$ . $t2$ >> - | t = ctyp -> t ] ] - ; - (* Identifiers *) - clty_longident: - [ [ m = UIDENT; "."; l = SELF -> [m :: l] - | i = LIDENT -> [i] ] ] - ; - class_longident: - [ [ m = UIDENT; "."; l = SELF -> [m :: l] - | i = LIDENT -> [i] ] ] - ; - (* Labels *) - ctyp: LEVEL "arrow" - [ RIGHTA - [ i = lident_colon; t1 = ctyp LEVEL "star"; "->"; t2 = SELF -> - <:ctyp< ( ~ $i$ : $t1$ ) -> $t2$ >> - | i = OPTLABEL; t1 = ctyp LEVEL "star"; "->"; t2 = SELF -> - <:ctyp< ( ? $i$ : $t1$ ) -> $t2$ >> - | i = QUESTIONIDENT; ":"; t1 = ctyp LEVEL "star"; "->"; t2 = SELF -> - <:ctyp< ( ? $i$ : $t1$ ) -> $t2$ >> - | "?"; i=lident_colon;t1 = ctyp LEVEL "star"; "->"; t2 = SELF -> - <:ctyp< ( ? $i$ : $t1$ ) -> $t2$ >> ] ] - ; - ctyp: LEVEL "simple" - [ [ "["; OPT "|"; rfl = LIST1 row_field SEP "|"; "]" -> - <:ctyp< [ = $list:rfl$ ] >> - | "["; ">"; "]" -> <:ctyp< [ > $list:[]$ ] >> - | "["; ">"; OPT "|"; rfl = LIST1 row_field SEP "|"; "]" -> - <:ctyp< [ > $list:rfl$ ] >> - | "[<"; OPT "|"; rfl = LIST1 row_field SEP "|"; "]" -> - <:ctyp< [ < $list:rfl$ ] >> - | "[<"; OPT "|"; rfl = LIST1 row_field SEP "|"; ">"; - ntl = LIST1 name_tag; "]" -> - <:ctyp< [ < $list:rfl$ > $list:ntl$ ] >> ] ] - ; - row_field: - [ [ "`"; i = ident -> MLast.RfTag i True [] - | "`"; i = ident; "of"; ao = OPT "&"; l = LIST1 ctyp SEP "&" -> - MLast.RfTag i (o2b ao) l - | t = ctyp -> MLast.RfInh t ] ] - ; - name_tag: - [ [ "`"; i = ident -> i ] ] - ; - expr: LEVEL "expr1" - [ [ "fun"; p = labeled_patt; e = fun_def -> <:expr< fun $p$ -> $e$ >> ] ] - ; - expr: AFTER "apply" - [ "label" - [ i = LABEL; e = SELF -> <:expr< ~ $i$ : $e$ >> - | i = TILDEIDENT -> <:expr< ~ $i$ >> - | "~"; i = LIDENT -> <:expr< ~ $i$ >> - | i = OPTLABEL; e = SELF -> <:expr< ? $i$ : $e$ >> - | i = QUESTIONIDENT -> <:expr< ? $i$ >> - | "?"; i = LIDENT -> <:expr< ? $i$ >> ] ] - ; - expr: LEVEL "simple" - [ [ "`"; s = ident -> <:expr< ` $s$ >> ] ] - ; - fun_def: - [ [ p = labeled_patt; e = SELF -> <:expr< fun $p$ -> $e$ >> ] ] - ; - fun_binding: - [ [ p = labeled_patt; e = SELF -> <:expr< fun $p$ -> $e$ >> ] ] - ; - patt: LEVEL "simple" - [ [ "`"; s = ident -> <:patt< ` $s$ >> - | "#"; t = mod_ident -> <:patt< # $list:t$ >> ] ] - ; - labeled_patt: - [ [ i = LABEL; p = patt LEVEL "simple" -> - <:patt< ~ $i$ : $p$ >> - | i = TILDEIDENT -> - <:patt< ~ $i$ >> - | "~"; i=LIDENT -> <:patt< ~ $i$ >> - | "~"; "("; i = LIDENT; ")" -> - <:patt< ~ $i$ >> - | "~"; "("; i = LIDENT; ":"; t = ctyp; ")" -> - <:patt< ~ $i$ : ($lid:i$ : $t$) >> - | i = OPTLABEL; j = LIDENT -> - <:patt< ? $i$ : ($lid:j$) >> - | i = OPTLABEL; "("; p = patt; "="; e = expr; ")" -> - <:patt< ? $i$ : ( $p$ = $e$ ) >> - | i = OPTLABEL; "("; p = patt; ":"; t = ctyp; ")" -> - <:patt< ? $i$ : ( $p$ : $t$ ) >> - | i = OPTLABEL; "("; p = patt; ":"; t = ctyp; "="; - e = expr; ")" -> - <:patt< ? $i$ : ( $p$ : $t$ = $e$ ) >> - | i = QUESTIONIDENT -> <:patt< ? $i$ >> - | "?"; i = LIDENT -> <:patt< ? $i$ >> - | "?"; "("; i = LIDENT; "="; e = expr; ")" -> - <:patt< ? ( $lid:i$ = $e$ ) >> - | "?"; "("; i = LIDENT; ":"; t = ctyp; "="; e = expr; ")" -> - <:patt< ? ( $lid:i$ : $t$ = $e$ ) >> - | "?"; "("; i = LIDENT; ")" -> - <:patt< ? $i$ >> - | "?"; "("; i = LIDENT; ":"; t = ctyp; ")" -> - <:patt< ? ( $lid:i$ : $t$ ) >> ] ] - ; - class_type: - [ [ i = lident_colon; t = ctyp LEVEL "star"; "->"; ct = SELF -> - <:class_type< [ ~ $i$ : $t$ ] -> $ct$ >> - | i = OPTLABEL; t = ctyp LEVEL "star"; "->"; ct = SELF -> - <:class_type< [ ? $i$ : $t$ ] -> $ct$ >> - | i = QUESTIONIDENT; ":"; t = ctyp LEVEL "star"; "->"; ct = SELF -> - <:class_type< [ ? $i$ : $t$ ] -> $ct$ >> - | "?"; i = LIDENT; ":"; t = ctyp LEVEL "star"; "->"; ct = SELF -> - <:class_type< [ ? $i$ : $t$ ] -> $ct$ >> ] ] - ; - class_fun_binding: - [ [ p = labeled_patt; cfb = SELF -> <:class_expr< fun $p$ -> $cfb$ >> ] ] - ; -END; - -(* Main entry points *) - -EXTEND - GLOBAL: interf implem use_file top_phrase expr patt; - interf: - [ [ si = sig_item_semi; (sil, stopped) = SELF -> ([si :: sil], stopped) - | "#"; n = LIDENT; dp = OPT expr; ";;" -> - ([(<:sig_item< # $n$ $opt:dp$ >>, loc)], True) - | EOI -> ([], False) ] ] - ; - sig_item_semi: - [ [ si = sig_item; OPT ";;" -> (si, loc) ] ] - ; - implem: - [ [ si = str_item_semi; (sil, stopped) = SELF -> ([si :: sil], stopped) - | "#"; n = LIDENT; dp = OPT expr; ";;" -> - ([(<:str_item< # $n$ $opt:dp$ >>, loc)], True) - | EOI -> ([], False) ] ] - ; - str_item_semi: - [ [ si = str_item; OPT ";;" -> (si, loc) ] ] - ; - top_phrase: - [ [ ph = phrase; ";;" -> Some ph - | EOI -> None ] ] - ; - use_file: - [ [ si = str_item; OPT ";;"; (sil, stopped) = SELF -> - ([si :: sil], stopped) - | "#"; n = LIDENT; dp = OPT expr; ";;" -> - ([<:str_item< # $n$ $opt:dp$ >>], True) - | EOI -> ([], False) ] ] - ; - phrase: - [ [ sti = str_item -> sti - | "#"; n = LIDENT; dp = OPT expr -> <:str_item< # $n$ $opt:dp$ >> ] ] - ; -END; - -Pcaml.add_option "-no_quot" (Arg.Set Plexer.no_quotations) - "Don't parse quotations, allowing to use, e.g. \"<:>\" as token"; diff --git a/camlp4/etc/pa_ocamllex.ml b/camlp4/etc/pa_ocamllex.ml deleted file mode 100644 index 76c8c6aea9..0000000000 --- a/camlp4/etc/pa_ocamllex.ml +++ /dev/null @@ -1,344 +0,0 @@ -(* camlp4 ./pa_o.cmo q_MLast.cmo pa_extend.cmo pr_dump.cmo *) -(* $Id$ *) -(* Alain Frisch's contribution *) - -open Syntax -open Lexgen -open Compact - -(* Adapted from output.ml *) -(**************************) - -(* Output the DFA tables and its entry points *) - -(* To output an array of short ints, encoded as a string *) - -let output_byte buf b = - Buffer.add_char buf '\\'; - Buffer.add_char buf (Char.chr(48 + b / 100)); - Buffer.add_char buf (Char.chr(48 + (b / 10) mod 10)); - Buffer.add_char buf (Char.chr(48 + b mod 10)) - -let loc = (-1,-1) - -let output_array v = - let b = Buffer.create (Array.length v * 3) in - for i = 0 to Array.length v - 1 do - output_byte b (v.(i) land 0xFF); - output_byte b ((v.(i) asr 8) land 0xFF); - if i land 7 = 7 then Buffer.add_string b "\\\n " - done; - let s = Buffer.contents b in - <:expr< $str:s$ >> - -let output_byte_array v = - let b = Buffer.create (Array.length v * 2) in - for i = 0 to Array.length v - 1 do - output_byte b (v.(i) land 0xFF); - if i land 15 = 15 then Buffer.add_string b "\\\n " - done; - let s = Buffer.contents b in - <:expr< $str:s$ >> - - - -(* Output the tables *) - -let output_tables tbl = - <:str_item< value lex_tables = { - Lexing.lex_base = $output_array tbl.tbl_base$; - Lexing.lex_backtrk = $output_array tbl.tbl_backtrk$; - Lexing.lex_default = $output_array tbl.tbl_default$; - Lexing.lex_trans = $output_array tbl.tbl_trans$; - Lexing.lex_check = $output_array tbl.tbl_check$; - Lexing.lex_base_code = $output_array tbl.tbl_base_code$; - Lexing.lex_backtrk_code = $output_array tbl.tbl_backtrk_code$; - Lexing.lex_default_code = $output_array tbl.tbl_default_code$; - Lexing.lex_trans_code = $output_array tbl.tbl_trans_code$; - Lexing.lex_check_code = $output_array tbl.tbl_check_code$; - Lexing.lex_code = $output_byte_array tbl.tbl_code$ - } >> - -(* Output the entries *) - -let rec make_alias n = function - | [] -> [] - | h::t -> - (h, "__ocaml_lex_arg_" ^ (string_of_int n)) :: (make_alias (succ n) t) - -let abstraction = - List.fold_right (fun (p,a) e -> <:expr< fun ($p$ as $lid:a$) -> $e$ >>) - - -let application = - List.fold_left (fun f (_,a) -> <:expr< $f$ $lid:a$ >>) - -let int i = <:expr< $int:string_of_int i$ >> - -let output_memory_actions acts = - let aux = function - | Copy (tgt, src) -> - <:expr< lexbuf.Lexing.lex_mem.($int tgt$) := - lexbuf.Lexing.lex_mem.($int src$) >> - | Set tgt -> - <:expr< lexbuf.Lexing.lex_mem.($int tgt$) := - lexbuf.Lexing.lex_curr_pos >> - in - <:expr< do { $list:List.map aux acts$ } >> - -let output_base_mem = function - | Mem i -> <:expr< lexbuf.Lexing.lex_mem.($int i$) >> - | Start -> <:expr< lexbuf.Lexing.lex_start_pos >> - | End -> <:expr< lexbuf.Lexing.lex_curr_pos >> - -let output_tag_access = function - | Sum (a,0) -> output_base_mem a - | Sum (a,i) -> <:expr< $output_base_mem a$ + $int i$ >> - -let rec output_env e = function - | [] -> e - | (x, Ident_string (o,nstart,nend)) :: rem -> - <:expr< - let $lid:x$ = - Lexing.$lid:if o then "sub_lexeme_opt" else "sub_lexeme"$ - lexbuf $output_tag_access nstart$ $output_tag_access nend$ - in $output_env e rem$ - >> - | (x, Ident_char (o,nstart)) :: rem -> - <:expr< - let $lid:x$ = - Lexing.$lid: if o then "sub_lexeme_char_opt" else "sub_lexeme_char"$ - lexbuf $output_tag_access nstart$ - in $output_env e rem$ - >> - -let output_entry e = - let init_num, init_moves = e.auto_initial_state in - let args = make_alias 0 (e.auto_args @ [ <:patt< lexbuf >> ]) in - let f = "__ocaml_lex_rec_" ^ e.auto_name ^ "_rec" in - let call_f = application <:expr< $lid:f$ >> args in - let body_wrapper = - <:expr< - do { - lexbuf.Lexing.lex_mem := Array.create $int e.auto_mem_size$ (-1) ; - $output_memory_actions init_moves$; - $call_f$ $int init_num$ - } >> in - let cases = - List.map - (fun (num, env, (loc,e)) -> - <:patt< $int:string_of_int num$ >>, - None, - output_env <:expr< $e$ >> env - (* Note: the <:expr<...>> above is there to set the location *) - ) e.auto_actions @ - [ <:patt< __ocaml_lex_n >>, - None, - <:expr< do - { lexbuf.Lexing.refill_buff lexbuf; $call_f$ __ocaml_lex_n }>> ] - in - let engine = - if e.auto_mem_size = 0 - then <:expr< Lexing.engine >> - else <:expr< Lexing.new_engine >> in - let body = - <:expr< fun state -> - match $engine$ lex_tables state lexbuf with [ $list:cases$ ] >> in - [ - <:patt< $lid:e.auto_name$ >>, (abstraction args body_wrapper); - <:patt< $lid:f$ >>, (abstraction args body) - ] - -(* Main output function *) - -exception Table_overflow - -let output_lexdef tables entry_points = - Printf.eprintf - "pa_ocamllex: lexer found; %d states, %d transitions, table size %d bytes\n" - (Array.length tables.tbl_base) - (Array.length tables.tbl_trans) - (2 * (Array.length tables.tbl_base + Array.length tables.tbl_backtrk + - Array.length tables.tbl_default + Array.length tables.tbl_trans + - Array.length tables.tbl_check)); - let size_groups = - (2 * (Array.length tables.tbl_base_code + - Array.length tables.tbl_backtrk_code + - Array.length tables.tbl_default_code + - Array.length tables.tbl_trans_code + - Array.length tables.tbl_check_code) + - Array.length tables.tbl_code) in - if size_groups > 0 then - Printf.eprintf "pa_ocamllex: %d additional bytes used for bindings\n" - size_groups ; - flush stderr; - if Array.length tables.tbl_trans > 0x8000 then raise Table_overflow; - - let entries = List.map output_entry entry_points in - [output_tables tables; <:str_item< value rec $list:List.flatten entries$ >> ] - - -(* Adapted from parser.mly and main.ml *) -(***************************************) - -(* Auxiliaries for the parser. *) - -let char s = Char.code (Token.eval_char s) - -let named_regexps = - (Hashtbl.create 13 : (string, regular_expression) Hashtbl.t) - -let regexp_for_string s = - let rec re_string n = - if n >= String.length s then Epsilon - else if succ n = String.length s then - Characters (Cset.singleton (Char.code s.[n])) - else - Sequence - (Characters(Cset.singleton (Char.code s.[n])), - re_string (succ n)) - in re_string 0 - -let char_class c1 c2 = Cset.interval c1 c2 - -let all_chars = Cset.all_chars - -let rec remove_as = function - | Bind (e,_) -> remove_as e - | Epsilon|Eof|Characters _ as e -> e - | Sequence (e1, e2) -> Sequence (remove_as e1, remove_as e2) - | Alternative (e1, e2) -> Alternative (remove_as e1, remove_as e2) - | Repetition e -> Repetition (remove_as e) - -let () = - Hashtbl.add named_regexps "eof" (Characters Cset.eof) - -(* The parser *) - -let let_regexp = Grammar.Entry.create Pcaml.gram "pa_ocamllex let" -let header = Grammar.Entry.create Pcaml.gram "pa_ocamllex header" -let lexer_def = Grammar.Entry.create Pcaml.gram "pa_ocaml lexerdef" - -EXTEND - GLOBAL: Pcaml.str_item let_regexp header lexer_def; - - let_regexp: [ - [ x = LIDENT; "="; r = regexp -> - if Hashtbl.mem named_regexps x then - Printf.eprintf - "pa_ocamllex (warning): multiple definition of named regexp '%s'\n" - x; - Hashtbl.add named_regexps x r; - ] - ]; - - lexer_def: [ - [ def = LIST0 definition SEP "and" -> - (try - let (entries, transitions) = make_dfa def in - let tables = compact_tables transitions in - let output = output_lexdef tables entries in - <:str_item< declare $list: output$ end >> - with - |Table_overflow -> - failwith "Transition table overflow in lexer, automaton is too big" - | Lexgen.Memory_overflow -> - failwith "Position memory overflow in lexer, too many as variables") - ] - ]; - - - Pcaml.str_item: [ - [ "pa_ocamllex"; LIDENT "rule"; d = lexer_def -> d - | "pa_ocamllex"; "let"; let_regexp -> - <:str_item< declare $list: []$ end >> - ] - ]; - - definition: [ - [ x=LIDENT; pl = LIST0 Pcaml.patt; "="; - short=[ LIDENT "parse" -> false | LIDENT "shortest" -> true ]; - OPT "|"; l = LIST0 [ r=regexp; a=action -> (r,a) ] SEP "|" -> - { name=x ; shortest=short ; args=pl ; clauses = l } ] - ]; - - action: [ - [ "{"; e = OPT Pcaml.expr; "}" -> - let e = match e with - | Some e -> e - | None -> <:expr< () >> - in - (loc,e) - ] - ]; - - header: [ - [ "{"; e = LIST0 [ si = Pcaml.str_item; OPT ";;" -> si ]; "}" -> - [<:str_item< declare $list:e$ end>>, loc] ] - | [ -> [] ] - ]; - - regexp: [ - [ r = regexp; "as"; i = LIDENT -> Bind (r,i) ] - | [ r1 = regexp; "|"; r2 = regexp -> Alternative(r1,r2) ] - | [ r1 = regexp; r2 = regexp -> Sequence(r1,r2) ] - | [ r = regexp; "*" -> Repetition r - | r = regexp; "+" -> Sequence(Repetition (remove_as r), r) - | r = regexp; "?" -> Alternative(Epsilon, r) - | "("; r = regexp; ")" -> r - | "_" -> Characters all_chars - | c = CHAR -> Characters (Cset.singleton (char c)) - | s = STRING -> regexp_for_string (Token.eval_string s) - | "["; cc = ch_class; "]" -> Characters cc - | x = LIDENT -> - try Hashtbl.find named_regexps x - with Not_found -> - failwith - ("pa_ocamllex (error): reference to unbound regexp name `"^x^"'") - ] - ]; - - ch_class: [ - [ "^"; cc = ch_class -> Cset.complement cc] - | [ c1 = CHAR; "-"; c2 = CHAR -> Cset.interval (char c1) (char c2) - | c = CHAR -> Cset.singleton (char c) - | cc1 = ch_class; cc2 = ch_class -> Cset.union cc1 cc2 - ] - ]; -END - -(* We have to be careful about "rule"; in standalone mode, - it is used as a keyword (otherwise, there is a conflict - with named regexp); in normal mode, it is used as LIDENT - (we do not want to reserve such an useful identifier). - - Plexer does not like identifiers used as keyword _and_ - as LIDENT ... -*) - -let standalone = - let already = ref false in - fun () -> - if not (!already) then - begin - already := true; - Printf.eprintf "pa_ocamllex: stand-alone mode\n"; - - DELETE_RULE Pcaml.str_item: "pa_ocamllex"; LIDENT "rule";lexer_def END; - DELETE_RULE Pcaml.str_item: "pa_ocamllex"; "let"; let_regexp END; - let ocamllex = Grammar.Entry.create Pcaml.gram "pa_ocamllex" in - EXTEND GLOBAL: ocamllex let_regexp header lexer_def; - ocamllex: [ - [ h = header; - l = [LIST0 ["let"; let_regexp]; "rule"; d = lexer_def -> (d,loc)]; - t = header; EOI -> h @ (l :: t) ,false - ] - ]; - END; - Pcaml.parse_implem := Grammar.Entry.parse ocamllex - end - -let () = - Pcaml.add_option "-ocamllex" (Arg.Unit standalone) - "Activate (standalone) ocamllex emulation mode." - diff --git a/camlp4/etc/pa_olabl.ml b/camlp4/etc/pa_olabl.ml deleted file mode 100644 index d43b499dfd..0000000000 --- a/camlp4/etc/pa_olabl.ml +++ /dev/null @@ -1,2005 +0,0 @@ -(* camlp4r pa_extend.cmo q_MLast.cmo *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2001 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -module Plexer = - struct - open Stdpp; - open Token; - value buff = ref (String.create 80); - value store len x = - do { - if len >= String.length buff.val then - buff.val := buff.val ^ String.create (String.length buff.val) - else (); - buff.val.[len] := x; - succ len - } - ; - value mstore len s = - add_rec len 0 where rec add_rec len i = - if i == String.length s then len - else add_rec (store len s.[i]) (succ i) - ; - value get_buff len = String.sub buff.val 0 len; - value rec ident len = - parser - [ [: `('A'..'Z' | 'a'..'z' | '\192'..'\214' | '\216'..'\246' | - '\248'..'\255' | '0'..'9' | '_' | ''' as - c) - ; - s :] -> - ident (store len c) s - | [: :] -> len ] - and ident2 len = - parser - [ [: `('!' | '?' | '~' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' | - '%' | '.' | ':' | '<' | '>' | '|' as - c) - ; - s :] -> - ident2 (store len c) s - | [: :] -> len ] - and ident3 len = - parser - [ [: `('0'..'9' | 'A'..'Z' | 'a'..'z' | '\192'..'\214' | - '\216'..'\246' | '\248'..'\255' | '_' | '!' | '%' | '&' | '*' | - '+' | '-' | '.' | '/' | ':' | '<' | '=' | '>' | '?' | '@' | '^' | - '|' | '~' | ''' | '$' as - c) - ; - s :] -> - ident3 (store len c) s - | [: :] -> len ] - and ident4 len = - parser - [ [: `('!' | '?' | '~' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' | - '%' | '.' | '<' | '>' | '|' as - c) - ; - s :] -> - ident4 (store len c) s - | [: :] -> len ] - and base_number len = - parser - [ [: `'o' | 'O'; s :] -> octal_digits (store len 'o') s - | [: `'x' | 'X'; s :] -> hexa_digits (store len 'x') s - | [: `'b' | 'B'; s :] -> binary_digits (store len 'b') s - | [: a = number len :] -> a ] - and octal_digits len = - parser - [ [: `('0'..'7' as d); s :] -> octal_digits (store len d) s - | [: :] -> ("INT", get_buff len) ] - and hexa_digits len = - parser - [ [: `('0'..'9' | 'a'..'f' | 'A'..'F' as d); s :] -> - hexa_digits (store len d) s - | [: :] -> ("INT", get_buff len) ] - and binary_digits len = - parser - [ [: `('0'..'1' as d); s :] -> binary_digits (store len d) s - | [: :] -> ("INT", get_buff len) ] - and number len = - parser - [ [: `('0'..'9' as c); s :] -> number (store len c) s - | [: `'.'; s :] -> decimal_part (store len '.') s - | [: `'e' | 'E'; s :] -> exponent_part (store len 'E') s - | [: :] -> ("INT", get_buff len) ] - and decimal_part len = - parser - [ [: `('0'..'9' as c); s :] -> decimal_part (store len c) s - | [: `'e' | 'E'; s :] -> exponent_part (store len 'E') s - | [: :] -> ("FLOAT", get_buff len) ] - and exponent_part len = - parser - [ [: `('+' | '-' as c); s :] -> end_exponent_part (store len c) s - | [: a = end_exponent_part len :] -> a ] - and end_exponent_part len = - parser - [ [: `('0'..'9' as c); s :] -> end_exponent_part (store len c) s - | [: :] -> ("FLOAT", get_buff len) ] - ; - value valch x = Char.code x - Char.code '0'; - value rec backslash s i = - if i = String.length s then raise Not_found - else - match s.[i] with - [ 'n' -> ('\n', i + 1) - | 'r' -> ('\r', i + 1) - | 't' -> ('\t', i + 1) - | 'b' -> ('\b', i + 1) - | '\\' -> ('\\', i + 1) - | '0'..'9' as c -> backslash1 (valch c) s (i + 1) - | _ -> raise Not_found ] - and backslash1 cod s i = - if i = String.length s then (Char.chr cod, i) - else - match s.[i] with - [ '0'..'9' as c -> backslash2 (10 * cod + valch c) s (i + 1) - | _ -> (Char.chr cod, i) ] - and backslash2 cod s i = - if i = String.length s then (Char.chr cod, i) - else - match s.[i] with - [ '0'..'9' as c -> (Char.chr (10 * cod + valch c), i + 1) - | _ -> (Char.chr cod, i) ] - ; - value rec skip_indent s i = - if i = String.length s then i - else - match s.[i] with - [ ' ' | '\t' -> skip_indent s (i + 1) - | _ -> i ] - ; - value skip_opt_linefeed s i = - if i = String.length s then i else if s.[i] = '\010' then i + 1 else i - ; - value char_of_char_token s = - if String.length s = 1 then s.[0] - else if String.length s = 0 then failwith "invalid char token" - else if s.[0] = '\\' then - if String.length s = 2 && s.[1] = ''' then ''' - else - try - let (c, i) = backslash s 1 in - if i = String.length s then c else raise Not_found - with - [ Not_found -> failwith "invalid char token" ] - else failwith "invalid char token" - ; - value string_of_string_token s = - loop 0 0 where rec loop len i = - if i = String.length s then get_buff len - else - let (len, i) = - if s.[i] = '\\' then - let i = i + 1 in - if i = String.length s then failwith "invalid string token" - else if s.[i] = '"' then (store len '"', i + 1) - else - match s.[i] with - [ '\010' -> (len, skip_indent s (i + 1)) - | '\013' -> (len, skip_indent s (skip_opt_linefeed s (i + 1))) - | c -> - try - let (c, i) = backslash s i in - (store len c, i) - with - [ Not_found -> (store (store len '\\') c, i + 1) ] ] - else (store len s.[i], i + 1) - in - loop len i - ; - value rec skip_spaces = - parser - [ [: `' ' | '\n' | '\r' | '\t' | '\026' | '\012'; s :] -> skip_spaces s - | [: :] -> () ] - ; - value error_on_unknown_keywords = ref False; - value next_token_fun find_id_kwd find_spe_kwd = - let err bp ep msg = raise_with_loc (bp, ep) (Token.Error msg) in - let keyword_or_error (bp, ep) s = - try ("", find_spe_kwd s) with - [ Not_found -> - if error_on_unknown_keywords.val then - err bp ep ("illegal token: " ^ s) - else ("", s) ] - in - let rec next_token = - parser bp - [ [: `('A'..'Z' | 'À'..'Ö' | 'Ø'..'Þ' as c); s :] -> - let id = get_buff (ident (store 0 c) s) in - try ("", find_id_kwd id) with [ Not_found -> ("UIDENT", id) ] - | [: `('a'..'z' | 'ß'..'ö' | 'ø'..'ÿ' | '_' as c); s :] -> - let id = get_buff (ident (store 0 c) s) in - let is_label = - match Stream.peek s with - [ Some ':' -> - match Stream.npeek 2 s with - [ [_; ':' | '=' | '>'] -> False - | _ -> True ] - | _ -> False ] - in - if is_label then do { Stream.junk s; ("LABEL", id) } - else try ("", find_id_kwd id) with [ Not_found -> ("LIDENT", id) ] - | [: `('1'..'9' as c); s :] -> number (store 0 c) s - | [: `'0'; s :] -> base_number (store 0 '0') s - | [: `'''; s :] ep -> - match Stream.npeek 2 s with - [ [_; '''] | ['\\'; _] -> ("CHAR", char bp 0 s) - | _ -> keyword_or_error (bp, ep) "'" ] - | [: `'"'; s :] -> ("STRING", string bp 0 s) - | [: `'$'; s :] -> locate_or_antiquot bp 0 s - | [: `('!' | '~' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' | - '%' as - c) - ; - s :] -> - let id = get_buff (ident2 (store 0 c) s) in - keyword_or_error (bp, Stream.count s) id - | [: `('?' as c); s :] -> - let id = get_buff (ident4 (store 0 c) s) in - keyword_or_error (bp, Stream.count s) id - | [: `'<'; s :] -> less bp s - | [: `(':' as c1); - (is_label, len) = - parser - [ [: `(']' | ':' | '=' | '>' as c2) :] -> - (False, store (store 0 c1) c2) - | [: `('a'..'z' | 'ß'..'ö' | 'ø'..'ÿ' | '_' as c); s :] -> - (True, ident (store 0 c) s) - | [: :] -> (False, store 0 c1) ] :] ep -> - let id = get_buff len in - if is_label then ("ELABEL", id) else keyword_or_error (bp, ep) id - | [: `('>' | '|' as c1); - len = - parser - [ [: `(']' | '}' as c2) :] -> store (store 0 c1) c2 - | [: a = ident2 (store 0 c1) :] -> a ] :] ep -> - let id = get_buff len in - keyword_or_error (bp, ep) id - | [: `('[' | '{' as c1); s :] -> - let len = - match Stream.npeek 2 s with - [ ['<'; '<' | ':'] -> store 0 c1 - | _ -> - match s with parser - [ [: `('|' | '<' | ':' as c2) :] -> store (store 0 c1) c2 - | [: :] -> store 0 c1 ] ] - in - let ep = Stream.count s in - let id = get_buff len in - keyword_or_error (bp, ep) id - | [: `'.'; id = parser [ [: `'.' :] -> ".." | [: :] -> "." ] :] ep -> - keyword_or_error (bp, ep) id - | [: `';'; id = parser [ [: `';' :] -> ";;" | [: :] -> ";" ] :] ep -> - keyword_or_error (bp, ep) id - | [: `'\\'; s :] -> ("LIDENT", get_buff (ident3 0 s)) - | [: `c :] ep -> keyword_or_error (bp, ep) (String.make 1 c) ] - and less bp = - parser - [ [: `'<'; s :] -> ("QUOTATION", ":" ^ get_buff (quotation bp 0 s)) - | [: `':'; i = parser [: len = ident 0 :] -> get_buff len; - `'<' ? "character '<' expected"; s :] -> - ("QUOTATION", i ^ ":" ^ get_buff (quotation bp 0 s)) - | [: s :] ep -> - let id = get_buff (ident2 (store 0 '<') s) in - keyword_or_error (bp, ep) id ] - and string bp len = - parser - [ [: `'"' :] -> get_buff len - | [: `'\\'; `c; s :] -> string bp (store (store len '\\') c) s - | [: `c; s :] -> string bp (store len c) s - | [: :] ep -> err bp ep "string not terminated" ] - and char bp len = - parser - [ [: `'''; s :] -> - if len = 0 then char bp (store len ''') s else get_buff len - | [: `'\\'; `c; s :] -> char bp (store (store len '\\') c) s - | [: `c; s :] -> char bp (store len c) s - | [: :] ep -> err bp ep "char not terminated" ] - and locate_or_antiquot bp len = - parser - [ [: `'$' :] -> ("ANTIQUOT", ":" ^ get_buff len) - | [: `('a'..'z' | 'A'..'Z' as c); s :] -> antiquot bp (store len c) s - | [: `('0'..'9' as c); s :] -> maybe_locate bp (store len c) s - | [: `':'; s :] -> - let k = get_buff len in - ("ANTIQUOT", k ^ ":" ^ locate_or_antiquot_rest bp 0 s) - | [: `'\\'; `c; s :] -> - ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s) - | [: `c; s :] -> - ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s) - | [: :] ep -> err bp ep "antiquotation not terminated" ] - and maybe_locate bp len = - parser - [ [: `'$' :] -> ("ANTIQUOT", ":" ^ get_buff len) - | [: `('0'..'9' as c); s :] -> maybe_locate bp (store len c) s - | [: `':'; s :] -> - ("LOCATE", get_buff len ^ ":" ^ locate_or_antiquot_rest bp 0 s) - | [: `'\\'; `c; s :] -> - ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s) - | [: `c; s :] -> - ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s) - | [: :] ep -> err bp ep "antiquotation not terminated" ] - and antiquot bp len = - parser - [ [: `'$' :] -> ("ANTIQUOT", ":" ^ get_buff len) - | [: `('a'..'z' | 'A'..'Z' | '0'..'9' as c); s :] -> - antiquot bp (store len c) s - | [: `':'; s :] -> - let k = get_buff len in - ("ANTIQUOT", k ^ ":" ^ locate_or_antiquot_rest bp 0 s) - | [: `'\\'; `c; s :] -> - ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s) - | [: `c; s :] -> - ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s) - | [: :] ep -> err bp ep "antiquotation not terminated" ] - and locate_or_antiquot_rest bp len = - parser - [ [: `'$' :] -> get_buff len - | [: `'\\'; `c; s :] -> locate_or_antiquot_rest bp (store len c) s - | [: `c; s :] -> locate_or_antiquot_rest bp (store len c) s - | [: :] ep -> err bp ep "antiquotation not terminated" ] - and quotation bp len = - parser - [ [: `'>'; s :] -> maybe_end_quotation bp len s - | [: `'<'; s :] -> - quotation bp (maybe_nested_quotation bp (store len '<') strm__) s - | [: `'\\'; - len = - parser - [ [: `('>' | '<' | '\\' as c) :] -> store len c - | [: :] -> store len '\\' ]; - s :] -> - quotation bp len s - | [: `c; s :] -> quotation bp (store len c) s - | [: :] ep -> err bp ep "quotation not terminated" ] - and maybe_nested_quotation bp len = - parser - [ [: `'<'; s :] -> mstore (quotation bp (store len '<') s) ">>" - | [: `':'; len = ident (store len ':'); - a = - parser - [ [: `'<'; s :] -> mstore (quotation bp (store len '<') s) ">>" - | [: :] -> len ] :] -> - a - | [: :] -> len ] - and maybe_end_quotation bp len = - parser - [ [: `'>' :] -> len - | [: a = quotation bp (store len '>') :] -> a ] - in - let rec next_token_loc = - parser bp - [ [: `' ' | '\n' | '\r' | '\t' | '\026' | '\012'; s :] -> - next_token_loc s - | [: `'('; s :] -> maybe_comment bp s - | [: `'#'; _ = spaces_tabs; a = linenum bp :] -> a - | [: tok = next_token :] ep -> (tok, (bp, ep)) - | [: _ = Stream.empty :] -> (("EOI", ""), (bp, succ bp)) ] - and maybe_comment bp = - parser - [ [: `'*'; s :] -> do { comment bp s; next_token_loc s } - | [: :] ep -> - let tok = keyword_or_error (bp, ep) "(" in - (tok, (bp, ep)) ] - and comment bp = - parser - [ [: `'('; s :] -> maybe_nested_comment bp s - | [: `'*'; s :] -> maybe_end_comment bp s - | [: `c; s :] -> comment bp s - | [: :] ep -> err bp ep "comment not terminated" ] - and maybe_nested_comment bp = - parser - [ [: `'*'; s :] -> do { comment bp s; comment bp s } - | [: a = comment bp :] -> a ] - and maybe_end_comment bp = - parser [ [: `')' :] -> () | [: a = comment bp :] -> a ] - and linenum bp = - parser - [ [: `'0'..'9'; _ = digits; _ = spaces_tabs; `'"'; _ = any_to_nl; - s :] -> - next_token_loc s - | [: :] -> (keyword_or_error (bp, bp + 1) "#", (bp, bp + 1)) ] - and spaces_tabs = - parser [ [: `' ' | '\t'; s :] -> spaces_tabs s | [: :] -> () ] - and digits = parser [ [: `'0'..'9'; s :] -> digits s | [: :] -> () ] - and any_to_nl = - parser - [ [: `'\r' | '\n' :] -> () - | [: `_; s :] -> any_to_nl s - | [: :] -> () ] - in - fun cstrm -> - try next_token_loc cstrm with - [ Stream.Error str -> - err (Stream.count cstrm) (Stream.count cstrm + 1) str ] - ; - value locerr () = invalid_arg "Lexer: location function"; - value loct_create () = ref (Array.create 1024 None); - value loct_func loct i = - match - if i < 0 || i >= Array.length loct.val then None - else Array.unsafe_get loct.val i - with - [ Some loc -> loc - | _ -> locerr () ] - ; - value loct_add loct i loc = - do { - if i >= Array.length loct.val then do { - let new_tmax = Array.length loct.val * 2 in - let new_loct = Array.create new_tmax None in - Array.blit loct.val 0 new_loct 0 (Array.length loct.val); - loct.val := new_loct - } - else (); - loct.val.(i) := Some loc - } - ; - value func kwd_table = - let find = Hashtbl.find kwd_table in - let lex cstrm = - let next_token_loc = next_token_fun find find in - let loct = loct_create () in - let ts = - Stream.from - (fun i -> - let (tok, loc) = next_token_loc cstrm in - do { loct_add loct i loc; Some tok }) - in - let locf = loct_func loct in - (ts, locf) - in - lex - ; - value rec check_keyword_stream = - parser [: _ = check; _ = Stream.empty :] -> True - and check = - parser - [ [: `'A'..'Z' | 'a'..'z' | 'À'..'Ö' | 'Ø'..'ö' | 'ø'..'ÿ'; s :] -> - check_ident s - | [: `'!' | '?' | '~' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' | - '%' | '.' - ; - s :] -> - check_ident2 s - | [: `'<'; s :] -> - match Stream.npeek 1 s with - [ [':' | '<'] -> () - | _ -> check_ident2 s ] - | [: `':'; - _ = - parser - [ [: `']' | ':' | '=' | '>' :] -> () - | [: :] -> () ] :] ep -> - () - | [: `'>' | '|'; - _ = - parser - [ [: `']' | '}' :] -> () - | [: a = check_ident2 :] -> a ] :] -> - () - | [: `'[' | '{'; s :] -> - match Stream.npeek 2 s with - [ ['<'; '<' | ':'] -> () - | _ -> - match s with parser - [ [: :] -> - match Stream.peek strm__ with - [ Some ('|' | '<' | ':') -> Stream.junk strm__ - | _ -> () ] ] ] - | [: `';'; _ = parser [ [: `';' :] -> () | [: :] -> () ] :] -> () - | [: `_ :] -> () ] - and check_ident = - parser - [ [: `'A'..'Z' | 'a'..'z' | 'À'..'Ö' | 'Ø'..'ö' | 'ø'..'ÿ' | '0'..'9' | - '_' | ''' - ; - s :] -> - check_ident s - | [: :] -> () ] - and check_ident2 = - parser - [ [: `'!' | '?' | '~' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' | - '%' | '.' | ':' | '<' | '>' | '|' - ; - s :] -> - check_ident2 s - | [: :] -> () ] - ; - value check_keyword s = - try check_keyword_stream (Stream.of_string s) with _ -> False - ; - value using_token kwd_table (p_con, p_prm) = - match p_con with - [ "" -> - try - let _ = Hashtbl.find kwd_table p_prm in - () - with - [ Not_found -> - if check_keyword p_prm then Hashtbl.add kwd_table p_prm p_prm - else - raise - (Token.Error - ("the token \"" ^ p_prm ^ - "\" does not respect Plexer rules")) ] - | "LIDENT" | "UIDENT" | "INT" | "FLOAT" | "CHAR" | "STRING" | - "QUOTATION" | "ANTIQUOT" | "LOCATE" | "LABEL" | "ELABEL" | "EOI" -> - () - | _ -> - raise - (Token.Error - ("the constructor \"" ^ p_con ^ - "\" is not recognized by Llexer")) ] - ; - value removing_token kwd_table (p_con, p_prm) = - if p_con = "" then Hashtbl.remove kwd_table p_prm else () - ; - value text = - fun - [ ("", t) -> "'" ^ t ^ "'" - | ("LIDENT", "") -> "lowercase identifier" - | ("LIDENT", t) -> "'" ^ t ^ "'" - | ("UIDENT", "") -> "uppercase identifier" - | ("UIDENT", t) -> "'" ^ t ^ "'" - | ("INT", "") -> "integer" - | ("INT", s) -> "'" ^ s ^ "'" - | ("FLOAT", "") -> "float" - | ("STRING", "") -> "string" - | ("CHAR", "") -> "char" - | ("QUOTATION", "") -> "quotation" - | ("ANTIQUOT", k) -> "antiquot \"" ^ k ^ "\"" - | ("LOCATE", "") -> "locate" - | ("LABEL", "") -> "label" - | ("ELABEL", "") -> "elabel" - | ("EOI", "") -> "end of input" - | (con, "") -> con - | (con, prm) -> con ^ " \"" ^ prm ^ "\"" ] - ; - value eq_before_colon p e = - loop 0 where rec loop i = - if i == String.length e then - failwith "Internal error in Plexer: incorrect ANTIQUOT" - else if i == String.length p then e.[i] == ':' - else if p.[i] == e.[i] then loop (i + 1) - else False - ; - value after_colon e = - try - let i = String.index e ':' in - String.sub e (i + 1) (String.length e - i - 1) - with - [ Not_found -> "" ] - ; - value gmake () = - let kwd_table = Hashtbl.create 301 in - {tok_func = func kwd_table; tok_using = using_token kwd_table; - tok_removing = removing_token kwd_table; - tok_match = Token.default_match; tok_text = text; tok_comm = None} - ; - end -; - -open Stdpp; -open Pcaml; - -Pcaml.no_constructors_arity.val := True; - -do { - Grammar.Unsafe.gram_reinit gram (Plexer.gmake ()); - Grammar.Unsafe.clear_entry interf; - Grammar.Unsafe.clear_entry implem; - Grammar.Unsafe.clear_entry top_phrase; - Grammar.Unsafe.clear_entry use_file; - Grammar.Unsafe.clear_entry module_type; - Grammar.Unsafe.clear_entry module_expr; - Grammar.Unsafe.clear_entry sig_item; - Grammar.Unsafe.clear_entry str_item; - Grammar.Unsafe.clear_entry expr; - Grammar.Unsafe.clear_entry patt; - Grammar.Unsafe.clear_entry ctyp; - Grammar.Unsafe.clear_entry let_binding; - Grammar.Unsafe.clear_entry class_type; - Grammar.Unsafe.clear_entry class_expr; - Grammar.Unsafe.clear_entry class_sig_item; - Grammar.Unsafe.clear_entry class_str_item -}; - -Pcaml.parse_interf.val := Grammar.Entry.parse interf; -Pcaml.parse_implem.val := Grammar.Entry.parse implem; - -value o2b = - fun - [ Some _ -> True - | None -> False ] -; - -value mkumin loc f arg = - match arg with - [ <:expr< $int:n$ >> when int_of_string n > 0 -> - let n = "-" ^ n in - <:expr< $int:n$ >> - | <:expr< $flo:n$ >> when float_of_string n > 0.0 -> - let n = "-" ^ n in - <:expr< $flo:n$ >> - | _ -> - let f = "~" ^ f in - <:expr< $lid:f$ $arg$ >> ] -; - -external loc_of_node : 'a -> (int * int) = "%field0"; - -value mklistexp loc last = - loop True where rec loop top = - fun - [ [] -> - match last with - [ Some e -> e - | None -> <:expr< [] >> ] - | [e1 :: el] -> - let loc = if top then loc else (fst (loc_of_node e1), snd loc) in - <:expr< [$e1$ :: $loop False el$] >> ] -; - -value mklistpat loc last = - loop True where rec loop top = - fun - [ [] -> - match last with - [ Some p -> p - | None -> <:patt< [] >> ] - | [p1 :: pl] -> - let loc = if top then loc else (fst (loc_of_node p1), snd loc) in - <:patt< [$p1$ :: $loop False pl$] >> ] -; - -value neg s = string_of_int (- int_of_string s); - -value is_operator = - let ht = Hashtbl.create 73 in - let ct = Hashtbl.create 73 in - do { - List.iter (fun x -> Hashtbl.add ht x True) - ["asr"; "land"; "lor"; "lsl"; "lsr"; "lxor"; "mod"; "or"]; - List.iter (fun x -> Hashtbl.add ct x True) - ['!'; '&'; '*'; '+'; '-'; '/'; ':'; '<'; '='; '>'; '@'; '^'; '|'; '~'; - '?'; '%'; '.']; - fun x -> - try Hashtbl.find ht x with - [ Not_found -> try Hashtbl.find ct x.[0] with _ -> False ] - } -; - -(* -value p_operator strm = - match Stream.peek strm with - [ Some (Token.Tterm "(") -> - match Stream.npeek 3 strm with - [ [_; Token.Tterm x; Token.Tterm ")"] when is_operator x -> - do { Stream.junk strm; Stream.junk strm; Stream.junk strm; x } - | _ -> raise Stream.Failure ] - | _ -> raise Stream.Failure ] -; - -value operator = Grammar.Entry.of_parser gram "operator" p_operator; -*) - -value operator = - Grammar.Entry.of_parser gram "operator" - (parser [: `("", x) when is_operator x :] -> x) -; - -value symbolchar = - let list = - ['!'; '$'; '%'; '&'; '*'; '+'; '-'; '.'; '/'; ':'; '<'; '='; '>'; '?'; - '@'; '^'; '|'; '~'] - in - let rec loop s i = - if i == String.length s then True - else if List.mem s.[i] list then loop s (i + 1) - else False - in - loop -; - -value prefixop = - let list = ['!'; '?'; '~'] in - let excl = ["!="] in - Grammar.Entry.of_parser gram "prefixop" - (parser - [: `("", x) - when - not (List.mem x excl) && String.length x >= 2 && - List.mem x.[0] list && symbolchar x 1 :] -> - x) -; - -value infixop0 = - let list = ['='; '<'; '>'; '|'; '&'; '$'] in - let excl = ["<-"; "||"; "&&"] in - Grammar.Entry.of_parser gram "infixop0" - (parser - [: `("", x) - when - not (List.mem x excl) && String.length x >= 2 && - List.mem x.[0] list && symbolchar x 1 :] -> - x) -; - -value infixop1 = - let list = ['@'; '^'] in - Grammar.Entry.of_parser gram "infixop1" - (parser - [: `("", x) - when - String.length x >= 2 && List.mem x.[0] list && - symbolchar x 1 :] -> - x) -; - -value infixop2 = - let list = ['+'; '-'] in - Grammar.Entry.of_parser gram "infixop2" - (parser - [: `("", x) - when - x <> "->" && String.length x >= 2 && List.mem x.[0] list && - symbolchar x 1 :] -> - x) -; - -value infixop3 = - let list = ['*'; '/'; '%'] in - Grammar.Entry.of_parser gram "infixop3" - (parser - [: `("", x) - when - String.length x >= 2 && List.mem x.[0] list && - symbolchar x 1 :] -> - x) -; - -value infixop4 = - Grammar.Entry.of_parser gram "infixop4" - (parser - [: `("", x) - when - String.length x >= 3 && x.[0] == '*' && x.[1] == '*' && - symbolchar x 2 :] -> - x) -; - -value test_constr_decl = - Grammar.Entry.of_parser gram "test_constr_decl" - (fun strm -> - match Stream.npeek 1 strm with - [ [("UIDENT", _)] -> - match Stream.npeek 2 strm with - [ [_; ("", ".")] -> raise Stream.Failure - | [_; ("", "(")] -> raise Stream.Failure - | [_ :: _] -> () - | _ -> raise Stream.Failure ] - | [("", "|")] -> () - | _ -> raise Stream.Failure ]) -; - -value stream_peek_nth n strm = - loop n (Stream.npeek n strm) where rec loop n = - fun - [ [] -> None - | [x] -> if n == 1 then Some x else None - | [_ :: l] -> loop (n - 1) l ] -; - -value test_label_eq = - let rec test lev strm = - match stream_peek_nth lev strm with - [ Some (("UIDENT", _) | ("LIDENT", _) | ("", ".")) -> test (lev + 1) strm - | Some ("", "=") -> () - | _ -> raise Stream.Failure ] - in - Grammar.Entry.of_parser gram "test_label_eq" (test 1) -; - -value constr_arity = ref [("Some", 1); ("Match_Failure", 1)]; - -value rec constr_expr_arity = - fun - [ <:expr< $uid:c$ >> -> - try List.assoc c constr_arity.val with [ Not_found -> 0 ] - | <:expr< $uid:_$.$e$ >> -> constr_expr_arity e - | _ -> 1 ] -; - -value rec constr_patt_arity = - fun - [ <:patt< $uid:c$ >> -> - try List.assoc c constr_arity.val with [ Not_found -> 0 ] - | <:patt< $uid:_$.$p$ >> -> constr_patt_arity p - | _ -> 1 ] -; - -value rec get_seq = - fun - [ <:expr< do { $list:el$ } >> -> el - | e -> [e] ] -; - -value choose_tvar tpl = - let rec find_alpha v = - let s = String.make 1 v in - if List.mem_assoc s tpl then - if v = 'z' then None else find_alpha (Char.chr (Char.code v + 1)) - else Some (String.make 1 v) - in - let rec make_n n = - let v = "a" ^ string_of_int n in - if List.mem_assoc v tpl then make_n (succ n) else v - in - match find_alpha 'a' with - [ Some x -> x - | None -> make_n 1 ] -; - -value rec patt_lid = - fun - [ <:patt< $lid:i$ $p$ >> -> Some (i, [p]) - | <:patt< $p1$ $p2$ >> -> - match patt_lid p1 with - [ Some (i, pl) -> Some (i, [p2 :: pl]) - | None -> None ] - | _ -> None ] -; - -value type_parameter = Grammar.Entry.create gram "type_parameter"; -value fun_def = Grammar.Entry.create gram "fun_def"; -value fun_binding = Grammar.Entry.create gram "fun_binding"; - -EXTEND - GLOBAL: interf implem top_phrase use_file sig_item str_item ctyp patt expr - module_type module_expr let_binding type_parameter fun_def fun_binding; - (* Main entry points *) - interf: - [ [ st = LIST0 [ s = sig_item; OPT ";;" -> (s, loc) ]; EOI -> - (st, False) ] ] - ; - implem: - [ [ st = LIST0 [ s = str_item; OPT ";;" -> (s, loc) ]; EOI -> - (st, False) ] ] - ; - top_phrase: - [ [ ph = phrase; ";;" -> Some ph - | EOI -> None ] ] - ; - use_file: - [ [ l = LIST0 [ ph = phrase; OPT ";;" -> ph ]; EOI -> (l, False) ] ] - ; - phrase: - [ [ sti = str_item -> sti - | "#"; n = LIDENT; dp = dir_param -> MLast.StDir loc n dp ] ] - ; - dir_param: - [ [ -> None - | e = expr -> Some e ] ] - ; - (* Module expressions *) - module_expr: - [ [ "functor"; "("; i = UIDENT; ":"; t = module_type; ")"; "->"; - me = SELF -> - <:module_expr< functor ( $i$ : $t$ ) -> $me$ >> - | "struct"; st = LIST0 [ s = str_item; OPT ";;" -> s ]; "end" -> - <:module_expr< struct $list:st$ end >> ] - | [ me1 = SELF; me2 = SELF -> <:module_expr< $me1$ $me2$ >> ] - | [ i = mod_expr_ident -> i - | "("; me = SELF; ":"; mt = module_type; ")" -> - <:module_expr< ( $me$ : $mt$ ) >> - | "("; me = SELF; ")" -> <:module_expr< $me$ >> ] ] - ; - mod_expr_ident: - [ LEFTA - [ m1 = SELF; "."; m2 = SELF -> <:module_expr< $m1$ . $m2$ >> ] - | [ m = UIDENT -> <:module_expr< $uid:m$ >> ] ] - ; - str_item: - [ "top" - [ "exception"; (_, c, tl) = constructor_declaration -> - <:str_item< exception $c$ of $list:tl$ >> - | "external"; i = LIDENT; ":"; t = ctyp; "="; pd = LIST1 STRING -> - <:str_item< external $i$ : $t$ = $list:pd$ >> - | "external"; i = LABEL; t = ctyp; "="; pd = LIST1 STRING -> - <:str_item< external $i$ : $t$ = $list:pd$ >> - | "external"; "("; i = operator; ")"; ":"; t = ctyp; "="; - pd = LIST1 STRING -> - <:str_item< external $i$ : $t$ = $list:pd$ >> - | "module"; i = UIDENT; mb = module_binding -> - <:str_item< module $i$ = $mb$ >> - | "module"; "type"; i = UIDENT; "="; mt = module_type -> - <:str_item< module type $i$ = $mt$ >> - | "open"; i = mod_ident -> <:str_item< open $i$ >> - | "type"; tdl = LIST1 type_declaration SEP "and" -> - <:str_item< type $list:tdl$ >> - | "let"; r = OPT "rec"; l = LIST1 let_binding SEP "and"; "in"; - x = expr -> - let e = <:expr< let $opt:o2b r$ $list:l$ in $x$ >> in - <:str_item< $exp:e$ >> - | "let"; r = OPT "rec"; l = LIST1 let_binding SEP "and" -> - match l with - [ [(<:patt< _ >>, e)] -> <:str_item< $exp:e$ >> - | _ -> <:str_item< value $opt:o2b r$ $list:l$ >> ] - | "let"; "module"; m = UIDENT; mb = module_binding; "in"; e = expr -> - <:str_item< let module $m$ = $mb$ in $e$ >> - | e = expr -> <:str_item< $exp:e$ >> ] ] - ; - module_binding: - [ RIGHTA - [ "("; m = UIDENT; ":"; mt = module_type; ")"; mb = SELF -> - <:module_expr< functor ( $m$ : $mt$ ) -> $mb$ >> - | ":"; mt = module_type; "="; me = module_expr -> - <:module_expr< ( $me$ : $mt$ ) >> - | "="; me = module_expr -> <:module_expr< $me$ >> ] ] - ; - (* Module types *) - module_type: - [ [ "functor"; "("; i = UIDENT; ":"; t = SELF; ")"; "->"; mt = SELF -> - <:module_type< functor ( $i$ : $t$ ) -> $mt$ >> ] - | [ mt = SELF; "with"; wcl = LIST1 with_constr SEP "and" -> - <:module_type< $mt$ with $list:wcl$ >> ] - | [ "sig"; sg = LIST0 [ s = sig_item; OPT ";;" -> s ]; "end" -> - <:module_type< sig $list:sg$ end >> - | i = mod_type_ident -> i - | "("; mt = SELF; ")" -> <:module_type< $mt$ >> ] ] - ; - mod_type_ident: - [ LEFTA - [ m1 = SELF; "."; m2 = SELF -> <:module_type< $m1$ . $m2$ >> - | m1 = SELF; "("; m2 = SELF; ")" -> <:module_type< $m1$ $m2$ >> ] - | [ m = UIDENT -> <:module_type< $uid:m$ >> - | m = LIDENT -> <:module_type< $lid:m$ >> ] ] - ; - sig_item: - [ "top" - [ "exception"; (_, c, tl) = constructor_declaration -> - <:sig_item< exception $c$ of $list:tl$ >> - | "external"; i = LIDENT; ":"; t = ctyp; "="; pd = LIST1 STRING -> - <:sig_item< external $i$ : $t$ = $list:pd$ >> - | "external"; i = LABEL; t = ctyp; "="; pd = LIST1 STRING -> - <:sig_item< external $i$ : $t$ = $list:pd$ >> - | "external"; "("; i = operator; ")"; ":"; t = ctyp; "="; - pd = LIST1 STRING -> - <:sig_item< external $i$ : $t$ = $list:pd$ >> - | "include"; mt = module_type -> <:sig_item< include $mt$ >> - | "module"; i = UIDENT; mt = module_declaration -> - <:sig_item< module $i$ : $mt$ >> - | "module"; "type"; i = UIDENT; "="; mt = module_type -> - <:sig_item< module type $i$ = $mt$ >> - | "open"; i = mod_ident -> <:sig_item< open $i$ >> - | "type"; tdl = LIST1 type_declaration SEP "and" -> - <:sig_item< type $list:tdl$ >> - | "val"; i = LIDENT; ":"; t = ctyp -> <:sig_item< value $i$ : $t$ >> - | "val"; i = LABEL; t = ctyp -> <:sig_item< value $i$ : $t$ >> - | "val"; "("; i = operator; ")"; ":"; t = ctyp -> - <:sig_item< value $i$ : $t$ >> ] ] - ; - module_declaration: - [ RIGHTA - [ ":"; mt = module_type -> <:module_type< $mt$ >> - | "("; i = UIDENT; ":"; t = module_type; ")"; mt = SELF -> - <:module_type< functor ( $i$ : $t$ ) -> $mt$ >> ] ] - ; - (* "with" constraints (additional type equations over signature - components) *) - with_constr: - [ [ "type"; tp = type_parameters; i = mod_ident; "="; t = ctyp -> - MLast.WcTyp loc i tp t - | "module"; i = mod_ident; "="; me = module_expr -> - MLast.WcMod loc i me ] ] - ; - (* Core expressions *) - expr: - [ "top" LEFTA - [ e1 = SELF; ";"; e2 = SELF -> - <:expr< do { $list:[e1 :: get_seq e2]$ } >> - | e1 = SELF; ";" -> e1 ] - | "expr1" - [ "let"; o = OPT "rec"; l = LIST1 let_binding SEP "and"; "in"; - x = expr LEVEL "top" -> - <:expr< let $opt:o2b o$ $list:l$ in $x$ >> - | "let"; "module"; m = UIDENT; mb = module_binding; "in"; - e = expr LEVEL "top" -> - <:expr< let module $m$ = $mb$ in $e$ >> - | "function"; OPT "|"; l = LIST1 match_case SEP "|" -> - <:expr< fun [ $list:l$ ] >> - | "fun"; p = patt LEVEL "simple"; e = fun_def -> - <:expr< fun [$p$ -> $e$] >> - | "match"; x = SELF; "with"; OPT "|"; l = LIST1 match_case SEP "|" -> - <:expr< match $x$ with [ $list:l$ ] >> - | "try"; x = SELF; "with"; OPT "|"; l = LIST1 match_case SEP "|" -> - <:expr< try $x$ with [ $list:l$ ] >> - | "if"; e1 = SELF; "then"; e2 = expr LEVEL "expr1"; - e3 = [ "else"; e = expr LEVEL "expr1" -> e | -> <:expr< () >> ] -> - <:expr< if $e1$ then $e2$ else $e3$ >> - | "for"; i = LIDENT; "="; e1 = SELF; df = direction_flag; e2 = SELF; - "do"; e = SELF; "done" -> - <:expr< for $i$ = $e1$ $to:df$ $e2$ do { $list:get_seq e$ } >> - | "while"; e1 = SELF; "do"; e2 = SELF; "done" -> - <:expr< while $e1$ do { $list:get_seq e2$ } >> ] - | [ e = SELF; ","; el = LIST1 NEXT SEP "," -> - <:expr< ( $list:[e :: el]$ ) >> ] - | ":=" NONA - [ e1 = SELF; ":="; e2 = expr LEVEL "expr1" -> - <:expr< $e1$.val := $e2$ >> - | e1 = SELF; "<-"; e2 = expr LEVEL "expr1" -> <:expr< $e1$ := $e2$ >> ] - | "||" RIGHTA - [ e1 = SELF; f = [ op = "or" -> op | op = "||" -> op ]; e2 = SELF -> - <:expr< $lid:f$ $e1$ $e2$ >> ] - | "&&" RIGHTA - [ e1 = SELF; f = [ op = "&" -> op | op = "&&" -> op ]; e2 = SELF -> - <:expr< $lid:f$ $e1$ $e2$ >> ] - | "<" LEFTA - [ e1 = SELF; - f = - [ op = "<" -> op - | op = ">" -> op - | op = "<=" -> op - | op = ">=" -> op - | op = "=" -> op - | op = "<>" -> op - | op = "==" -> op - | op = "!=" -> op - | op = infixop0 -> op ]; - e2 = SELF -> - <:expr< $lid:f$ $e1$ $e2$ >> ] - | "^" RIGHTA - [ e1 = SELF; - f = [ op = "^" -> op | op = "@" -> op | op = infixop1 -> op ]; - e2 = SELF -> - <:expr< $lid:f$ $e1$ $e2$ >> ] - | RIGHTA - [ e1 = SELF; "::"; e2 = SELF -> <:expr< [$e1$ :: $e2$] >> ] - | "+" LEFTA - [ e1 = SELF; - f = - [ op = "+" -> op - | op = "-" -> op - | op = "+." -> op - | op = "-." -> op - | op = infixop2 -> op ]; - e2 = SELF -> - <:expr< $lid:f$ $e1$ $e2$ >> ] - | "*" LEFTA - [ e1 = SELF; - f = - [ op = "*" -> op - | op = "/" -> op - | op = "*." -> op - | op = "/." -> op - | op = "land" -> op - | op = "lor" -> op - | op = "lxor" -> op - | op = "mod" -> op - | op = infixop3 -> op ]; - e2 = SELF -> - <:expr< $lid:f$ $e1$ $e2$ >> ] - | "**" RIGHTA - [ e1 = SELF; - f = - [ op = "**" -> op - | op = "asr" -> op - | op = "lsl" -> op - | op = "lsr" -> op - | op = infixop4 -> op ]; - e2 = SELF -> - <:expr< $lid:f$ $e1$ $e2$ >> ] - | "unary minus" NONA - [ f = [ op = "-" -> op | op = "-." -> op ]; e = SELF -> - <:expr< $mkumin loc f e$ >> ] - | "apply" LEFTA - [ e1 = SELF; e2 = SELF -> - match constr_expr_arity e1 with - [ 1 -> <:expr< $e1$ $e2$ >> - | _ -> - match e2 with - [ <:expr< ( $list:el$ ) >> -> - List.fold_left (fun e1 e2 -> <:expr< $e1$ $e2$ >>) e1 el - | _ -> <:expr< $e1$ $e2$ >> ] ] - | "assert"; e = expr LEVEL "simple" -> - match e with - [ <:expr< False >> -> MLast.ExAsf loc - | _ -> MLast.ExAsr loc e ] - | "lazy"; e = SELF -> - <:expr< lazy ($e$) >> ] - | "simple" LEFTA - [ e1 = SELF; "."; "("; e2 = SELF; ")" -> <:expr< $e1$ .( $e2$ ) >> - | e1 = SELF; "."; "["; e2 = SELF; "]" -> <:expr< $e1$ .[ $e2$ ] >> - | e1 = SELF; "."; e2 = SELF -> <:expr< $e1$ . $e2$ >> - | "!"; e = SELF -> <:expr< $e$ . val>> - | f = - [ op = "~-" -> op - | op = "~-." -> op - | op = "~" -> op - | op = prefixop -> op ]; - e = SELF -> - <:expr< $lid:f$ $e$ >> - | s = INT -> <:expr< $int:s$ >> - | s = FLOAT -> <:expr< $flo:s$ >> - | s = STRING -> <:expr< $str:s$ >> - | c = CHAR -> <:expr< $chr:c$ >> - | i = expr_ident -> i - | s = "false" -> <:expr< False >> - | s = "true" -> <:expr< True >> - | "["; "]" -> <:expr< [] >> - | "["; el = expr1_semi_list; "]" -> <:expr< $mklistexp loc None el$ >> - | "[|"; "|]" -> <:expr< [| |] >> - | "[|"; el = expr1_semi_list; "|]" -> <:expr< [| $list:el$ |] >> - | "{"; test_label_eq; lel = lbl_expr_list; "}" -> - <:expr< { $list:lel$ } >> - | "{"; e = expr LEVEL "simple"; "with"; lel = lbl_expr_list; "}" -> - <:expr< { ($e$) with $list:lel$ } >> - | "("; ")" -> <:expr< () >> - | "("; e = SELF; ":"; t = ctyp; ")" -> <:expr< ($e$ : $t$) >> - | "("; e = SELF; ")" -> <:expr< $e$ >> - | "("; "-"; ")" -> <:expr< $lid:"-"$ >> - | "("; "-."; ")" -> <:expr< $lid:"-."$ >> - | "("; op = operator; ")" -> <:expr< $lid:op$ >> - | "begin"; e = SELF; "end" -> <:expr< $e$ >> - | x = LOCATE -> - let x = - try - let i = String.index x ':' in - (int_of_string (String.sub x 0 i), - String.sub x (i + 1) (String.length x - i - 1)) - with - [ Not_found | Failure _ -> (0, x) ] - in - Pcaml.handle_expr_locate loc x - | x = QUOTATION -> - let x = - try - let i = String.index x ':' in - (String.sub x 0 i, - String.sub x (i + 1) (String.length x - i - 1)) - with - [ Not_found -> ("", x) ] - in - Pcaml.handle_expr_quotation loc x ] ] - ; - let_binding: - [ [ p = patt; e = fun_binding -> - match patt_lid p with - [ Some (i, pl) -> - let e = - List.fold_left (fun e p -> <:expr< fun $p$ -> $e$ >>) e pl - in - (<:patt< $lid:i$ >>, e) - | None -> (p, e) ] ] ] - ; - fun_binding: - [ RIGHTA - [ p = patt LEVEL "simple"; e = SELF -> <:expr< fun $p$ -> $e$ >> - | "="; e = expr -> <:expr< $e$ >> - | ":"; t = ctyp; "="; e = expr -> <:expr< ($e$ : $t$) >> ] ] - ; - match_case: - [ [ x1 = patt; w = OPT [ "when"; e = expr -> e ]; "->"; x2 = expr -> - (x1, w, x2) ] ] - ; - lbl_expr_list: - [ [ le = lbl_expr; ";"; lel = SELF -> [le :: lel] - | le = lbl_expr; ";" -> [le] - | le = lbl_expr -> [le] ] ] - ; - lbl_expr: - [ [ i = patt_label_ident; "="; e = expr LEVEL "expr1" -> (i, e) ] ] - ; - expr1_semi_list: - [ [ e = expr LEVEL "expr1"; ";"; el = SELF -> [e :: el] - | e = expr LEVEL "expr1"; ";" -> [e] - | e = expr LEVEL "expr1" -> [e] ] ] - ; - fun_def: - [ RIGHTA - [ p = patt LEVEL "simple"; e = SELF -> <:expr< fun $p$ -> $e$ >> - | "->"; e = expr -> <:expr< $e$ >> ] ] - ; - expr_ident: - [ RIGHTA - [ i = LIDENT -> <:expr< $lid:i$ >> - | i = UIDENT -> <:expr< $uid:i$ >> - | m = UIDENT; "."; i = SELF -> - let rec loop m = - fun - [ <:expr< $x$ . $y$ >> -> loop <:expr< $m$ . $x$ >> y - | e -> <:expr< $m$ . $e$ >> ] - in - loop <:expr< $uid:m$ >> i - | m = UIDENT; "."; "("; i = operator; ")" -> - <:expr< $uid:m$ . $lid:i$ >> ] ] - ; - (* Patterns *) - patt: - [ LEFTA - [ p1 = SELF; "as"; i = LIDENT -> <:patt< ($p1$ as $lid:i$) >> ] - | LEFTA - [ p1 = SELF; "|"; p2 = SELF -> <:patt< $p1$ | $p2$ >> ] - | [ p = SELF; ","; pl = LIST1 NEXT SEP "," -> - <:patt< ( $list:[p :: pl]$) >> ] - | NONA - [ p1 = SELF; ".."; p2 = SELF -> <:patt< $p1$ .. $p2$ >> ] - | RIGHTA - [ p1 = SELF; "::"; p2 = SELF -> <:patt< [$p1$ :: $p2$] >> ] - | LEFTA - [ p1 = SELF; p2 = SELF -> - match constr_patt_arity p1 with - [ 1 -> <:patt< $p1$ $p2$ >> - | n -> - let p2 = - match p2 with - [ <:patt< _ >> when n > 1 -> - let pl = - loop n where rec loop n = - if n = 0 then [] else [<:patt< _ >> :: loop (n - 1)] - in - <:patt< ( $list:pl$ ) >> - | _ -> p2 ] - in - match p2 with - [ <:patt< ( $list:pl$ ) >> -> - List.fold_left (fun p1 p2 -> <:patt< $p1$ $p2$ >>) p1 pl - | _ -> <:patt< $p1$ $p2$ >> ] ] ] - | LEFTA - [ p1 = SELF; "."; p2 = SELF -> <:patt< $p1$ . $p2$ >> ] - | "simple" - [ s = LIDENT -> <:patt< $lid:s$ >> - | s = UIDENT -> <:patt< $uid:s$ >> - | s = INT -> <:patt< $int:s$ >> - | "-"; s = INT -> <:patt< $int:neg s$ >> - | s = STRING -> <:patt< $str:s$ >> - | s = CHAR -> <:patt< $chr:s$ >> - | s = "false" -> <:patt< False >> - | s = "true" -> <:patt< True >> - | "["; "]" -> <:patt< [] >> - | "["; pl = patt_semi_list; "]" -> <:patt< $mklistpat loc None pl$ >> - | "[|"; "|]" -> <:patt< [| |] >> - | "[|"; pl = patt_semi_list; "|]" -> <:patt< [| $list:pl$ |] >> - | "{"; lpl = lbl_patt_list; "}" -> <:patt< { $list:lpl$ } >> - | "("; ")" -> <:patt< () >> - | "("; p = SELF; ":"; t = ctyp; ")" -> <:patt< ($p$ : $t$) >> - | "("; p = SELF; ")" -> <:patt< $p$ >> - | "("; "-"; ")" -> <:patt< $lid:"-"$ >> - | "("; op = operator; ")" -> <:patt< $lid:op$ >> - | "_" -> <:patt< _ >> - | x = LOCATE -> - let x = - try - let i = String.index x ':' in - (int_of_string (String.sub x 0 i), - String.sub x (i + 1) (String.length x - i - 1)) - with - [ Not_found | Failure _ -> (0, x) ] - in - Pcaml.handle_patt_locate loc x - | x = QUOTATION -> - let x = - try - let i = String.index x ':' in - (String.sub x 0 i, - String.sub x (i + 1) (String.length x - i - 1)) - with - [ Not_found -> ("", x) ] - in - Pcaml.handle_patt_quotation loc x ] ] - ; - patt_semi_list: - [ [ p = patt; ";"; pl = SELF -> [p :: pl] - | p = patt; ";" -> [p] - | p = patt -> [p] ] ] - ; - lbl_patt_list: - [ [ le = lbl_patt; ";"; lel = SELF -> [le :: lel] - | le = lbl_patt; ";" -> [le] - | le = lbl_patt -> [le] ] ] - ; - lbl_patt: - [ [ i = patt_label_ident; "="; p = patt -> (i, p) ] ] - ; - patt_label_ident: - [ RIGHTA - [ i = UIDENT -> <:patt< $uid:i$ >> - | i = LIDENT -> <:patt< $lid:i$ >> - | m = UIDENT; "."; i = SELF -> <:patt< $uid:m$ . $i$ >> ] ] - ; - (* Type declaration *) - type_declaration: - [ [ tpl = type_parameters; n = type_patt; "="; tk = type_kind; - cl = LIST0 constrain -> - (n, tpl, tk, cl) - | tpl = type_parameters; n = type_patt; cl = LIST0 constrain -> - (n, tpl, <:ctyp< '$choose_tvar tpl$ >>, cl) ] ] - ; - type_patt: - [ [ n = LIDENT -> (loc, n) ] ] - ; - constrain: - [ [ "constraint"; t1 = ctyp; "="; t2 = ctyp -> (t1, t2) ] ] - ; - type_kind: - [ [ test_constr_decl; OPT "|"; - cdl = LIST1 constructor_declaration SEP "|" -> - <:ctyp< [ $list:cdl$ ] >> - | t = ctyp -> <:ctyp< $t$ >> - | t = ctyp; "="; "{"; ldl = label_declarations; "}" -> - <:ctyp< $t$ == { $list:ldl$ } >> - | t = ctyp; "="; OPT "|"; cdl = LIST1 constructor_declaration SEP "|" -> - <:ctyp< $t$ == [ $list:cdl$ ] >> - | "{"; ldl = label_declarations; "}" -> <:ctyp< { $list:ldl$ } >> ] ] - ; - type_parameters: - [ [ -> (* empty *) [] - | tp = type_parameter -> [tp] - | "("; tpl = LIST1 type_parameter SEP ","; ")" -> tpl ] ] - ; - type_parameter: - [ [ "'"; i = ident -> (i, (False, False)) ] ] - ; - constructor_declaration: - [ [ ci = UIDENT; "of"; cal = LIST1 ctyp LEVEL "ctyp1" SEP "*" -> - (loc, ci, cal) - | ci = UIDENT -> (loc, ci, []) ] ] - ; - label_declarations: - [ [ ld = label_declaration; ";"; ldl = SELF -> [ld :: ldl] - | ld = label_declaration; ";" -> [ld] - | ld = label_declaration -> [ld] ] ] - ; - label_declaration: - [ [ i = LIDENT; ":"; t = ctyp -> (loc, i, False, t) - | i = LABEL; t = ctyp -> (loc, i, False, t) - | "mutable"; i = LIDENT; ":"; t = ctyp -> (loc, i, True, t) - | "mutable"; i = LABEL; t = ctyp -> (loc, i, True, t) ] ] - ; - (* Core types *) - ctyp: - [ [ t1 = SELF; "as"; "'"; i = ident -> <:ctyp< $t1$ as '$i$ >> ] - | "arrow" RIGHTA - [ t1 = SELF; "->"; t2 = SELF -> <:ctyp< $t1$ -> $t2$ >> ] - | [ t = SELF; "*"; tl = LIST1 ctyp LEVEL "ctyp1" SEP "*" -> - <:ctyp< ( $list:[t :: tl]$ ) >> ] - | "ctyp1" - [ t1 = SELF; t2 = SELF -> <:ctyp< $t2$ $t1$ >> ] - | "ctyp2" - [ t1 = SELF; "."; t2 = SELF -> <:ctyp< $t1$ . $t2$ >> - | t1 = SELF; "("; t2 = SELF; ")" -> <:ctyp< $t1$ $t2$ >> ] - | "simple" - [ "'"; i = ident -> <:ctyp< '$i$ >> - | "_" -> <:ctyp< _ >> - | i = LIDENT -> <:ctyp< $lid:i$ >> - | i = UIDENT -> <:ctyp< $uid:i$ >> - | "("; t = SELF; ","; tl = LIST1 ctyp SEP ","; ")"; - i = ctyp LEVEL "ctyp2" -> - List.fold_left (fun c a -> <:ctyp< $c$ $a$ >>) i [t :: tl] - | "("; t = SELF; ")" -> <:ctyp< $t$ >> ] ] - ; - (* Identifiers *) - ident: - [ [ i = LIDENT -> i - | i = UIDENT -> i ] ] - ; - mod_ident: - [ RIGHTA - [ i = UIDENT -> [i] - | i = LIDENT -> [i] - | m = UIDENT; "."; i = SELF -> [m :: i] ] ] - ; - (* Miscellaneous *) - direction_flag: - [ [ "to" -> True - | "downto" -> False ] ] - ; -END; - -(* Objects and Classes *) - -value rec class_type_of_ctyp loc t = - match t with - [ <:ctyp< $lid:i$ >> -> <:class_type< $list:[i]$ >> - | <:ctyp< $uid:m$.$t$ >> -> <:class_type< $list:[m :: type_id_list t]$ >> - | _ -> raise_with_loc loc (Stream.Error "lowercase identifier expected") ] -and type_id_list = - fun - [ <:ctyp< $uid:m$.$t$ >> -> [m :: type_id_list t] - | <:ctyp< $lid:i$ >> -> [i] - | t -> - raise_with_loc (loc_of_node t) - (Stream.Error "lowercase identifier expected") ] -; - -value class_fun_binding = Grammar.Entry.create gram "class_fun_binding"; - -EXTEND - GLOBAL: str_item sig_item expr ctyp class_sig_item class_str_item class_type - class_expr class_fun_binding; - str_item: - [ [ "class"; cd = LIST1 class_declaration SEP "and" -> - <:str_item< class $list:cd$ >> - | "class"; "type"; ctd = LIST1 class_type_declaration SEP "and" -> - <:str_item< class type $list:ctd$ >> ] ] - ; - sig_item: - [ [ "class"; cd = LIST1 class_description SEP "and" -> - <:sig_item< class $list:cd$ >> - | "class"; "type"; ctd = LIST1 class_type_declaration SEP "and" -> - <:sig_item< class type $list:ctd$ >> ] ] - ; - (* Class expressions *) - class_declaration: - [ [ vf = OPT "virtual"; ctp = class_type_parameters; i = LIDENT; - cfb = class_fun_binding -> - {MLast.ciLoc = loc; MLast.ciVir = o2b vf; MLast.ciPrm = ctp; - MLast.ciNam = i; MLast.ciExp = cfb} ] ] - ; - class_fun_binding: - [ [ "="; ce = class_expr -> ce - | ":"; ct = class_type; "="; ce = class_expr -> - <:class_expr< ($ce$ : $ct$) >> - | p = patt LEVEL "simple"; cfb = SELF -> - <:class_expr< fun $p$ -> $cfb$ >> ] ] - ; - class_type_parameters: - [ [ -> (loc, []) - | "["; tpl = LIST1 type_parameter SEP ","; "]" -> (loc, tpl) ] ] - ; - class_fun_def: - [ [ p = patt LEVEL "simple"; "->"; ce = class_expr -> - <:class_expr< fun $p$ -> $ce$ >> - | p = patt LEVEL "simple"; cfd = SELF -> - <:class_expr< fun $p$ -> $cfd$ >> ] ] - ; - class_expr: - [ "top" - [ "fun"; cfd = class_fun_def -> cfd - | "let"; rf = OPT "rec"; lb = LIST1 let_binding SEP "and"; "in"; - ce = SELF -> - <:class_expr< let $opt:o2b rf$ $list:lb$ in $ce$ >> ] - | "apply" NONA - [ ce = SELF; e = expr LEVEL "label" -> - <:class_expr< $ce$ $e$ >> ] - | "simple" - [ "["; ct = ctyp; ","; ctcl = LIST1 ctyp SEP ","; "]"; - ci = class_longident -> - <:class_expr< $list:ci$ [ $list:[ct :: ctcl]$ ] >> - | "["; ct = ctyp; "]"; ci = class_longident -> - <:class_expr< $list:ci$ [ $ct$ ] >> - | ci = class_longident -> <:class_expr< $list:ci$ >> - | "object"; cspo = OPT class_self_patt; cf = class_structure; "end" -> - <:class_expr< object $opt:cspo$ $list:cf$ end >> - | "("; ce = SELF; ":"; ct = class_type; ")" -> - <:class_expr< ($ce$ : $ct$) >> - | "("; ce = SELF; ")" -> ce ] ] - ; - class_structure: - [ [ cf = LIST0 class_str_item -> cf ] ] - ; - class_self_patt: - [ [ "("; p = patt; ")" -> p - | "("; p = patt; ":"; t = ctyp; ")" -> <:patt< ($p$ : $t$) >> ] ] - ; - class_str_item: - [ [ "inherit"; ce = class_expr; pb = OPT [ "as"; i = LIDENT -> i ] -> - <:class_str_item< inherit $ce$ $opt:pb$ >> - | "val"; (lab, mf, e) = cvalue -> - <:class_str_item< value $opt:mf$ $lab$ = $e$ >> - | "method"; "private"; "virtual"; l = label; ":"; t = ctyp -> - <:class_str_item< method virtual private $l$ : $t$ >> - | "method"; "virtual"; "private"; l = label; ":"; t = ctyp -> - <:class_str_item< method virtual private $l$ : $t$ >> - | "method"; "virtual"; l = label; ":"; t = ctyp -> - <:class_str_item< method virtual $l$ : $t$ >> - | "method"; "private"; l = label; fb = fun_binding -> - <:class_str_item< method private $l$ = $fb$ >> - | "method"; l = label; fb = fun_binding -> - <:class_str_item< method $l$ = $fb$ >> - | "constraint"; t1 = ctyp; "="; t2 = ctyp -> - <:class_str_item< type $t1$ = $t2$ >> - | "initializer"; se = expr -> <:class_str_item< initializer $se$ >> ] ] - ; - cvalue: - [ [ mf = OPT "mutable"; l = label; "="; e = expr -> (l, o2b mf, e) - | mf = OPT "mutable"; l = label; ":"; t = ctyp; "="; e = expr -> - (l, o2b mf, <:expr< ($e$ : $t$) >>) - | mf = OPT "mutable"; l = label; ":"; t1 = ctyp; ":>"; t2 = ctyp; "="; - e = expr -> - (l, o2b mf, <:expr< ($e$ : $t1$ :> $t2$) >>) - | mf = OPT "mutable"; l = label; ":>"; t = ctyp; "="; e = expr -> - (l, o2b mf, <:expr< ($e$ :> $t$) >>) ] ] - ; - label: - [ [ i = LIDENT -> i ] ] - ; - (* Class types *) - class_type: - [ [ t = ctyp LEVEL "ctyp1" -> class_type_of_ctyp loc t - | t = ctyp LEVEL "ctyp1"; "->"; ct = SELF -> - <:class_type< [ $t$ ] -> $ct$ >> - | t = ctyp LEVEL "ctyp1"; "*"; tl = LIST1 ctyp LEVEL "simple" SEP "*"; - "->"; ct = SELF -> - <:class_type< [ ($t$ * $list:tl$) ] -> $ct$ >> - | cs = class_signature -> cs ] ] - ; - class_signature: - [ [ "["; tl = LIST1 ctyp SEP ","; "]"; id = clty_longident -> - <:class_type< $list:id$ [ $list:tl$ ] >> - | id = clty_longident -> <:class_type< $list:id$ >> - | "object"; cst = OPT class_self_type; csf = LIST0 class_sig_item; - "end" -> - <:class_type< object $opt:cst$ $list:csf$ end >> ] ] - ; - class_self_type: - [ [ "("; t = ctyp; ")" -> t ] ] - ; - class_sig_item: - [ [ "inherit"; cs = class_signature -> <:class_sig_item< inherit $cs$ >> - | "val"; mf = OPT "mutable"; l = label; ":"; t = ctyp -> - <:class_sig_item< value $opt:o2b mf$ $l$ : $t$ >> - | "method"; "private"; "virtual"; l = label; ":"; t = ctyp -> - <:class_sig_item< method virtual private $l$ : $t$ >> - | "method"; "virtual"; "private"; l = label; ":"; t = ctyp -> - <:class_sig_item< method virtual private $l$ : $t$ >> - | "method"; "virtual"; l = label; ":"; t = ctyp -> - <:class_sig_item< method virtual $l$ : $t$ >> - | "method"; "private"; l = label; ":"; t = ctyp -> - <:class_sig_item< method private $l$ : $t$ >> - | "method"; l = label; ":"; t = ctyp -> - <:class_sig_item< method $l$ : $t$ >> - | "constraint"; t1 = ctyp; "="; t2 = ctyp -> - <:class_sig_item< type $t1$ = $t2$ >> ] ] - ; - class_description: - [ [ vf = OPT "virtual"; ctp = class_type_parameters; n = LIDENT; ":"; - ct = class_type -> - {MLast.ciLoc = loc; MLast.ciVir = o2b vf; MLast.ciPrm = ctp; - MLast.ciNam = n; MLast.ciExp = ct} - | vf = OPT "virtual"; ctp = class_type_parameters; n = LABEL; - ct = class_type -> - {MLast.ciLoc = loc; MLast.ciVir = o2b vf; MLast.ciPrm = ctp; - MLast.ciNam = n; MLast.ciExp = ct} ] ] - ; - class_type_declaration: - [ [ vf = OPT "virtual"; ctp = class_type_parameters; n = LIDENT; "="; - cs = class_signature -> - {MLast.ciLoc = loc; MLast.ciVir = o2b vf; MLast.ciPrm = ctp; - MLast.ciNam = n; MLast.ciExp = cs} ] ] - ; - (* Expressions *) - expr: LEVEL "apply" - [ LEFTA - [ "new"; i = class_longident -> <:expr< new $list:i$ >> ] ] - ; - expr: LEVEL "simple" - [ [ e = SELF; "#"; lab = label -> <:expr< $e$ # $lab$ >> ] ] - ; - expr: LEVEL "simple" - [ [ "("; e = SELF; ":"; t1 = ctyp; ":>"; t2 = ctyp; ")" -> - <:expr< ($e$ : $t1$ :> $t2$) >> - | "("; e = SELF; ":>"; t = ctyp; ")" -> <:expr< ($e$ :> $t$) >> - | "{<"; ">}" -> <:expr< {< >} >> - | "{<"; fel = field_expr_list; ">}" -> <:expr< {< $list:fel$ >} >> ] ] - ; - field_expr_list: - [ [ l = label; "="; e = expr LEVEL "expr1"; ";"; fel = SELF -> - [(l, e) :: fel] - | l = label; "="; e = expr LEVEL "expr1"; ";" -> [(l, e)] - | l = label; "="; e = expr LEVEL "expr1" -> [(l, e)] ] ] - ; - (* Core types *) - ctyp: LEVEL "simple" - [ [ "#"; id = class_longident -> <:ctyp< # $list:id$ >> - | "<"; (ml, v) = meth_list; ">" -> <:ctyp< < $list:ml$ $opt:v$ > >> - | "<"; ">" -> <:ctyp< < > >> ] ] - ; - meth_list: - [ [ f = field; ";"; (ml, v) = SELF -> ([f :: ml], v) - | f = field; ";" -> ([f], False) - | f = field -> ([f], False) - | ".." -> ([], True) ] ] - ; - field: - [ [ lab = LIDENT; ":"; t = ctyp -> (lab, t) - | lab = LABEL; t = ctyp -> (lab, t) ] ] - ; - (* Identifiers *) - clty_longident: - [ [ m = UIDENT; "."; l = SELF -> [m :: l] - | i = LIDENT -> [i] ] ] - ; - class_longident: - [ [ m = UIDENT; "."; l = SELF -> [m :: l] - | i = LIDENT -> [i] ] ] - ; -END; - -(* Labels *) - -EXTEND - GLOBAL: ctyp expr patt fun_def fun_binding class_type class_fun_binding; - ctyp: AFTER "arrow" - [ NONA - [ i = LABEL; t = SELF -> <:ctyp< ~ $i$ : $t$ >> - | "?"; i = LABEL; t = SELF -> <:ctyp< ? $i$ : $t$ >> ] ] - ; - ctyp: LEVEL "simple" - [ [ "["; OPT "|"; rfl = LIST0 row_field SEP "|"; "]" -> - <:ctyp< [ = $list:rfl$ ] >> - | "["; ">"; OPT "|"; rfl = LIST1 row_field SEP "|"; "]" -> - <:ctyp< [ > $list:rfl$ ] >> - | "[<"; OPT "|"; rfl = LIST1 row_field SEP "|"; "]" -> - <:ctyp< [ < $list:rfl$ ] >> - | "[<"; OPT "|"; rfl = LIST1 row_field SEP "|"; ">"; - ntl = LIST1 name_tag; "]" -> - <:ctyp< [ < $list:rfl$ > $list:ntl$ ] >> ] ] - ; - row_field: - [ [ "`"; i = ident -> MLast.RfTag i False [] - | "`"; i = ident; "of"; ao = OPT "&"; l = LIST1 ctyp SEP "&" -> - MLast.RfTag i (o2b ao) l - | "`"; i = ident; "&"; l = LIST1 ctyp SEP "&" -> MLast.RfTag i True l - | "`"; i = ident; l = LIST1 ctyp SEP "&" -> MLast.RfTag i False l ] ] - ; - name_tag: - [ [ "`"; i = ident -> i ] ] - ; - expr: LEVEL "expr1" - [ [ "fun"; p = labeled_patt; e = fun_def -> <:expr< fun $p$ -> $e$ >> ] ] - ; - expr: AFTER "apply" - [ "label" - [ i = LABEL; e = SELF -> <:expr< ~ $i$ : $e$ >> - | i = ELABEL -> <:expr< ~ $i$ >> - | "?"; i = LABEL; e = SELF -> <:expr< ? $i$ : $e$ >> - | "?"; i = ELABEL -> <:expr< ? $i$ >> ] ] - ; - expr: LEVEL "simple" - [ [ "`"; s = ident -> <:expr< ` $s$ >> ] ] - ; - fun_def: - [ [ p = labeled_patt; e = SELF -> <:expr< fun $p$ -> $e$ >> ] ] - ; - fun_binding: - [ [ p = labeled_patt; e = SELF -> <:expr< fun $p$ -> $e$ >> ] ] - ; - patt: LEVEL "simple" - [ [ "`"; s = ident -> <:patt< ` $s$ >> ] ] - ; - labeled_patt: - [ [ i = LABEL; p = patt LEVEL "simple" -> <:patt< ~ $i$ : $p$ >> - | i = ELABEL -> <:patt< ~ $i$ >> - | "?"; i = LABEL; j = LIDENT -> <:patt< ? $i$ : ($lid:j$) >> - | "?"; "("; i = LABEL; j = LIDENT; ")" -> <:patt< ? $i$ : ($lid:j$) >> - | "?"; "("; i = LABEL; j = LIDENT; "="; e = expr; ")" -> - <:patt< ? $i$ : ( $lid:j$ = $e$ ) >> - | "?"; i = ELABEL -> <:patt< ? $i$ : ($lid:i$) >> - | "?"; "("; i = ELABEL; "="; e = expr; ")" -> - <:patt< ? $i$ : ( $lid:i$ = $e$ ) >> ] ] - ; - class_type: - [ [ i = LABEL; t = ctyp LEVEL "ctyp1"; "->"; ct = SELF -> - <:class_type< [ ~ $i$ : $t$ ] -> $ct$ >> - | "?"; i = LABEL; t = ctyp LEVEL "ctyp1"; "->"; ct = SELF -> - <:class_type< [ ? $i$ : $t$ ] -> $ct$ >> ] ] - ; - class_fun_binding: - [ [ p = labeled_patt; cfb = SELF -> <:class_expr< fun $p$ -> $cfb$ >> ] ] - ; - ident: - [ [ i = LIDENT -> i - | i = UIDENT -> i ] ] - ; -END; - -type spat_comp = - [ SpTrm of MLast.loc and MLast.patt and option MLast.expr - | SpNtr of MLast.loc and MLast.patt and MLast.expr - | SpStr of MLast.loc and MLast.patt ] -; -type sexp_comp = - [ SeTrm of MLast.loc and MLast.expr | SeNtr of MLast.loc and MLast.expr ] -; - -value strm_n = "strm__"; -value peek_fun loc = <:expr< Stream.peek >>; -value junk_fun loc = <:expr< Stream.junk >>; - -(* Parsers. *) -(* In syntax generated, many cases are optimisations. *) - -value rec pattern_eq_expression p e = - match (p, e) with - [ (<:patt< $lid:a$ >>, <:expr< $lid:b$ >>) -> a = b - | (<:patt< $uid:a$ >>, <:expr< $uid:b$ >>) -> a = b - | (<:patt< $p1$ $p2$ >>, <:expr< $e1$ $e2$ >>) -> - pattern_eq_expression p1 e1 && pattern_eq_expression p2 e2 - | _ -> False ] -; - -value is_raise e = - match e with - [ <:expr< raise $_$ >> -> True - | _ -> False ] -; - -value is_raise_failure e = - match e with - [ <:expr< raise Stream.Failure >> -> True - | _ -> False ] -; - -value rec handle_failure e = - match e with - [ <:expr< try $te$ with [ Stream.Failure -> $e$] >> -> handle_failure e - | <:expr< match $me$ with [ $list:pel$ ] >> -> - handle_failure me && - List.for_all - (fun - [ (_, None, e) -> handle_failure e - | _ -> False ]) - pel - | <:expr< let $list:pel$ in $e$ >> -> - List.for_all (fun (p, e) -> handle_failure e) pel && handle_failure e - | <:expr< $lid:_$ >> | <:expr< $int:_$ >> | <:expr< $str:_$ >> | - <:expr< $chr:_$ >> | <:expr< fun [ $list:_$ ] >> | <:expr< $uid:_$ >> -> - True - | <:expr< raise $e$ >> -> - match e with - [ <:expr< Stream.Failure >> -> False - | _ -> True ] - | <:expr< $f$ $x$ >> -> - is_constr_apply f && handle_failure f && handle_failure x - | _ -> False ] -and is_constr_apply = - fun - [ <:expr< $uid:_$ >> -> True - | <:expr< $lid:_$ >> -> False - | <:expr< $x$ $_$ >> -> is_constr_apply x - | _ -> False ] -; - -value rec subst v e = - let loc = MLast.loc_of_expr e in - match e with - [ <:expr< $lid:x$ >> -> - let x = if x = v then strm_n else x in - <:expr< $lid:x$ >> - | <:expr< $uid:_$ >> -> e - | <:expr< $int:_$ >> -> e - | <:expr< $chr:_$ >> -> e - | <:expr< $str:_$ >> -> e - | <:expr< $_$ . $_$ >> -> e - | <:expr< let $opt:rf$ $list:pel$ in $e$ >> -> - <:expr< let $opt:rf$ $list:List.map (subst_pe v) pel$ in $subst v e$ >> - | <:expr< $e1$ $e2$ >> -> <:expr< $subst v e1$ $subst v e2$ >> - | <:expr< ( $list:el$ ) >> -> <:expr< ( $list:List.map (subst v) el$ ) >> - | _ -> raise Not_found ] -and subst_pe v (p, e) = - match p with - [ <:patt< $lid:v'$ >> -> if v = v' then (p, e) else (p, subst v e) - | _ -> raise Not_found ] -; - -value stream_pattern_component skont ckont = - fun - [ SpTrm loc p wo -> - <:expr< match $peek_fun loc$ $lid:strm_n$ with - [ Some $p$ $when:wo$ -> - do { $junk_fun loc$ $lid:strm_n$; $skont$ } - | _ -> $ckont$ ] >> - | SpNtr loc p e -> - let e = - match e with - [ <:expr< fun [ ($lid:v$ : Stream.t _) -> $e$ ] >> when v = strm_n -> - e - | _ -> <:expr< $e$ $lid:strm_n$ >> ] - in - if pattern_eq_expression p skont then - if is_raise_failure ckont then e - else if handle_failure e then e - else <:expr< try $e$ with [ Stream.Failure -> $ckont$ ] >> - else if is_raise_failure ckont then <:expr< let $p$ = $e$ in $skont$ >> - else if pattern_eq_expression <:patt< Some $p$ >> skont then - <:expr< try Some $e$ with [ Stream.Failure -> $ckont$ ] >> - else if is_raise ckont then - let tst = - if handle_failure e then e - else <:expr< try $e$ with [ Stream.Failure -> $ckont$ ] >> - in - <:expr< let $p$ = $tst$ in $skont$ >> - else - <:expr< match try Some $e$ with [ Stream.Failure -> None ] with - [ Some $p$ -> $skont$ - | _ -> $ckont$ ] >> - | SpStr loc p -> - try - match p with - [ <:patt< $lid:v$ >> -> subst v skont - | _ -> raise Not_found ] - with - [ Not_found -> <:expr< let $p$ = $lid:strm_n$ in $skont$ >> ] ] -; - -value rec stream_pattern loc epo e ekont = - fun - [ [] -> - match epo with - [ Some ep -> <:expr< let $ep$ = Stream.count $lid:strm_n$ in $e$ >> - | _ -> e ] - | [(spc, err) :: spcl] -> - let skont = - let ekont err = - let str = - match err with - [ Some estr -> estr - | _ -> <:expr< "" >> ] - in - <:expr< raise (Stream.Error $str$) >> - in - stream_pattern loc epo e ekont spcl - in - let ckont = ekont err in - stream_pattern_component skont ckont spc ] -; - -value stream_patterns_term loc ekont tspel = - let pel = - List.map - (fun (p, w, loc, spcl, epo, e) -> - let p = <:patt< Some $p$ >> in - let e = - let ekont err = - let str = - match err with - [ Some estr -> estr - | _ -> <:expr< "" >> ] - in - <:expr< raise (Stream.Error $str$) >> - in - let skont = stream_pattern loc epo e ekont spcl in - <:expr< do { $junk_fun loc$ $lid:strm_n$; $skont$ } >> - in - (p, w, e)) - tspel - in - let pel = pel @ [(<:patt< _ >>, None, ekont ())] in - <:expr< match $peek_fun loc$ $lid:strm_n$ with [ $list:pel$ ] >> -; - -value rec group_terms = - fun - [ [([(SpTrm loc p w, None) :: spcl], epo, e) :: spel] -> - let (tspel, spel) = group_terms spel in - ([(p, w, loc, spcl, epo, e) :: tspel], spel) - | spel -> ([], spel) ] -; - -value rec parser_cases loc = - fun - [ [] -> <:expr< raise Stream.Failure >> - | spel -> - match group_terms spel with - [ ([], [(spcl, epo, e) :: spel]) -> - stream_pattern loc epo e (fun _ -> parser_cases loc spel) spcl - | (tspel, spel) -> - stream_patterns_term loc (fun _ -> parser_cases loc spel) tspel ] ] -; - -value cparser loc bpo pc = - let e = parser_cases loc pc in - let e = - match bpo with - [ Some bp -> <:expr< let $bp$ = Stream.count $lid:strm_n$ in $e$ >> - | None -> e ] - in - let p = <:patt< ($lid:strm_n$ : Stream.t _) >> in - <:expr< fun $p$ -> $e$ >> -; - -value cparser_match loc me bpo pc = - let pc = parser_cases loc pc in - let e = - match bpo with - [ Some bp -> <:expr< let $bp$ = Stream.count $lid:strm_n$ in $pc$ >> - | None -> pc ] - in - <:expr< let $lid:strm_n$ = $me$ in $e$ >> -; - -(* streams *) - -value rec not_computing = - fun - [ <:expr< $lid:_$ >> | <:expr< $uid:_$ >> | <:expr< $int:_$ >> | - <:expr< $flo:_$ >> | <:expr< $chr:_$ >> | <:expr< $str:_$ >> -> - True - | <:expr< $x$ $y$ >> -> is_cons_apply_not_computing x && not_computing y - | _ -> False ] -and is_cons_apply_not_computing = - fun - [ <:expr< $uid:_$ >> -> True - | <:expr< $lid:_$ >> -> False - | <:expr< $x$ $y$ >> -> is_cons_apply_not_computing x && not_computing y - | _ -> False ] -; - -value slazy loc e = - match e with - [ <:expr< $f$ () >> -> - match f with - [ <:expr< $lid:_$ >> -> f - | _ -> <:expr< fun _ -> $e$ >> ] - | _ -> <:expr< fun _ -> $e$ >> ] -; - -value rec cstream gloc = - fun - [ [] -> - let loc = gloc in - <:expr< Stream.sempty >> - | [SeTrm loc e] -> - if not_computing e then <:expr< Stream.ising $e$ >> - else <:expr< Stream.lsing $slazy loc e$ >> - | [SeTrm loc e :: secl] -> - if not_computing e then <:expr< Stream.icons $e$ $cstream gloc secl$ >> - else <:expr< Stream.lcons $slazy loc e$ $cstream gloc secl$ >> - | [SeNtr loc e] -> - if not_computing e then e else <:expr< Stream.slazy $slazy loc e$ >> - | [SeNtr loc e :: secl] -> - if not_computing e then <:expr< Stream.iapp $e$ $cstream gloc secl$ >> - else <:expr< Stream.lapp $slazy loc e$ $cstream gloc secl$ >> ] -; - -(* Syntax extensions in Ocaml grammar *) - -EXTEND - GLOBAL: expr; - expr: LEVEL "expr1" - [ [ "parser"; po = OPT ipatt; OPT "|"; pcl = LIST1 parser_case SEP "|" -> - <:expr< $cparser loc po pcl$ >> - | "match"; e = SELF; "with"; "parser"; po = OPT ipatt; OPT "|"; - pcl = LIST1 parser_case SEP "|" -> - <:expr< $cparser_match loc e po pcl$ >> ] ] - ; - parser_case: - [ [ "[<"; sp = stream_patt; ">]"; po = OPT ipatt; "->"; e = expr -> - (sp, po, e) ] ] - ; - stream_patt: - [ [ spc = stream_patt_comp -> [(spc, None)] - | spc = stream_patt_comp; ";" -> [(spc, None)] - | spc = stream_patt_comp; ";"; sp = stream_patt_comp_err_list -> - [(spc, None) :: sp] - | -> (* empty *) [] ] ] - ; - stream_patt_comp_err_list: - [ [ spc = stream_patt_comp_err -> [spc] - | spc = stream_patt_comp_err; ";" -> [spc] - | spc = stream_patt_comp_err; ";"; sp = SELF -> [spc :: sp] ] ] - ; - stream_patt_comp: - [ [ "'"; p = patt; eo = OPT [ "when"; e = expr LEVEL "expr1" -> e ] -> - SpTrm loc p eo - | p = patt; "="; e = expr LEVEL "expr1" -> SpNtr loc p e - | p = patt -> SpStr loc p ] ] - ; - stream_patt_comp_err: - [ [ spc = stream_patt_comp; - eo = OPT [ "?"; e = expr LEVEL "expr1" -> e ] -> - (spc, eo) ] ] - ; - ipatt: - [ [ i = LIDENT -> <:patt< $lid:i$ >> ] ] - ; - expr: LEVEL "simple" - [ [ "[<"; ">]" -> <:expr< $cstream loc []$ >> - | "[<"; sel = stream_expr_comp_list; ">]" -> - <:expr< $cstream loc sel$ >> ] ] - ; - stream_expr_comp_list: - [ [ se = stream_expr_comp; ";"; sel = SELF -> [se :: sel] - | se = stream_expr_comp; ";" -> [se] - | se = stream_expr_comp -> [se] ] ] - ; - stream_expr_comp: - [ [ "'"; e = expr LEVEL "expr1" -> SeTrm loc e - | e = expr LEVEL "expr1" -> SeNtr loc e ] ] - ; -END; diff --git a/camlp4/etc/pa_oop.ml b/camlp4/etc/pa_oop.ml deleted file mode 100644 index fd56158346..0000000000 --- a/camlp4/etc/pa_oop.ml +++ /dev/null @@ -1,154 +0,0 @@ -(* camlp4r pa_extend.cmo q_MLast.cmo *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1998 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -open Pcaml; - -type spat_comp = - [ SpTrm of MLast.loc and MLast.patt and option MLast.expr - | SpNtr of MLast.loc and MLast.patt and MLast.expr - | SpStr of MLast.loc and MLast.patt ] -; -type sexp_comp = - [ SeTrm of MLast.loc and MLast.expr | SeNtr of MLast.loc and MLast.expr ] -; - -value strm_n = "strm__"; -value peek_fun loc = <:expr< Stream.peek >>; -value junk_fun loc = <:expr< Stream.junk >>; - -(* Parsers. *) - -value stream_pattern_component skont = - fun - [ SpTrm loc p wo -> - (<:expr< $peek_fun loc$ $lid:strm_n$ >>, p, wo, - <:expr< do { $junk_fun loc$ $lid:strm_n$; $skont$ } >>) - | SpNtr loc p e -> - (<:expr< try Some ($e$ $lid:strm_n$) with - [ Stream.Failure -> None ] >>, - p, None, skont) - | SpStr loc p -> - (<:expr< Some $lid:strm_n$ >>, p, None, skont) ] -; - -value rec stream_pattern loc epo e ekont = - fun - [ [] -> - match epo with - [ Some ep -> <:expr< let $ep$ = Stream.count $lid:strm_n$ in $e$ >> - | _ -> e ] - | [(spc, err) :: spcl] -> - let skont = - let ekont err = - let str = - match err with - [ Some estr -> estr - | _ -> <:expr< "" >> ] - in - <:expr< raise (Stream.Error $str$) >> - in - stream_pattern loc epo e ekont spcl - in - let (tst, p, wo, e) = stream_pattern_component skont spc in - let ckont = ekont err in - <:expr< match $tst$ with - [ Some $p$ $when:wo$ -> $e$ | _ -> $ckont$ ] >> ] -; - -value rec parser_cases loc = - fun - [ [] -> <:expr< raise Stream.Failure >> - | [(spcl, epo, e) :: spel] -> - stream_pattern loc epo e (fun _ -> parser_cases loc spel) spcl ] -; - -value cparser loc bpo pc = - let e = parser_cases loc pc in - let e = - match bpo with - [ Some bp -> <:expr< let $bp$ = Stream.count $lid:strm_n$ in $e$ >> - | None -> e ] - in - let p = <:patt< ($lid:strm_n$ : Stream.t _) >> in - <:expr< fun $p$ -> $e$ >> -; - -value cparser_match loc me bpo pc = - let pc = parser_cases loc pc in - let e = - match bpo with - [ Some bp -> <:expr< let $bp$ = Stream.count $lid:strm_n$ in $pc$ >> - | None -> pc ] - in - <:expr< let $lid:strm_n$ = $me$ in $e$ >> -; - -(* streams *) - -value slazy loc e = <:expr< fun _ -> $e$ >>; - -value rec cstream gloc = - fun - [ [] -> let loc = gloc in <:expr< Stream.sempty >> - | [SeTrm loc e :: secl] -> - <:expr< Stream.lcons $slazy loc e$ $cstream gloc secl$ >> - | [SeNtr loc e :: secl] -> - <:expr< Stream.lapp $slazy loc e$ $cstream gloc secl$ >> ] -; - -(* Syntax extensions in Ocaml grammar *) - -EXTEND - GLOBAL: expr; - expr: LEVEL "expr1" - [ [ "parser"; po = OPT ipatt; OPT "|"; pcl = LIST1 parser_case SEP "|" -> - <:expr< $cparser loc po pcl$ >> - | "match"; e = expr; "with"; "parser"; po = OPT ipatt; OPT "|"; - pcl = LIST1 parser_case SEP "|" -> - <:expr< $cparser_match loc e po pcl$ >> ] ] - ; - parser_case: - [ [ "[<"; sp = stream_patt; ">]"; po = OPT ipatt; "->"; e = expr -> - (sp, po, e) ] ] - ; - stream_patt: - [ [ spc = stream_patt_comp -> [(spc, None)] - | spc = stream_patt_comp; ";"; sp = LIST1 stream_patt_comp_err SEP ";" -> - [(spc, None) :: sp] - | (* empty *) -> [] ] ] - ; - stream_patt_comp_err: - [ [ spc = stream_patt_comp; - eo = OPT [ "??"; e = expr LEVEL "expr1" -> e ] -> - (spc, eo) ] ] - ; - stream_patt_comp: - [ [ "'"; p = patt; eo = OPT [ "when"; e = (expr LEVEL "expr1") -> e ] -> - SpTrm loc p eo - | p = patt; "="; e = (expr LEVEL "expr1") -> SpNtr loc p e - | p = patt -> SpStr loc p ] ] - ; - ipatt: - [ [ i = LIDENT -> <:patt< $lid:i$ >> ] ] - ; - - expr: LEVEL "simple" - [ [ "[<"; se = LIST0 stream_expr_comp SEP ";"; ">]" -> - <:expr< $cstream loc se$ >> ] ] - ; - stream_expr_comp: - [ [ "'"; e = expr LEVEL "expr1" -> SeTrm loc e - | e = expr LEVEL "expr1" -> SeNtr loc e ] ] - ; -END; diff --git a/camlp4/etc/pa_op.ml b/camlp4/etc/pa_op.ml deleted file mode 100644 index 5f2fff0fae..0000000000 --- a/camlp4/etc/pa_op.ml +++ /dev/null @@ -1,330 +0,0 @@ -(* camlp4r pa_extend.cmo q_MLast.cmo *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1998 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -open Pcaml; - -type spat_comp = - [ SpTrm of MLast.loc and MLast.patt and option MLast.expr - | SpNtr of MLast.loc and MLast.patt and MLast.expr - | SpStr of MLast.loc and MLast.patt ] -; -type sexp_comp = - [ SeTrm of MLast.loc and MLast.expr | SeNtr of MLast.loc and MLast.expr ] -; - -value strm_n = "strm__"; -value peek_fun loc = <:expr< Stream.peek >>; -value junk_fun loc = <:expr< Stream.junk >>; - -(* Parsers. *) -(* In syntax generated, many cases are optimisations. *) - -value rec pattern_eq_expression p e = - match (p, e) with - [ (<:patt< $lid:a$ >>, <:expr< $lid:b$ >>) -> a = b - | (<:patt< $uid:a$ >>, <:expr< $uid:b$ >>) -> a = b - | (<:patt< $p1$ $p2$ >>, <:expr< $e1$ $e2$ >>) -> - pattern_eq_expression p1 e1 && pattern_eq_expression p2 e2 - | _ -> False ] -; - -value is_raise e = - match e with - [ <:expr< raise $_$ >> -> True - | _ -> False ] -; - -value is_raise_failure e = - match e with - [ <:expr< raise Stream.Failure >> -> True - | _ -> False ] -; - -value rec handle_failure e = - match e with - [ <:expr< try $te$ with [ Stream.Failure -> $e$] >> -> - handle_failure e - | <:expr< match $me$ with [ $list:pel$ ] >> -> - handle_failure me && - List.for_all - (fun - [ (_, None, e) -> handle_failure e - | _ -> False ]) - pel - | <:expr< let $list:pel$ in $e$ >> -> - List.for_all (fun (p, e) -> handle_failure e) pel && handle_failure e - | <:expr< $lid:_$ >> | <:expr< $int:_$ >> | <:expr< $str:_$ >> | - <:expr< $chr:_$ >> | <:expr< fun [ $list:_$ ] >> | <:expr< $uid:_$ >> -> - True - | <:expr< raise $e$ >> -> - match e with - [ <:expr< Stream.Failure >> -> False - | _ -> True ] - | <:expr< $f$ $x$ >> -> - is_constr_apply f && handle_failure f && handle_failure x - | _ -> False ] -and is_constr_apply = - fun - [ <:expr< $uid:_$ >> -> True - | <:expr< $lid:_$ >> -> False - | <:expr< $x$ $_$ >> -> is_constr_apply x - | _ -> False ] -; - -value rec subst v e = - let loc = MLast.loc_of_expr e in - match e with - [ <:expr< $lid:x$ >> -> - let x = if x = v then strm_n else x in - <:expr< $lid:x$ >> - | <:expr< $uid:_$ >> -> e - | <:expr< $int:_$ >> -> e - | <:expr< $chr:_$ >> -> e - | <:expr< $str:_$ >> -> e - | <:expr< $_$ . $_$ >> -> e - | <:expr< let $opt:rf$ $list:pel$ in $e$ >> -> - <:expr< let $opt:rf$ $list:List.map (subst_pe v) pel$ in $subst v e$ >> - | <:expr< $e1$ $e2$ >> -> <:expr< $subst v e1$ $subst v e2$ >> - | <:expr< ( $list:el$ ) >> -> <:expr< ( $list:List.map (subst v) el$ ) >> - | _ -> raise Not_found ] -and subst_pe v (p, e) = - match p with - [ <:patt< $lid:v'$ >> -> if v = v' then (p, e) else (p, subst v e) - | _ -> raise Not_found ] -; - -value stream_pattern_component skont ckont = - fun - [ SpTrm loc p wo -> - <:expr< match $peek_fun loc$ $lid:strm_n$ with - [ Some $p$ $when:wo$ -> - do { $junk_fun loc$ $lid:strm_n$; $skont$ } - | _ -> $ckont$ ] >> - | SpNtr loc p e -> - let e = - match e with - [ <:expr< fun [ ($lid:v$ : Stream.t _) -> $e$ ] >> when v = strm_n -> e - | _ -> <:expr< $e$ $lid:strm_n$ >> ] - in - if pattern_eq_expression p skont then - if is_raise_failure ckont then e - else if handle_failure e then e - else <:expr< try $e$ with [ Stream.Failure -> $ckont$ ] >> - else if is_raise_failure ckont then - <:expr< let $p$ = $e$ in $skont$ >> - else if pattern_eq_expression <:patt< Some $p$ >> skont then - <:expr< try Some $e$ with [ Stream.Failure -> $ckont$ ] >> - else if is_raise ckont then - let tst = - if handle_failure e then e - else <:expr< try $e$ with [ Stream.Failure -> $ckont$ ] >> - in - <:expr< let $p$ = $tst$ in $skont$ >> - else - <:expr< match try Some $e$ with [ Stream.Failure -> None ] with - [ Some $p$ -> $skont$ - | _ -> $ckont$ ] >> - | SpStr loc p -> - try - match p with - [ <:patt< $lid:v$ >> -> subst v skont - | _ -> raise Not_found ] - with - [ Not_found -> <:expr< let $p$ = $lid:strm_n$ in $skont$ >> ] ] -; - -value rec stream_pattern loc epo e ekont = - fun - [ [] -> - match epo with - [ Some ep -> <:expr< let $ep$ = Stream.count $lid:strm_n$ in $e$ >> - | _ -> e ] - | [(spc, err) :: spcl] -> - let skont = - let ekont err = - let str = - match err with - [ Some estr -> estr - | _ -> <:expr< "" >> ] - in - <:expr< raise (Stream.Error $str$) >> - in - stream_pattern loc epo e ekont spcl - in - let ckont = ekont err in stream_pattern_component skont ckont spc ] -; - -value stream_patterns_term loc ekont tspel = - let pel = - List.map - (fun (p, w, loc, spcl, epo, e) -> - let p = <:patt< Some $p$ >> in - let e = - let ekont err = - let str = - match err with - [ Some estr -> estr - | _ -> <:expr< "" >> ] - in - <:expr< raise (Stream.Error $str$) >> - in - let skont = stream_pattern loc epo e ekont spcl in - <:expr< do { $junk_fun loc$ $lid:strm_n$; $skont$ } >> - in - (p, w, e)) - tspel - in - let pel = pel @ [(<:patt< _ >>, None, ekont ())] in - <:expr< match $peek_fun loc$ $lid:strm_n$ with [ $list:pel$ ] >> -; - -value rec group_terms = - fun - [ [([(SpTrm loc p w, None) :: spcl], epo, e) :: spel] -> - let (tspel, spel) = group_terms spel in - ([(p, w, loc, spcl, epo, e) :: tspel], spel) - | spel -> ([], spel) ] -; - -value rec parser_cases loc = - fun - [ [] -> <:expr< raise Stream.Failure >> - | spel -> - match group_terms spel with - [ ([], [(spcl, epo, e) :: spel]) -> - stream_pattern loc epo e (fun _ -> parser_cases loc spel) spcl - | (tspel, spel) -> - stream_patterns_term loc (fun _ -> parser_cases loc spel) tspel ] ] -; - -value cparser loc bpo pc = - let e = parser_cases loc pc in - let e = - match bpo with - [ Some bp -> <:expr< let $bp$ = Stream.count $lid:strm_n$ in $e$ >> - | None -> e ] - in - let p = <:patt< ($lid:strm_n$ : Stream.t _) >> in - <:expr< fun $p$ -> $e$ >> -; - -value cparser_match loc me bpo pc = - let pc = parser_cases loc pc in - let e = - match bpo with - [ Some bp -> <:expr< let $bp$ = Stream.count $lid:strm_n$ in $pc$ >> - | None -> pc ] - in - <:expr< let ($lid:strm_n$ : Stream.t _) = $me$ in $e$ >> -; - -(* streams *) - -value rec not_computing = - fun - [ <:expr< $lid:_$ >> | <:expr< $uid:_$ >> | <:expr< $int:_$ >> | - <:expr< $flo:_$ >> | <:expr< $chr:_$ >> | <:expr< $str:_$ >> -> True - | <:expr< $x$ $y$ >> -> is_cons_apply_not_computing x && not_computing y - | _ -> False ] -and is_cons_apply_not_computing = - fun - [ <:expr< $uid:_$ >> -> True - | <:expr< $lid:_$ >> -> False - | <:expr< $x$ $y$ >> -> is_cons_apply_not_computing x && not_computing y - | _ -> False ] -; - -value slazy loc e = - match e with - [ <:expr< $f$ () >> -> - match f with - [ <:expr< $lid:_$ >> -> f - | _ -> <:expr< fun _ -> $e$ >> ] - | _ -> <:expr< fun _ -> $e$ >> ] -; - -value rec cstream gloc = - fun - [ [] -> let loc = gloc in <:expr< Stream.sempty >> - | [SeTrm loc e] -> - if not_computing e then <:expr< Stream.ising $e$ >> - else <:expr< Stream.lsing $slazy loc e$ >> - | [SeTrm loc e :: secl] -> - if not_computing e then <:expr< Stream.icons $e$ $cstream gloc secl$ >> - else <:expr< Stream.lcons $slazy loc e$ $cstream gloc secl$ >> - | [SeNtr loc e] -> - if not_computing e then e else <:expr< Stream.slazy $slazy loc e$ >> - | [SeNtr loc e :: secl] -> - if not_computing e then <:expr< Stream.iapp $e$ $cstream gloc secl$ >> - else <:expr< Stream.lapp $slazy loc e$ $cstream gloc secl$ >> ] -; - -(* Syntax extensions in Ocaml grammar *) - -EXTEND - GLOBAL: expr; - expr: LEVEL "expr1" - [ [ "parser"; po = OPT ipatt; OPT "|"; pcl = LIST1 parser_case SEP "|" -> - <:expr< $cparser loc po pcl$ >> - | "match"; e = expr; "with"; "parser"; po = OPT ipatt; OPT "|"; - pcl = LIST1 parser_case SEP "|" -> - <:expr< $cparser_match loc e po pcl$ >> ] ] - ; - parser_case: - [ [ "[<"; sp = stream_patt; ">]"; po = OPT ipatt; "->"; e = expr -> - (sp, po, e) ] ] - ; - stream_patt: - [ [ spc = stream_patt_comp -> [(spc, None)] - | spc = stream_patt_comp; ";" -> [(spc, None)] - | spc = stream_patt_comp; ";"; sp = stream_patt_comp_err_list -> - [(spc, None) :: sp] - | (* empty *) -> [] ] ] - ; - stream_patt_comp_err_list: - [ [ spc = stream_patt_comp_err -> [spc] - | spc = stream_patt_comp_err; ";" -> [spc] - | spc = stream_patt_comp_err; ";"; sp = stream_patt_comp_err_list -> - [spc :: sp] ] ] - ; - stream_patt_comp: - [ [ "'"; p = patt; eo = OPT [ "when"; e = (expr LEVEL "expr1") -> e ] -> - SpTrm loc p eo - | p = patt; "="; e = (expr LEVEL "expr1") -> SpNtr loc p e - | p = patt -> SpStr loc p ] ] - ; - stream_patt_comp_err: - [ [ spc = stream_patt_comp; - eo = OPT [ "??"; e = expr LEVEL "expr1" -> e ] -> (spc, eo) ] ] - ; - ipatt: - [ [ i = LIDENT -> <:patt< $lid:i$ >> - | "_" -> <:patt< _ >> ] ] - ; - - expr: LEVEL "simple" - [ [ "[<"; ">]" -> <:expr< $cstream loc []$ >> - | "[<"; sel = stream_expr_comp_list; ">]" -> - <:expr< $cstream loc sel$ >> ] ] - ; - stream_expr_comp_list: - [ [ se = stream_expr_comp; ";"; sel = stream_expr_comp_list -> [se :: sel] - | se = stream_expr_comp; ";" -> [se] - | se = stream_expr_comp -> [se] ] ] - ; - stream_expr_comp: - [ [ "'"; e = expr LEVEL "expr1" -> SeTrm loc e - | e = expr LEVEL "expr1" -> SeNtr loc e ] ] - ; -END; diff --git a/camlp4/etc/pa_ru.ml b/camlp4/etc/pa_ru.ml deleted file mode 100644 index d3060c88c5..0000000000 --- a/camlp4/etc/pa_ru.ml +++ /dev/null @@ -1,46 +0,0 @@ -(* camlp4r pa_extend.cmo q_MLast.cmo *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1998 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -open Pcaml; - -value o2b = - fun - [ Some _ -> True - | None -> False ] -; - -EXTEND - GLOBAL: expr; - expr: LEVEL "top" - [ [ "do"; "{"; seq = sequence; "}" -> - match seq with - [ [e] -> e - | _ -> <:expr< do { $list:seq$ } >> ] ] ] - ; - sequence: - [ [ "let"; o = OPT "rec"; l = LIST1 let_binding SEP "and"; [ "in" | ";" ]; - el = SELF -> - let e = - match el with - [ [e] -> e - | _ -> <:expr< do { $list:el$ } >> ] - in - [<:expr< let $opt:o2b o$ $list:l$ in $e$ >>] - | e = expr; ";"; el = SELF -> - let e = let loc = MLast.loc_of_expr e in <:expr< ($e$ : unit) >> in - [e :: el] - | e = expr; ";" -> [e] - | e = expr -> [e] ] ] - ; -END; diff --git a/camlp4/etc/pa_scheme.ml b/camlp4/etc/pa_scheme.ml deleted file mode 100644 index 846a11e465..0000000000 --- a/camlp4/etc/pa_scheme.ml +++ /dev/null @@ -1,1002 +0,0 @@ -; camlp4 ./pa_schemer.cmo pa_extend.cmo q_MLast.cmo pr_dump.cmo -; $Id$ - -(open Pcaml) -(open Stdpp) - -(type (choice 'a 'b) (sum (Left 'a) (Right 'b))) - -; Buffer - -(module Buff - (struct - (define buff (ref (String.create 80))) - (define (store len x) - (if (>= len (String.length buff.val)) - (:= buff.val (^ buff.val (String.create (String.length buff.val))))) - (:= buff.val.[len] x) - (succ len)) - (define (get len) (String.sub buff.val 0 len)))) - -; Lexer - -(definerec skip_to_eol - (parser - (((` (or '\n' '\r'))) ()) - (((` _) s) (skip_to_eol s)))) - -(define no_ident ['(' ')' '[' ']' '{' '}' ' ' '\t' '\n' '\r' ';']) - -(definerec (ident len) - (parser - (((` '.')) (values (Buff.get len) True)) - (((` x (not (List.mem x no_ident))) s) (ident (Buff.store len x) s)) - (() (values (Buff.get len) False)))) - -(define (identifier kwt (values s dot)) - (let ((con - (try (begin (: (Hashtbl.find kwt s) unit) "") - (Not_found - (match s.[0] - ((range 'A' 'Z') (if dot "UIDENTDOT" "UIDENT")) - (_ (if dot "LIDENTDOT" "LIDENT"))))))) - (values con s))) - -(definerec (string len) - (parser - (((` '"')) (Buff.get len)) - (((` '\\') (` c) s) (string (Buff.store (Buff.store len '\\') c) s)) - (((` x) s) (string (Buff.store len x) s)))) - -(definerec (end_exponent_part_under len) - (parser - (((` (as (range '0' '9') c)) s) - (end_exponent_part_under (Buff.store len c) s)) - (() (values "FLOAT" (Buff.get len))))) - -(define (end_exponent_part len) - (parser - (((` (as (range '0' '9') c)) s) - (end_exponent_part_under (Buff.store len c) s)) - (() (raise (Stream.Error "ill-formed floating-point constant"))))) - -(define (exponent_part len) - (parser - (((` (as (or '+' '-') c)) s) (end_exponent_part (Buff.store len c) s)) - (((a (end_exponent_part len))) a))) - -(definerec (decimal_part len) - (parser - (((` (as (range '0' '9') c)) s) (decimal_part (Buff.store len c) s)) - (((` (or 'e' 'E')) s) (exponent_part (Buff.store len 'E') s)) - (() (values "FLOAT" (Buff.get len))))) - -(definerec (number len) - (parser - (((` (as (range '0' '9') c)) s) (number (Buff.store len c) s)) - (((` '.') s) (decimal_part (Buff.store len '.') s)) - (((` (or 'e' 'E')) s) (exponent_part (Buff.store len 'E') s)) - (() (values "INT" (Buff.get len))))) - -(define binary - (parser - (((` (as (range '0' '1') c))) c))) - -(define octal - (parser - (((` (as (range '0' '7') c))) c))) - -(define hexa - (parser - (((` (as (or (range '0' '9') (range 'a' 'f') (range 'A' 'F')) c))) c))) - -(definerec (digits_under kind len) - (parser - (((d kind) s) (digits_under kind (Buff.store len d) s)) - (() (Buff.get len)))) - -(define (digits kind bp len) - (parser - (((d kind) s) (values "INT" (digits_under kind (Buff.store len d) s))) - ((s) ep - (raise_with_loc (values bp ep) (Failure "ill-formed integer constant"))))) - -(define (base_number kwt bp len) - (parser - (((` (or 'b' 'B')) s) (digits binary bp (Buff.store len 'b') s)) - (((` (or 'o' 'O')) s) (digits octal bp (Buff.store len 'o') s)) - (((` (or 'x' 'X')) s) (digits hexa bp (Buff.store len 'x') s)) - (((id (ident (Buff.store 0 '#')))) (identifier kwt id)))) - -(definerec (operator len) - (parser - (((` '.')) (Buff.get (Buff.store len '.'))) - (() (Buff.get len)))) - -(define (char_or_quote_id x) - (parser - (((` ''')) (values "CHAR" (String.make 1 x))) - ((s) ep - (if (List.mem x no_ident) - (Stdpp.raise_with_loc (values (- ep 2) (- ep 1)) - (Stream.Error "bad quote")) - (let* ((len (Buff.store (Buff.store 0 ''') x)) - ((values s dot) (ident len s))) - (values (if dot "LIDENTDOT" "LIDENT") s)))))) - -(definerec (char len) - (parser - (((` ''')) len) - (((` x) s) (char (Buff.store len x) s)))) - -(define quote - (parser - (((` '\\') (len (char (Buff.store 0 '\\')))) - (values "CHAR" (Buff.get len))) - (((` x) s) (char_or_quote_id x s)))) - -; The system with LIDENTDOT and UIDENTDOT is not great (it would be -; better to have a token DOT (actually SPACEDOT and DOT)) but it is -; the only way (that I have found) to have a good behaviour in the -; toplevel (not expecting tokens after a phrase). Drawbacks: 1/ to be -; complete, we should have STRINGDOT, RIGHTPARENDOT, and so on 2/ the -; parser rule with dot is right associative and we have to reverse -; the resulting tree (using the function leftify). -; This is a complicated issue: the behaviour of the OCaml toplevel -; is strange, anyway. For example, even without Camlp4, The OCaml -; toplevel accepts that: -; # let x = 32;; foo bar match let ) - -(definerec* - ((lexer kwt) - (parser - (((t (lexer0 kwt)) - (_ no_dot)) t))) - (no_dot - (parser - (((` '.')) ep - (Stdpp.raise_with_loc (values (- ep 1) ep) (Stream.Error "bad dot"))) - (() ()))) - ((lexer0 kwt) - (parser bp - (((` (or '\t' '\n' '\r')) s) (lexer0 kwt s)) - (((` ' ') s) (after_space kwt s)) - (((` ';') (_ skip_to_eol) s) (lexer kwt s)) - (((` '(')) (values (values "" "(") (values bp (+ bp 1)))) - (((` ')') s) ep (values (values "" (rparen s)) (values bp ep))) - (((` '[')) (values (values "" "[") (values bp (+ bp 1)))) - (((` ']')) (values (values "" "]") (values bp (+ bp 1)))) - (((` '{')) (values (values "" "{") (values bp (+ bp 1)))) - (((` '}')) (values (values "" "}") (values bp (+ bp 1)))) - (((` '"') (s (string 0))) ep - (values (values "STRING" s) (values bp ep))) - (((` ''') (tok quote)) ep (values tok (values bp ep))) - (((` '<') (tok (less kwt))) ep (values tok (values bp ep))) - (((` '-') (tok (minus kwt))) ep (values tok (values bp ep))) - (((` '~') (tok tilde)) ep (values tok (values bp ep))) - (((` '?') (tok question)) ep (values tok (values bp ep))) - (((` '#') (tok (base_number kwt bp (Buff.store 0 '0')))) ep - (values tok (values bp ep))) - (((` (as (range '0' '9') c)) (tok (number (Buff.store 0 c)))) ep - (values tok (values bp ep))) - (((` (as (or '+' '*' '/') c)) (id (operator (Buff.store 0 c)))) ep - (values (identifier kwt (values id False)) (values bp ep))) - (((` x) (id (ident (Buff.store 0 x)))) ep - (values (identifier kwt id) (values bp ep))) - (() (values (values "EOI" "") (values bp (+ bp 1)))))) - (rparen - (parser - (((` '.')) ").") - ((_) ")"))) - ((after_space kwt) - (parser - (((` '.')) ep (values (values "" ".") (values (- ep 1) ep))) - (((x (lexer0 kwt))) x))) - (tilde - (parser - (((` (as (range 'a' 'z') c)) ((values s dot) (ident (Buff.store 0 c)))) - (values "TILDEIDENT" s)) - (() (values "LIDENT" "~")))) - (question - (parser - (((` (as (range 'a' 'z') c)) ((values s dot) (ident (Buff.store 0 c)))) - (values "QUESTIONIDENT" s)) - (() (values "LIDENT" "?")))) - ((minus kwt) - (parser - (((` '.')) (identifier kwt (values "-." False))) - (((` (as (range '0' '9') c)) - (n (number (Buff.store (Buff.store 0 '-') c)))) ep n) - (((id (ident (Buff.store 0 '-')))) (identifier kwt id)))) - ((less kwt) - (parser - (((` ':') (lab (label 0)) (? (` '<') "'<' expected") (q (quotation 0))) - (values "QUOT" (^ lab ":" q))) - (((id (ident (Buff.store 0 '<')))) (identifier kwt id)))) - ((label len) - (parser - (((` (as (or (range 'a' 'z') (range 'A' 'Z') '_') c)) s) - (label (Buff.store len c) s)) - (() (Buff.get len)))) - ((quotation len) - (parser - (((` '>') s) (quotation_greater len s)) - (((` x) s) (quotation (Buff.store len x) s)) - (() (failwith "quotation not terminated")))) - ((quotation_greater len) - (parser - (((` '>')) (Buff.get len)) - (((a (quotation (Buff.store len '>')))) a)))) - -(define (lexer_using kwt (values con prm)) - (match con - ((or "CHAR" "EOI" "INT" "FLOAT" "LIDENT" "LIDENTDOT" "QUESTIONIDENT" - "QUOT" "STRING" "TILDEIDENT" "UIDENT" "UIDENTDOT") - ()) - ("ANTIQUOT" ()) - ("" (try (Hashtbl.find kwt prm) (Not_found (Hashtbl.add kwt prm ())))) - (_ - (raise - (Token.Error - (^ "the constructor \"" con "\" is not recognized by Plexer")))))) - -(define (lexer_text (values con prm)) - (cond - ((= con "") (^ "'"prm "'")) - ((= prm "") con) - (else (^ con " \"" prm "\"")))) - -(define (lexer_gmake ()) - (let ((kwt (Hashtbl.create 89))) - {(Token.tok_func (Token.lexer_func_of_parser (lexer kwt))) - (Token.tok_using (lexer_using kwt)) - (Token.tok_removing (lambda)) - (Token.tok_match Token.default_match) - (Token.tok_text lexer_text) - (Token.tok_comm None)})) - -; Building AST - -(type sexpr - (sum - (Sacc MLast.loc sexpr sexpr) - (Schar MLast.loc string) - (Sexpr MLast.loc (list sexpr)) - (Sint MLast.loc string) - (Sfloat MLast.loc string) - (Slid MLast.loc string) - (Slist MLast.loc (list sexpr)) - (Sqid MLast.loc string) - (Squot MLast.loc string string) - (Srec MLast.loc (list sexpr)) - (Sstring MLast.loc string) - (Stid MLast.loc string) - (Suid MLast.loc string))) - -(define loc_of_sexpr - (lambda_match - ((or (Sacc loc _ _) (Schar loc _) (Sexpr loc _) (Sint loc _) - (Sfloat loc _) (Slid loc _) (Slist loc _) (Sqid loc _) (Squot loc _ _) - (Srec loc _) (Sstring loc _) (Stid loc _) (Suid loc _)) - loc))) -(define (error_loc loc err) - (raise_with_loc loc (Stream.Error (^ err " expected")))) -(define (error se err) (error_loc (loc_of_sexpr se) err)) - -(define strm_n "strm__") -(define (peek_fun loc) <:expr< Stream.peek >>) -(define (junk_fun loc) <:expr< Stream.junk >>) - -(define assoc_left_parsed_op_list ["+" "*" "+." "*." "land" "lor" "lxor"]) -(define assoc_right_parsed_op_list ["and" "or" "^" "@"]) -(define and_by_couple_op_list ["=" "<>" "<" ">" "<=" ">=" "==" "!="]) - -(define (op_apply loc e1 e2) - (lambda_match - ("and" <:expr< $e1$ && $e2$ >>) - ("or" <:expr< $e1$ || $e2$ >>) - (x <:expr< $lid:x$ $e1$ $e2$ >>))) - -(define string_se - (lambda_match - ((Sstring loc s) s) - (se (error se "string")))) - -(define mod_ident_se - (lambda_match - ((Suid _ s) [(Pcaml.rename_id.val s)]) - ((Slid _ s) [(Pcaml.rename_id.val s)]) - (se (error se "mod_ident")))) - -(define (lident_expr loc s) - (if (&& (> (String.length s) 1) (= s.[0] '`')) - (let ((s (String.sub s 1 (- (String.length s) 1)))) - <:expr< ` $s$ >>) - <:expr< $lid:(Pcaml.rename_id.val s)$ >>)) - -(definerec* - (module_expr_se - (lambda_match - ((Sexpr loc [(Slid _ "functor") (Suid _ s) se1 se2]) - (let* ((s (Pcaml.rename_id.val s)) - (mt (module_type_se se1)) - (me (module_expr_se se2))) - <:module_expr< functor ($s$ : $mt$) -> $me$ >>)) - ((Sexpr loc [(Slid _ "struct") . sl]) - (let ((mel (List.map str_item_se sl))) - <:module_expr< struct $list:mel$ end >>)) - ((Sexpr loc [se1 se2]) - (let* ((me1 (module_expr_se se1)) - (me2 (module_expr_se se2))) - <:module_expr< $me1$ $me2$ >>)) - ((Suid loc s) <:module_expr< $uid:(Pcaml.rename_id.val s)$ >>) - (se (error se "module expr")))) - (module_type_se - (lambda_match - ((Sexpr loc [(Slid _ "functor") (Suid _ s) se1 se2]) - (let* ((s (Pcaml.rename_id.val s)) - (mt1 (module_type_se se1)) - (mt2 (module_type_se se2))) - <:module_type< functor ($s$ : $mt1$) -> $mt2$ >>)) - ((Sexpr loc [(Slid _ "sig") . sel]) - (let ((sil (List.map sig_item_se sel))) - <:module_type< sig $list:sil$ end >>)) - ((Sexpr loc [(Slid _ "with") se (Sexpr _ sel)]) - (let* ((mt (module_type_se se)) - (wcl (List.map with_constr_se sel))) - <:module_type< $mt$ with $list:wcl$ >>)) - ((Suid loc s) <:module_type< $uid:(Pcaml.rename_id.val s)$ >>) - (se (error se "module type")))) - (with_constr_se - (lambda_match - ((Sexpr loc [(Slid _ "type") se1 se2]) - (let* ((tn (mod_ident_se se1)) - (te (ctyp_se se2))) - (MLast.WcTyp loc tn [] te))) - (se (error se "with constr")))) - (sig_item_se - (lambda_match - ((Sexpr loc [(Slid _ "type") . sel]) - (let ((tdl (type_declaration_list_se sel))) - <:sig_item< type $list:tdl$ >>)) - ((Sexpr loc [(Slid _ "exception") (Suid _ c) . sel]) - (let* ((c (Pcaml.rename_id.val c)) - (tl (List.map ctyp_se sel))) - <:sig_item< exception $c$ of $list:tl$ >>)) - ((Sexpr loc [(Slid _ "value") (Slid _ s) se]) - (let* ((s (Pcaml.rename_id.val s)) - (t (ctyp_se se))) - <:sig_item< value $s$ : $t$ >>)) - ((Sexpr loc [(Slid _ "external") (Slid _ i) se . sel]) - (let* ((i (Pcaml.rename_id.val i)) - (pd (List.map string_se sel)) - (t (ctyp_se se))) - <:sig_item< external $i$ : $t$ = $list:pd$ >>)) - ((Sexpr loc [(Slid _ "module") (Suid _ s) se]) - (let* ((s (Pcaml.rename_id.val s)) - (mb (module_type_se se))) - <:sig_item< module $s$ : $mb$ >>)) - ((Sexpr loc [(Slid _ "moduletype") (Suid _ s) se]) - (let* ((s (Pcaml.rename_id.val s)) - (mt (module_type_se se))) - <:sig_item< module type $s$ = $mt$ >>)) - (se (error se "sig item")))) - ((str_item_se se) - (match se - ((Sexpr loc [(Slid _ "open") se]) - (let ((s (mod_ident_se se))) <:str_item< open $s$ >>)) - ((Sexpr loc [(Slid _ "type") . sel]) - (let ((tdl (type_declaration_list_se sel))) - <:str_item< type $list:tdl$ >>)) - ((Sexpr loc [(Slid _ "exception") (Suid _ c) . sel]) - (let* ((c (Pcaml.rename_id.val c)) - (tl (List.map ctyp_se sel))) - <:str_item< exception $c$ of $list:tl$ >>)) - ((Sexpr loc [(Slid _ (as (or "define" "definerec") r)) se . sel]) - (let* ((r (= r "definerec")) - ((values p e) (fun_binding_se se (begin_se loc sel)))) - <:str_item< value $opt:r$ $p$ = $e$ >>)) - ((Sexpr loc [(Slid _ (as (or "define*" "definerec*") r)) . sel]) - (let* ((r (= r "definerec*")) - (lbs (List.map let_binding_se sel))) - <:str_item< value $opt:r$ $list:lbs$ >>)) - ((Sexpr loc [(Slid _ "external") (Slid _ i) se . sel]) - (let* ((i (Pcaml.rename_id.val i)) - (pd (List.map string_se sel)) - (t (ctyp_se se))) - <:str_item< external $i$ : $t$ = $list:pd$ >>)) - ((Sexpr loc [(Slid _ "module") (Suid _ i) se]) - (let* ((i (Pcaml.rename_id.val i)) - (mb (module_binding_se se))) - <:str_item< module $i$ = $mb$ >>)) - ((Sexpr loc [(Slid _ "moduletype") (Suid _ s) se]) - (let* ((s (Pcaml.rename_id.val s)) - (mt (module_type_se se))) - <:str_item< module type $s$ = $mt$ >>)) - (_ - (let* ((loc (loc_of_sexpr se)) - (e (expr_se se))) - <:str_item< $exp:e$ >>)))) - ((module_binding_se se) (module_expr_se se)) - (expr_se - (lambda_match - ((Sacc loc se1 se2) - (let ((e1 (expr_se se1))) - (match se2 - ((Slist loc [se2]) - (let ((e2 (expr_se se2))) <:expr< $e1$ .[ $e2$ ] >>)) - ((Sexpr loc [se2]) - (let ((e2 (expr_se se2))) <:expr< $e1$ .( $e2$ ) >>)) - (_ (let ((e2 (expr_se se2))) <:expr< $e1$ . $e2$ >>))))) - ((Slid loc s) (lident_expr loc s)) - ((Suid loc s) <:expr< $uid:(Pcaml.rename_id.val s)$ >>) - ((Sint loc s) <:expr< $int:s$ >>) - ((Sfloat loc s) <:expr< $flo:s$ >>) - ((Schar loc s) <:expr< $chr:s$ >>) - ((Sstring loc s) <:expr< $str:s$ >>) - ((Stid loc s) <:expr< ~ $(Pcaml.rename_id.val s)$ >>) - ((Sqid loc s) <:expr< ? $(Pcaml.rename_id.val s)$ >>) - ((Sexpr loc []) <:expr< () >>) - ((when (Sexpr loc [(Slid _ s) e1 . (as [_ . _] sel)]) - (List.mem s assoc_left_parsed_op_list)) - (letrec - (((loop e1) - (lambda_match - ([] e1) - ([e2 . el] (loop (op_apply loc e1 e2 s) el))))) - (loop (expr_se e1) (List.map expr_se sel)))) - ((when (Sexpr loc [(Slid _ s) . (as [_ _ . _] sel)]) - (List.mem s assoc_right_parsed_op_list)) - (letrec - ((loop - (lambda_match - ([] - (assert False)) - ([e1] e1) - ([e1 . el] (let ((e2 (loop el))) (op_apply loc e1 e2 s)))))) - (loop (List.map expr_se sel)))) - ((when (Sexpr loc [(Slid _ s) . (as [_ _ . _] sel)]) - (List.mem s and_by_couple_op_list)) - (letrec - ((loop - (lambda_match - ((or [] [_]) (assert False)) - ([e1 e2] <:expr< $lid:s$ $e1$ $e2$ >>) - ([e1 . (as [e2 _ . _] el)] - (let* ((a1 (op_apply loc e1 e2 s)) - (a2 (loop el))) - <:expr< $a1$ && $a2$ >>))))) - (loop (List.map expr_se sel)))) - ((Sexpr loc [(Stid _ s) se]) - (let ((e (expr_se se))) <:expr< ~ $s$ : $e$ >>)) - ((Sexpr loc [(Slid _ "-") se]) - (let ((e (expr_se se))) <:expr< - $e$ >>)) - ((Sexpr loc [(Slid _ "if") se se1]) - (let* ((e (expr_se se)) - (e1 (expr_se se1))) - <:expr< if $e$ then $e1$ else () >>)) - ((Sexpr loc [(Slid _ "if") se se1 se2]) - (let* ((e (expr_se se)) - (e1 (expr_se se1)) - (e2 (expr_se se2))) - <:expr< if $e$ then $e1$ else $e2$ >>)) - ((Sexpr loc [(Slid _ "cond") . sel]) - (letrec - ((loop - (lambda_match - ([(Sexpr loc [(Slid _ "else") . sel])] (begin_se loc sel)) - ([(Sexpr loc [se1 . sel1]) . sel] - (let* ((e1 (expr_se se1)) - (e2 (begin_se loc sel1)) - (e3 (loop sel))) - <:expr< if $e1$ then $e2$ else $e3$ >>)) - ([] <:expr< () >>) - ([se . _] (error se "cond clause"))))) - (loop sel))) - ((Sexpr loc [(Slid _ "while") se . sel]) - (let* ((e (expr_se se)) - (el (List.map expr_se sel))) - <:expr< while $e$ do { $list:el$ } >>)) - ((Sexpr loc [(Slid _ "for") (Slid _ i) se1 se2 . sel]) - (let* ((i (Pcaml.rename_id.val i)) - (e1 (expr_se se1)) - (e2 (expr_se se2)) - (el (List.map expr_se sel))) - <:expr< for $i$ = $e1$ to $e2$ do { $list:el$ } >>)) - ((Sexpr loc [(Slid loc1 "lambda")]) <:expr< fun [] >>) - ((Sexpr loc [(Slid loc1 "lambda") sep . sel]) - (let ((e (begin_se loc1 sel))) - (match (ipatt_opt_se sep) - ((Left p) <:expr< fun $p$ -> $e$ >>) - ((Right (values se sel)) - (List.fold_right - (lambda (se e) - (let ((p (ipatt_se se))) <:expr< fun $p$ -> $e$ >>)) - [se . sel] e))))) - ((Sexpr loc [(Slid _ "lambda_match") . sel]) - (let ((pel (List.map (match_case loc) sel))) - <:expr< fun [ $list:pel$ ] >>)) - ((Sexpr loc [(Slid _ (as (or "let" "letrec") r)) . sel]) - (match sel - ([(Sexpr _ sel1) . sel2] - (let* ((r (= r "letrec")) - (lbs (List.map let_binding_se sel1)) - (e (begin_se loc sel2))) - <:expr< let $opt:r$ $list:lbs$ in $e$ >>)) - ([(Slid _ n) (Sexpr _ sl) . sel] - (let* ((n (Pcaml.rename_id.val n)) - ((values pl el) - (List.fold_right - (lambda (se (values pl el)) - (match se - ((Sexpr _ [se1 se2]) - (values [(patt_se se1) . pl] - [(expr_se se2) . el])) - (se (error se "named let")))) - sl (values [] []))) - (e1 - (List.fold_right - (lambda (p e) <:expr< fun $p$ -> $e$ >>) - pl (begin_se loc sel))) - (e2 - (List.fold_left - (lambda (e1 e2) <:expr< $e1$ $e2$ >>) - <:expr< $lid:n$ >> el))) - <:expr< let rec $lid:n$ = $e1$ in $e2$ >>)) - ([se . _] (error se "let_binding")) - (_ (error_loc loc "let_binding")))) - ((Sexpr loc [(Slid _ "let*") . sel]) - (match sel - ([(Sexpr _ sel1) . sel2] - (List.fold_right - (lambda (se ek) - (let (((values p e) (let_binding_se se))) - <:expr< let $p$ = $e$ in $ek$ >>)) - sel1 (begin_se loc sel2))) - ([se . _] (error se "let_binding")) - (_ (error_loc loc "let_binding")))) - ((Sexpr loc [(Slid _ "match") se . sel]) - (let* ((e (expr_se se)) - (pel (List.map (match_case loc) sel))) - <:expr< match $e$ with [ $list:pel$ ] >>)) - ((Sexpr loc [(Slid _ "parser") . sel]) - (let ((e - (match sel - ([(as (Slid _ _) se) . sel] - (let* ((p (patt_se se)) - (pc (parser_cases_se loc sel))) - <:expr< let $p$ = Stream.count $lid:strm_n$ in $pc$ >>)) - (_ (parser_cases_se loc sel))))) - <:expr< fun ($lid:strm_n$ : Stream.t _) -> $e$ >>)) - ((Sexpr loc [(Slid _ "match_with_parser") se . sel]) - (let* ((me (expr_se se)) - ((values bpo sel) - (match sel - ([(as (Slid _ _) se) . sel] (values (Some (patt_se se)) sel)) - (_ (values None sel)))) - (pc (parser_cases_se loc sel)) - (e - (match bpo - ((Some bp) - <:expr< let $bp$ = Stream.count $lid:strm_n$ in $pc$ >>) - (None pc)))) - (match me - ((when <:expr< $lid:x$ >> (= x strm_n)) e) - (_ <:expr< let ($lid:strm_n$ : Stream.t _) = $me$ in $e$ >>)))) - ((Sexpr loc [(Slid _ "try") se . sel]) - (let* ((e (expr_se se)) - (pel (List.map (match_case loc) sel))) - <:expr< try $e$ with [ $list:pel$ ] >>)) - ((Sexpr loc [(Slid _ "begin") . sel]) - (let ((el (List.map expr_se sel))) <:expr< do { $list:el$ } >>)) - ((Sexpr loc [(Slid _ ":=") se1 se2]) - (let* ((e1 (expr_se se1)) - (e2 (expr_se se2))) - <:expr< $e1$ := $e2$ >>)) - ((Sexpr loc [(Slid _ "values") . sel]) - (let ((el (List.map expr_se sel))) <:expr< ( $list:el$ ) >>)) - ((Srec loc [(Slid _ "with") se . sel]) - (let* ((e (expr_se se)) - (lel (List.map (label_expr_se loc) sel))) - <:expr< { ($e$) with $list:lel$ } >>)) - ((Srec loc sel) - (let ((lel (List.map (label_expr_se loc) sel))) - <:expr< { $list:lel$ } >>)) - ((Sexpr loc [(Slid _ ":") se1 se2]) - (let* ((e (expr_se se1)) (t (ctyp_se se2))) <:expr< ( $e$ : $t$ ) >>)) - ((Sexpr loc [se]) (let ((e (expr_se se))) <:expr< $e$ () >>)) - ((Sexpr loc [(Slid _ "assert") se]) - (let ((e (expr_se se))) <:expr< assert $e$ >>)) - ((Sexpr loc [(Slid _ "lazy") se]) - (let ((e (expr_se se))) <:expr< lazy $e$ >>)) - ((Sexpr loc [se . sel]) - (List.fold_left - (lambda (e se) (let ((e1 (expr_se se))) <:expr< $e$ $e1$ >>)) - (expr_se se) sel)) - ((Slist loc sel) - (letrec ((loop - (lambda_match - ([] <:expr< [] >>) - ([se1 (Slid _ ".") se2] - (let* ((e (expr_se se1)) - (el (expr_se se2))) - <:expr< [$e$ :: $el$] >>)) - ([se . sel] - (let* ((e (expr_se se)) - (el (loop sel))) - <:expr< [$e$ :: $el$] >>))))) - (loop sel))) - ((Squot loc typ txt) - (Pcaml.handle_expr_quotation loc (values typ txt))))) - ((begin_se loc) - (lambda_match - ([] <:expr< () >>) - ([se] (expr_se se)) - ((sel) - (let* ((el (List.map expr_se sel)) - (loc (values (fst (loc_of_sexpr (List.hd sel))) (snd loc)))) - <:expr< do { $list:el$ } >>)))) - (let_binding_se - (lambda_match - ((Sexpr loc [se . sel]) - (let ((e (begin_se loc sel))) - (match (ipatt_opt_se se) - ((Left p) (values p e)) - ((Right _) (fun_binding_se se e))))) - (se (error se "let_binding")))) - ((fun_binding_se se e) - (match se - ((Sexpr _ [(Slid _ "values") . _]) (values (ipatt_se se) e)) - ((Sexpr _ [(Slid loc s) . sel]) - (let* ((s (Pcaml.rename_id.val s)) - (e - (List.fold_right - (lambda (se e) - (let* ((loc - (values (fst (loc_of_sexpr se)) - (snd (MLast.loc_of_expr e)))) - (p (ipatt_se se))) - <:expr< fun $p$ -> $e$ >>)) - sel e)) - (p <:patt< $lid:s$ >>)) - (values p e))) - ((_) (values (ipatt_se se) e)))) - ((match_case loc) - (lambda_match - ((Sexpr loc [(Sexpr _ [(Slid _ "when") se sew]) . sel]) - (values (patt_se se) (Some (expr_se sew)) (begin_se loc sel))) - ((Sexpr loc [se . sel]) - (values (patt_se se) None (begin_se loc sel))) - (se (error se "match_case")))) - ((label_expr_se loc) - (lambda_match - ((Sexpr _ [se1 se2]) (values (patt_se se1) (expr_se se2))) - (se (error se "label_expr")))) - ((label_patt_se loc) - (lambda_match - ((Sexpr _ [se1 se2]) (values (patt_se se1) (patt_se se2))) - (se (error se "label_patt")))) - ((parser_cases_se loc) - (lambda_match - ([] <:expr< raise Stream.Failure >>) - ([(Sexpr loc [(Sexpr _ spsel) . act]) . sel] - (let* ((ekont (lambda _ (parser_cases_se loc sel))) - (act (match act - ([se] (expr_se se)) - ([sep se] - (let* ((p (patt_se sep)) - (e (expr_se se))) - <:expr< let $p$ = Stream.count $lid:strm_n$ in $e$ >>)) - (_ (error_loc loc "parser_case"))))) - (stream_pattern_se loc act ekont spsel))) - ([se . _] - (error se "parser_case")))) - ((stream_pattern_se loc act ekont) - (lambda_match - ([] act) - ([se . sel] - (let* ((ckont (lambda err <:expr< raise (Stream.Error $err$) >>)) - (skont (stream_pattern_se loc act ckont sel))) - (stream_pattern_component skont ekont <:expr< "" >> se))))) - ((stream_pattern_component skont ekont err) - (lambda_match - ((Sexpr loc [(Slid _ "`") se . wol]) - (let* ((wo (match wol - ([se] (Some (expr_se se))) - ([] None) - (_ (error_loc loc "stream_pattern_component")))) - (e (peek_fun loc)) - (p (patt_se se)) - (j (junk_fun loc)) - (k (ekont err))) - <:expr< match $e$ $lid:strm_n$ with - [ Some $p$ $when:wo$ -> do { $j$ $lid:strm_n$ ; $skont$ } - | _ -> $k$ ] >>)) - ((Sexpr loc [se1 se2]) - (let* ((p (patt_se se1)) - (e (let ((e (expr_se se2))) - <:expr< try Some ($e$ $lid:strm_n$) with [ Stream.Failure -> None ] >>)) - (k (ekont err))) - <:expr< match $e$ with [ Some $p$ -> $skont$ | _ -> $k$ ] >>)) - ((Sexpr loc [(Slid _ "?") se1 se2]) - (stream_pattern_component skont ekont (expr_se se2) se1)) - ((Slid loc s) - (let ((s (Pcaml.rename_id.val s))) - <:expr< let $lid:s$ = $lid:strm_n$ in $skont$ >>)) - (se - (error se "stream_pattern_component")))) - (patt_se - (lambda_match - ((Sacc loc se1 se2) - (let* ((p1 (patt_se se1)) (p2 (patt_se se2))) <:patt< $p1$ . $p2$ >>)) - ((Slid loc "_") <:patt< _ >>) - ((Slid loc s) <:patt< $lid:(Pcaml.rename_id.val s)$ >>) - ((Suid loc s) <:patt< $uid:(Pcaml.rename_id.val s)$ >>) - ((Sint loc s) <:patt< $int:s$ >>) - ((Sfloat loc s) <:patt< $flo:s$ >>) - ((Schar loc s) <:patt< $chr:s$ >>) - ((Sstring loc s) <:patt< $str:s$ >>) - ((Stid loc _) (error_loc loc "patt")) - ((Sqid loc _) (error_loc loc "patt")) - ((Srec loc sel) - (let ((lpl (List.map (label_patt_se loc) sel))) - <:patt< { $list:lpl$ } >>)) - ((Sexpr loc [(Slid _ ":") se1 se2]) - (let* ((p (patt_se se1)) (t (ctyp_se se2))) <:patt< ($p$ : $t$) >>)) - ((Sexpr loc [(Slid _ "or") se . sel]) - (List.fold_left - (lambda (p se) (let ((p1 (patt_se se))) <:patt< $p$ | $p1$ >>)) - (patt_se se) sel)) - ((Sexpr loc [(Slid _ "range") se1 se2]) - (let* ((p1 (patt_se se1)) (p2 (patt_se se2))) <:patt< $p1$ .. $p2$ >>)) - ((Sexpr loc [(Slid _ "values") . sel]) - (let ((pl (List.map patt_se sel))) <:patt< ( $list:pl$ ) >>)) - ((Sexpr loc [(Slid _ "as") se1 se2]) - (let* ((p1 (patt_se se1)) - (p2 (patt_se se2))) - <:patt< ($p1$ as $p2$) >>)) - ((Sexpr loc [se . sel]) - (List.fold_left - (lambda (p se) (let ((p1 (patt_se se))) <:patt< $p$ $p1$ >>)) - (patt_se se) sel)) - ((Sexpr loc []) <:patt< () >>) - ((Slist loc sel) - (letrec ((loop - (lambda_match - ([] <:patt< [] >>) - ([se1 (Slid _ ".") se2] - (let* ((p (patt_se se1)) - (pl (patt_se se2))) - <:patt< [$p$ :: $pl$] >>)) - ([se . sel] - (let* ((p (patt_se se)) - (pl (loop sel))) - <:patt< [$p$ :: $pl$] >>))))) - (loop sel))) - ((Squot loc typ txt) - (Pcaml.handle_patt_quotation loc (values typ txt))))) - ((ipatt_se se) - (match (ipatt_opt_se se) - ((Left p) p) - ((Right (values se _)) (error se "ipatt")))) - (ipatt_opt_se - (lambda_match - ((Slid loc "_") (Left <:patt< _ >>)) - ((Slid loc s) (Left <:patt< $lid:(Pcaml.rename_id.val s)$ >>)) - ((Stid loc s) (Left <:patt< ~ $(Pcaml.rename_id.val s)$ >>)) - ((Sqid loc s) (Left <:patt< ? $(Pcaml.rename_id.val s)$ >>)) - ((Sexpr loc [(Sqid _ s) se]) - (let* ((s (Pcaml.rename_id.val s)) - (e (expr_se se))) - (Left <:patt< ? ( $lid:s$ = $e$ ) >>))) - ((Sexpr loc [(Slid _ ":") se1 se2]) - (let* ((p (ipatt_se se1)) (t (ctyp_se se2))) - (Left <:patt< ($p$ : $t$) >>))) - ((Sexpr loc [(Slid _ "values") . sel]) - (let ((pl (List.map ipatt_se sel))) (Left <:patt< ( $list:pl$ ) >>))) - ((Sexpr loc []) (Left <:patt< () >>)) - ((Sexpr loc [se . sel]) (Right (values se sel))) - (se (error se "ipatt")))) - (type_declaration_list_se - (lambda_match - ([se1 se2 . sel] - (let (((values n1 loc1 tpl) - (match se1 - ((Sexpr _ [(Slid loc n) . sel]) - (values n loc (List.map type_parameter_se sel))) - ((Slid loc n) - (values n loc [])) - ((se) - (error se "type declaration"))))) - [(values (values loc1 (Pcaml.rename_id.val n1)) tpl (ctyp_se se2) []) . - (type_declaration_list_se sel)])) - ([] []) - ([se . _] (error se "type_declaration")))) - (type_parameter_se - (lambda_match - ((when (Slid _ s) (and (>= (String.length s) 2) (= s.[0] '''))) - (values (String.sub s 1 (- (String.length s) 1)) (values False False))) - (se - (error se "type_parameter")))) - (ctyp_se - (lambda_match - ((Sexpr loc [(Slid _ "sum") . sel]) - (let ((cdl (List.map constructor_declaration_se sel))) - <:ctyp< [ $list:cdl$ ] >>)) - ((Srec loc sel) - (let ((ldl (List.map label_declaration_se sel))) - <:ctyp< { $list:ldl$ } >>)) - ((Sexpr loc [(Slid _ "->") . (as [_ _ . _] sel)]) - (letrec - ((loop - (lambda_match - ([] (assert False)) - ([se] (ctyp_se se)) - ([se . sel] - (let* ((t1 (ctyp_se se)) - (loc (values (fst (loc_of_sexpr se)) (snd loc))) - (t2 (loop sel))) - <:ctyp< $t1$ -> $t2$ >>))))) - (loop sel))) - ((Sexpr loc [(Slid _ "*") . sel]) - (let ((tl (List.map ctyp_se sel))) <:ctyp< ($list:tl$) >>)) - ((Sexpr loc [se . sel]) - (List.fold_left - (lambda (t se) (let ((t2 (ctyp_se se))) <:ctyp< $t$ $t2$ >>)) - (ctyp_se se) sel)) - ((Sacc loc se1 se2) - (let* ((t1 (ctyp_se se1)) (t2 (ctyp_se se2))) <:ctyp< $t1$ . $t2$ >>)) - ((Slid loc "_") <:ctyp< _ >>) - ((Slid loc s) - (if (= s.[0] ''') - (let ((s (String.sub s 1 (- (String.length s) 1)))) - <:ctyp< '$s$ >>) - <:ctyp< $lid:(Pcaml.rename_id.val s)$ >>)) - ((Suid loc s) <:ctyp< $uid:(Pcaml.rename_id.val s)$ >>) - (se (error se "ctyp")))) - (constructor_declaration_se - (lambda_match - ((Sexpr loc [(Suid _ ci) . sel]) - (values loc (Pcaml.rename_id.val ci) (List.map ctyp_se sel))) - (se - (error se "constructor_declaration")))) - (label_declaration_se - (lambda_match - ((Sexpr loc [(Slid _ lab) (Slid _ "mutable") se]) - (values loc (Pcaml.rename_id.val lab) True (ctyp_se se))) - ((Sexpr loc [(Slid _ lab) se]) - (values loc (Pcaml.rename_id.val lab) False (ctyp_se se))) - (se - (error se "label_declaration"))))) - -(define directive_se - (lambda_match - ((Sexpr _ [(Slid _ s)]) (values s None)) - ((Sexpr _ [(Slid _ s) se]) (let ((e (expr_se se))) (values s (Some e)))) - (se (error se "directive")))) - -; Parser - -(:= Pcaml.syntax_name.val "Scheme") -(:= Pcaml.no_constructors_arity.val False) - -(begin - (Grammar.Unsafe.gram_reinit gram (lexer_gmake ())) - (Grammar.Unsafe.clear_entry interf) - (Grammar.Unsafe.clear_entry implem) - (Grammar.Unsafe.clear_entry top_phrase) - (Grammar.Unsafe.clear_entry use_file) - (Grammar.Unsafe.clear_entry module_type) - (Grammar.Unsafe.clear_entry module_expr) - (Grammar.Unsafe.clear_entry sig_item) - (Grammar.Unsafe.clear_entry str_item) - (Grammar.Unsafe.clear_entry expr) - (Grammar.Unsafe.clear_entry patt) - (Grammar.Unsafe.clear_entry ctyp) - (Grammar.Unsafe.clear_entry let_binding) - (Grammar.Unsafe.clear_entry type_declaration) - (Grammar.Unsafe.clear_entry class_type) - (Grammar.Unsafe.clear_entry class_expr) - (Grammar.Unsafe.clear_entry class_sig_item) - (Grammar.Unsafe.clear_entry class_str_item)) - -(:= Pcaml.parse_interf.val (Grammar.Entry.parse interf)) -(:= Pcaml.parse_implem.val (Grammar.Entry.parse implem)) - -(define sexpr (Grammar.Entry.create gram "sexpr")) - -(definerec leftify - (lambda_match - ((Sacc loc1 se1 se2) - (match (leftify se2) - ((Sacc loc2 se2 se3) (Sacc loc1 (Sacc loc2 se1 se2) se3)) - (se2 (Sacc loc1 se1 se2)))) - (x x))) - -EXTEND - GLOBAL : implem interf top_phrase use_file str_item sig_item expr - patt sexpr / - implem : - [ [ "#" / se = sexpr -> - (let (((values n dp) (directive_se se))) - (values [(values <:str_item< # $n$ $opt:dp$ >> loc)] True)) - | si = str_item / x = SELF -> - (let* (((values sil stopped) x) - (loc (MLast.loc_of_str_item si))) - (values [(values si loc) . sil] stopped)) - | EOI -> (values [] False) ] ] - / - interf : - [ [ "#" / se = sexpr -> - (let (((values n dp) (directive_se se))) - (values [(values <:sig_item< # $n$ $opt:dp$ >> loc)] True)) - | si = sig_item / x = SELF -> - (let* (((values sil stopped) x) - (loc (MLast.loc_of_sig_item si))) - (values [(values si loc) . sil] stopped)) - | EOI -> (values [] False) ] ] - / - top_phrase : - [ [ "#" / se = sexpr -> - (let (((values n dp) (directive_se se))) - (Some <:str_item< # $n$ $opt:dp$ >>)) - | se = sexpr -> (Some (str_item_se se)) - | EOI -> None ] ] - / - use_file : - [ [ "#" / se = sexpr -> - (let (((values n dp) (directive_se se))) - (values [<:str_item< # $n$ $opt:dp$ >>] True)) - | si = str_item / x = SELF -> - (let (((values sil stopped) x)) (values [si . sil] stopped)) - | EOI -> (values [] False) ] ] - / - str_item : - [ [ se = sexpr -> (str_item_se se) - | e = expr -> <:str_item< $exp:e$ >> ] ] - / - sig_item : - [ [ se = sexpr -> (sig_item_se se) ] ] - / - expr : - [ "top" - [ se = sexpr -> (expr_se se) ] ] - / - patt : - [ [ se = sexpr -> (patt_se se) ] ] - / - sexpr : - [ [ se1 = sexpr_dot / se2 = sexpr -> (leftify (Sacc loc se1 se2)) ] - | [ "(" / sl = LIST0 sexpr / ")" -> (Sexpr loc sl) - | "(" / sl = LIST0 sexpr / ")." / se = sexpr -> - (leftify (Sacc loc (Sexpr loc sl) se)) - | "[" / sl = LIST0 sexpr / "]" -> (Slist loc sl) - | "{" / sl = LIST0 sexpr / "}" -> (Srec loc sl) - | a = pa_extend_keyword -> (Slid loc a) - | s = LIDENT -> (Slid loc s) - | s = UIDENT -> (Suid loc s) - | s = TILDEIDENT -> (Stid loc s) - | s = QUESTIONIDENT -> (Sqid loc s) - | s = INT -> (Sint loc s) - | s = FLOAT -> (Sfloat loc s) - | s = CHAR -> (Schar loc s) - | s = STRING -> (Sstring loc s) - | s = QUOT -> - (let* ((i (String.index s ':')) - (typ (String.sub s 0 i)) - (txt (String.sub s (+ i 1) (- (- (String.length s) i) 1)))) - (Squot loc typ txt)) ] ] - / - sexpr_dot : - [ [ s = LIDENTDOT -> (Slid loc s) - | s = UIDENTDOT -> (Suid loc s) ] ] - / - pa_extend_keyword : - [ [ "_" -> "_" - | "," -> "," - | "=" -> "=" - | ":" -> ":" - | "." -> "." - | "/" -> "/" ] ] - / -END diff --git a/camlp4/etc/pa_schemer.ml b/camlp4/etc/pa_schemer.ml deleted file mode 100644 index a7d64ce4a5..0000000000 --- a/camlp4/etc/pa_schemer.ml +++ /dev/null @@ -1,1067 +0,0 @@ -(* camlp4 pa_r.cmo pa_rp.cmo pa_extend.cmo q_MLast.cmo pr_dump.cmo *) -(* File generated by pretty print; do not edit! *) - -open Pcaml; -open Stdpp; - -type choice 'a 'b = - [ Left of 'a - | Right of 'b ] -; - -(* Buffer *) - -module Buff = - struct - value buff = ref (String.create 80); - value store len x = - do { - if len >= String.length buff.val then - buff.val := buff.val ^ String.create (String.length buff.val) - else (); - buff.val.[len] := x; - succ len - } - ; - value get len = String.sub buff.val 0 len; - end -; - -(* Lexer *) - -value rec skip_to_eol = - parser - [ [: `'\n' | '\r' :] -> () - | [: `_; s :] -> skip_to_eol s ] -; - -value no_ident = ['('; ')'; '['; ']'; '{'; '}'; ' '; '\t'; '\n'; '\r'; ';']; - -value rec ident len = - parser - [ [: `'.' :] -> (Buff.get len, True) - | [: `x when not (List.mem x no_ident); s :] -> ident (Buff.store len x) s - | [: :] -> (Buff.get len, False) ] -; - -value identifier kwt (s, dot) = - let con = - try do { (Hashtbl.find kwt s : unit); "" } with - [ Not_found -> - match s.[0] with - [ 'A'..'Z' -> if dot then "UIDENTDOT" else "UIDENT" - | _ -> if dot then "LIDENTDOT" else "LIDENT" ] ] - in - (con, s) -; - -value rec string len = - parser - [ [: `'"' :] -> Buff.get len - | [: `'\\'; `c; s :] -> string (Buff.store (Buff.store len '\\') c) s - | [: `x; s :] -> string (Buff.store len x) s ] -; - -value rec end_exponent_part_under len = - parser - [ [: `('0'..'9' as c); s :] -> end_exponent_part_under (Buff.store len c) s - | [: :] -> ("FLOAT", Buff.get len) ] -; - -value end_exponent_part len = - parser - [ [: `('0'..'9' as c); s :] -> end_exponent_part_under (Buff.store len c) s - | [: :] -> raise (Stream.Error "ill-formed floating-point constant") ] -; - -value exponent_part len = - parser - [ [: `('+' | '-' as c); s :] -> end_exponent_part (Buff.store len c) s - | [: a = end_exponent_part len :] -> a ] -; - -value rec decimal_part len = - parser - [ [: `('0'..'9' as c); s :] -> decimal_part (Buff.store len c) s - | [: `'e' | 'E'; s :] -> exponent_part (Buff.store len 'E') s - | [: :] -> ("FLOAT", Buff.get len) ] -; - -value rec number len = - parser - [ [: `('0'..'9' as c); s :] -> number (Buff.store len c) s - | [: `'.'; s :] -> decimal_part (Buff.store len '.') s - | [: `'e' | 'E'; s :] -> exponent_part (Buff.store len 'E') s - | [: :] -> ("INT", Buff.get len) ] -; - -value binary = parser [: `('0'..'1' as c) :] -> c; - -value octal = parser [: `('0'..'7' as c) :] -> c; - -value hexa = parser [: `('0'..'9' | 'a'..'f' | 'A'..'F' as c) :] -> c; - -value rec digits_under kind len = - parser - [ [: d = kind; s :] -> digits_under kind (Buff.store len d) s - | [: :] -> Buff.get len ] -; - -value digits kind bp len = - parser - [ [: d = kind; s :] -> ("INT", digits_under kind (Buff.store len d) s) - | [: s :] ep -> - raise_with_loc (bp, ep) (Failure "ill-formed integer constant") ] -; - -value base_number kwt bp len = - parser - [ [: `'b' | 'B'; s :] -> digits binary bp (Buff.store len 'b') s - | [: `'o' | 'O'; s :] -> digits octal bp (Buff.store len 'o') s - | [: `'x' | 'X'; s :] -> digits hexa bp (Buff.store len 'x') s - | [: id = ident (Buff.store 0 '#') :] -> identifier kwt id ] -; - -value rec operator len = - parser - [ [: `'.' :] -> Buff.get (Buff.store len '.') - | [: :] -> Buff.get len ] -; - -value char_or_quote_id x = - parser - [ [: `''' :] -> ("CHAR", String.make 1 x) - | [: s :] ep -> - if List.mem x no_ident then - Stdpp.raise_with_loc (ep - 2, ep - 1) (Stream.Error "bad quote") - else - let len = Buff.store (Buff.store 0 ''') x in - let (s, dot) = ident len s in - (if dot then "LIDENTDOT" else "LIDENT", s) ] -; - -value rec char len = - parser - [ [: `''' :] -> len - | [: `x; s :] -> char (Buff.store len x) s ] -; - -value quote = - parser - [ [: `'\\'; len = char (Buff.store 0 '\\') :] -> ("CHAR", Buff.get len) - | [: `x; s :] -> char_or_quote_id x s ] -; - -(* The system with LIDENTDOT and UIDENTDOT is not great (it would be *) -(* better to have a token DOT (actually SPACEDOT and DOT)) but it is *) -(* the only way (that I have found) to have a good behaviour in the *) -(* toplevel (not expecting tokens after a phrase). Drawbacks: 1/ to be *) -(* complete, we should have STRINGDOT, RIGHTPARENDOT, and so on 2/ the *) -(* parser rule with dot is right associative and we have to reverse *) -(* the resulting tree (using the function leftify). *) -(* This is a complicated issue: the behaviour of the OCaml toplevel *) -(* is strange, anyway. For example, even without Camlp4, The OCaml *) -(* toplevel accepts that: *) -(* # let x = 32;; foo bar match let ) *) - -value rec lexer kwt = parser [: t = lexer0 kwt; _ = no_dot :] -> t -and no_dot = - parser - [ [: `'.' :] ep -> - Stdpp.raise_with_loc (ep - 1, ep) (Stream.Error "bad dot") - | [: :] -> () ] -and lexer0 kwt = - parser bp - [ [: `'\t' | '\n' | '\r'; s :] -> lexer0 kwt s - | [: `' '; s :] -> after_space kwt s - | [: `';'; _ = skip_to_eol; s :] -> lexer kwt s - | [: `'(' :] -> (("", "("), (bp, bp + 1)) - | [: `')'; s :] ep -> (("", rparen s), (bp, ep)) - | [: `'[' :] -> (("", "["), (bp, bp + 1)) - | [: `']' :] -> (("", "]"), (bp, bp + 1)) - | [: `'{' :] -> (("", "{"), (bp, bp + 1)) - | [: `'}' :] -> (("", "}"), (bp, bp + 1)) - | [: `'"'; s = string 0 :] ep -> (("STRING", s), (bp, ep)) - | [: `'''; tok = quote :] ep -> (tok, (bp, ep)) - | [: `'<'; tok = less kwt :] ep -> (tok, (bp, ep)) - | [: `'-'; tok = minus kwt :] ep -> (tok, (bp, ep)) - | [: `'~'; tok = tilde :] ep -> (tok, (bp, ep)) - | [: `'?'; tok = question :] ep -> (tok, (bp, ep)) - | [: `'#'; tok = base_number kwt bp (Buff.store 0 '0') :] ep -> - (tok, (bp, ep)) - | [: `('0'..'9' as c); tok = number (Buff.store 0 c) :] ep -> - (tok, (bp, ep)) - | [: `('+' | '*' | '/' as c); id = operator (Buff.store 0 c) :] ep -> - (identifier kwt (id, False), (bp, ep)) - | [: `x; id = ident (Buff.store 0 x) :] ep -> (identifier kwt id, (bp, ep)) - | [: :] -> (("EOI", ""), (bp, bp + 1)) ] -and rparen = - parser - [ [: `'.' :] -> ")." - | [: ___ :] -> ")" ] -and after_space kwt = - parser - [ [: `'.' :] ep -> (("", "."), (ep - 1, ep)) - | [: x = lexer0 kwt :] -> x ] -and tilde = - parser - [ [: `('a'..'z' as c); (s, dot) = ident (Buff.store 0 c) :] -> - ("TILDEIDENT", s) - | [: :] -> ("LIDENT", "~") ] -and question = - parser - [ [: `('a'..'z' as c); (s, dot) = ident (Buff.store 0 c) :] -> - ("QUESTIONIDENT", s) - | [: :] -> ("LIDENT", "?") ] -and minus kwt = - parser - [ [: `'.' :] -> identifier kwt ("-.", False) - | [: `('0'..'9' as c); n = number (Buff.store (Buff.store 0 '-') c) :] ep -> - n - | [: id = ident (Buff.store 0 '-') :] -> identifier kwt id ] -and less kwt = - parser - [ [: `':'; lab = label 0; `'<' ? "'<' expected"; q = quotation 0 :] -> - ("QUOT", lab ^ ":" ^ q) - | [: id = ident (Buff.store 0 '<') :] -> identifier kwt id ] -and label len = - parser - [ [: `('a'..'z' | 'A'..'Z' | '_' as c); s :] -> label (Buff.store len c) s - | [: :] -> Buff.get len ] -and quotation len = - parser - [ [: `'>'; s :] -> quotation_greater len s - | [: `x; s :] -> quotation (Buff.store len x) s - | [: :] -> failwith "quotation not terminated" ] -and quotation_greater len = - parser - [ [: `'>' :] -> Buff.get len - | [: a = quotation (Buff.store len '>') :] -> a ] -; - -value lexer_using kwt (con, prm) = - match con with - [ "CHAR" | "EOI" | "INT" | "FLOAT" | "LIDENT" | "LIDENTDOT" | - "QUESTIONIDENT" | "QUOT" | "STRING" | "TILDEIDENT" | "UIDENT" | - "UIDENTDOT" -> - () - | "ANTIQUOT" -> () - | "" -> - try Hashtbl.find kwt prm with [ Not_found -> Hashtbl.add kwt prm () ] - | _ -> - raise - (Token.Error - ("the constructor \"" ^ con ^ "\" is not recognized by Plexer")) ] -; - -value lexer_text (con, prm) = - if con = "" then "'" ^ prm ^ "'" - else if prm = "" then con - else con ^ " \"" ^ prm ^ "\"" -; - -value lexer_gmake () = - let kwt = Hashtbl.create 89 in - {Token.tok_func = Token.lexer_func_of_parser (lexer kwt); - Token.tok_using = lexer_using kwt; Token.tok_removing = fun []; - Token.tok_match = Token.default_match; Token.tok_text = lexer_text; - Token.tok_comm = None} -; - -(* Building AST *) - -type sexpr = - [ Sacc of MLast.loc and sexpr and sexpr - | Schar of MLast.loc and string - | Sexpr of MLast.loc and list sexpr - | Sint of MLast.loc and string - | Sfloat of MLast.loc and string - | Slid of MLast.loc and string - | Slist of MLast.loc and list sexpr - | Sqid of MLast.loc and string - | Squot of MLast.loc and string and string - | Srec of MLast.loc and list sexpr - | Sstring of MLast.loc and string - | Stid of MLast.loc and string - | Suid of MLast.loc and string ] -; - -value loc_of_sexpr = - fun [ - Sacc loc _ _ | Schar loc _ | Sexpr loc _ | Sint loc _ | Sfloat loc _ | - Slid loc _ | Slist loc _ | Sqid loc _ | Squot loc _ _ | Srec loc _ | - Sstring loc _ | Stid loc _ | Suid loc _ -> - loc ] -; -value error_loc loc err = - raise_with_loc loc (Stream.Error (err ^ " expected")) -; -value error se err = error_loc (loc_of_sexpr se) err; - -value strm_n = "strm__"; -value peek_fun loc = <:expr< Stream.peek >>; -value junk_fun loc = <:expr< Stream.junk >>; - -value assoc_left_parsed_op_list = - ["+"; "*"; "+."; "*."; "land"; "lor"; "lxor"] -; -value assoc_right_parsed_op_list = ["and"; "or"; "^"; "@"]; -value and_by_couple_op_list = ["="; "<>"; "<"; ">"; "<="; ">="; "=="; "!="]; - -value op_apply loc e1 e2 = - fun - [ "and" -> <:expr< $e1$ && $e2$ >> - | "or" -> <:expr< $e1$ || $e2$ >> - | x -> <:expr< $lid:x$ $e1$ $e2$ >> ] -; - -value string_se = - fun - [ Sstring loc s -> s - | se -> error se "string" ] -; - -value mod_ident_se = - fun - [ Suid _ s -> [Pcaml.rename_id.val s] - | Slid _ s -> [Pcaml.rename_id.val s] - | se -> error se "mod_ident" ] -; - -value lident_expr loc s = - if String.length s > 1 && s.[0] = '`' then - let s = String.sub s 1 (String.length s - 1) in - <:expr< ` $s$ >> - else <:expr< $lid:(Pcaml.rename_id.val s)$ >> -; - -value rec module_expr_se = - fun - [ Sexpr loc [Slid _ "functor"; Suid _ s; se1; se2] -> - let s = Pcaml.rename_id.val s in - let mt = module_type_se se1 in - let me = module_expr_se se2 in - <:module_expr< functor ($s$ : $mt$) -> $me$ >> - | Sexpr loc [Slid _ "struct" :: sl] -> - let mel = List.map str_item_se sl in - <:module_expr< struct $list:mel$ end >> - | Sexpr loc [se1; se2] -> - let me1 = module_expr_se se1 in - let me2 = module_expr_se se2 in - <:module_expr< $me1$ $me2$ >> - | Suid loc s -> <:module_expr< $uid:(Pcaml.rename_id.val s)$ >> - | se -> error se "module expr" ] -and module_type_se = - fun - [ Sexpr loc [Slid _ "functor"; Suid _ s; se1; se2] -> - let s = Pcaml.rename_id.val s in - let mt1 = module_type_se se1 in - let mt2 = module_type_se se2 in - <:module_type< functor ($s$ : $mt1$) -> $mt2$ >> - | Sexpr loc [Slid _ "sig" :: sel] -> - let sil = List.map sig_item_se sel in - <:module_type< sig $list:sil$ end >> - | Sexpr loc [Slid _ "with"; se; Sexpr _ sel] -> - let mt = module_type_se se in - let wcl = List.map with_constr_se sel in - <:module_type< $mt$ with $list:wcl$ >> - | Suid loc s -> <:module_type< $uid:(Pcaml.rename_id.val s)$ >> - | se -> error se "module type" ] -and with_constr_se = - fun - [ Sexpr loc [Slid _ "type"; se1; se2] -> - let tn = mod_ident_se se1 in - let te = ctyp_se se2 in - MLast.WcTyp loc tn [] te - | se -> error se "with constr" ] -and sig_item_se = - fun - [ Sexpr loc [Slid _ "type" :: sel] -> - let tdl = type_declaration_list_se sel in - <:sig_item< type $list:tdl$ >> - | Sexpr loc [Slid _ "exception"; Suid _ c :: sel] -> - let c = Pcaml.rename_id.val c in - let tl = List.map ctyp_se sel in - <:sig_item< exception $c$ of $list:tl$ >> - | Sexpr loc [Slid _ "value"; Slid _ s; se] -> - let s = Pcaml.rename_id.val s in - let t = ctyp_se se in - <:sig_item< value $s$ : $t$ >> - | Sexpr loc [Slid _ "external"; Slid _ i; se :: sel] -> - let i = Pcaml.rename_id.val i in - let pd = List.map string_se sel in - let t = ctyp_se se in - <:sig_item< external $i$ : $t$ = $list:pd$ >> - | Sexpr loc [Slid _ "module"; Suid _ s; se] -> - let s = Pcaml.rename_id.val s in - let mb = module_type_se se in - <:sig_item< module $s$ : $mb$ >> - | Sexpr loc [Slid _ "moduletype"; Suid _ s; se] -> - let s = Pcaml.rename_id.val s in - let mt = module_type_se se in - <:sig_item< module type $s$ = $mt$ >> - | se -> error se "sig item" ] -and str_item_se se = - match se with - [ Sexpr loc [Slid _ "open"; se] -> - let s = mod_ident_se se in - <:str_item< open $s$ >> - | Sexpr loc [Slid _ "type" :: sel] -> - let tdl = type_declaration_list_se sel in - <:str_item< type $list:tdl$ >> - | Sexpr loc [Slid _ "exception"; Suid _ c :: sel] -> - let c = Pcaml.rename_id.val c in - let tl = List.map ctyp_se sel in - <:str_item< exception $c$ of $list:tl$ >> - | Sexpr loc [Slid _ ("define" | "definerec" as r); se :: sel] -> - let r = r = "definerec" in - let (p, e) = fun_binding_se se (begin_se loc sel) in - <:str_item< value $opt:r$ $p$ = $e$ >> - | Sexpr loc [Slid _ ("define*" | "definerec*" as r) :: sel] -> - let r = r = "definerec*" in - let lbs = List.map let_binding_se sel in - <:str_item< value $opt:r$ $list:lbs$ >> - | Sexpr loc [Slid _ "external"; Slid _ i; se :: sel] -> - let i = Pcaml.rename_id.val i in - let pd = List.map string_se sel in - let t = ctyp_se se in - <:str_item< external $i$ : $t$ = $list:pd$ >> - | Sexpr loc [Slid _ "module"; Suid _ i; se] -> - let i = Pcaml.rename_id.val i in - let mb = module_binding_se se in - <:str_item< module $i$ = $mb$ >> - | Sexpr loc [Slid _ "moduletype"; Suid _ s; se] -> - let s = Pcaml.rename_id.val s in - let mt = module_type_se se in - <:str_item< module type $s$ = $mt$ >> - | _ -> - let loc = loc_of_sexpr se in - let e = expr_se se in - <:str_item< $exp:e$ >> ] -and module_binding_se se = module_expr_se se -and expr_se = - fun - [ Sacc loc se1 se2 -> - let e1 = expr_se se1 in - match se2 with - [ Slist loc [se2] -> - let e2 = expr_se se2 in - <:expr< $e1$ .[ $e2$ ] >> - | Sexpr loc [se2] -> - let e2 = expr_se se2 in - <:expr< $e1$ .( $e2$ ) >> - | _ -> - let e2 = expr_se se2 in - <:expr< $e1$ . $e2$ >> ] - | Slid loc s -> lident_expr loc s - | Suid loc s -> <:expr< $uid:(Pcaml.rename_id.val s)$ >> - | Sint loc s -> <:expr< $int:s$ >> - | Sfloat loc s -> <:expr< $flo:s$ >> - | Schar loc s -> <:expr< $chr:s$ >> - | Sstring loc s -> <:expr< $str:s$ >> - | Stid loc s -> <:expr< ~ $(Pcaml.rename_id.val s)$ >> - | Sqid loc s -> <:expr< ? $(Pcaml.rename_id.val s)$ >> - | Sexpr loc [] -> <:expr< () >> - | Sexpr loc [Slid _ s; e1 :: ([_ :: _] as sel)] - when List.mem s assoc_left_parsed_op_list -> - let rec loop e1 = - fun - [ [] -> e1 - | [e2 :: el] -> loop (op_apply loc e1 e2 s) el ] - in - loop (expr_se e1) (List.map expr_se sel) - | Sexpr loc [Slid _ s :: ([_; _ :: _] as sel)] - when List.mem s assoc_right_parsed_op_list -> - let rec loop = - fun - [ [] -> assert False - | [e1] -> e1 - | [e1 :: el] -> - let e2 = loop el in - op_apply loc e1 e2 s ] - in - loop (List.map expr_se sel) - | Sexpr loc [Slid _ s :: ([_; _ :: _] as sel)] - when List.mem s and_by_couple_op_list -> - let rec loop = - fun - [ [] | [_] -> assert False - | [e1; e2] -> <:expr< $lid:s$ $e1$ $e2$ >> - | [e1 :: ([e2; _ :: _] as el)] -> - let a1 = op_apply loc e1 e2 s in - let a2 = loop el in - <:expr< $a1$ && $a2$ >> ] - in - loop (List.map expr_se sel) - | Sexpr loc [Stid _ s; se] -> - let e = expr_se se in - <:expr< ~ $s$ : $e$ >> - | Sexpr loc [Slid _ "-"; se] -> - let e = expr_se se in - <:expr< - $e$ >> - | Sexpr loc [Slid _ "if"; se; se1] -> - let e = expr_se se in - let e1 = expr_se se1 in - <:expr< if $e$ then $e1$ else () >> - | Sexpr loc [Slid _ "if"; se; se1; se2] -> - let e = expr_se se in - let e1 = expr_se se1 in - let e2 = expr_se se2 in - <:expr< if $e$ then $e1$ else $e2$ >> - | Sexpr loc [Slid _ "cond" :: sel] -> - let rec loop = - fun - [ [Sexpr loc [Slid _ "else" :: sel]] -> begin_se loc sel - | [Sexpr loc [se1 :: sel1] :: sel] -> - let e1 = expr_se se1 in - let e2 = begin_se loc sel1 in - let e3 = loop sel in - <:expr< if $e1$ then $e2$ else $e3$ >> - | [] -> <:expr< () >> - | [se :: _] -> error se "cond clause" ] - in - loop sel - | Sexpr loc [Slid _ "while"; se :: sel] -> - let e = expr_se se in - let el = List.map expr_se sel in - <:expr< while $e$ do { $list:el$ } >> - | Sexpr loc [Slid _ "for"; Slid _ i; se1; se2 :: sel] -> - let i = Pcaml.rename_id.val i in - let e1 = expr_se se1 in - let e2 = expr_se se2 in - let el = List.map expr_se sel in - <:expr< for $i$ = $e1$ to $e2$ do { $list:el$ } >> - | Sexpr loc [Slid loc1 "lambda"] -> <:expr< fun [] >> - | Sexpr loc [Slid loc1 "lambda"; sep :: sel] -> - let e = begin_se loc1 sel in - match ipatt_opt_se sep with - [ Left p -> <:expr< fun $p$ -> $e$ >> - | Right (se, sel) -> - List.fold_right - (fun se e -> - let p = ipatt_se se in - <:expr< fun $p$ -> $e$ >>) - [se :: sel] e ] - | Sexpr loc [Slid _ "lambda_match" :: sel] -> - let pel = List.map (match_case loc) sel in - <:expr< fun [ $list:pel$ ] >> - | Sexpr loc [Slid _ ("let" | "letrec" as r) :: sel] -> - match sel with - [ [Sexpr _ sel1 :: sel2] -> - let r = r = "letrec" in - let lbs = List.map let_binding_se sel1 in - let e = begin_se loc sel2 in - <:expr< let $opt:r$ $list:lbs$ in $e$ >> - | [Slid _ n; Sexpr _ sl :: sel] -> - let n = Pcaml.rename_id.val n in - let (pl, el) = - List.fold_right - (fun se (pl, el) -> - match se with - [ Sexpr _ [se1; se2] -> - ([patt_se se1 :: pl], [expr_se se2 :: el]) - | se -> error se "named let" ]) - sl ([], []) - in - let e1 = - List.fold_right (fun p e -> <:expr< fun $p$ -> $e$ >>) pl - (begin_se loc sel) - in - let e2 = - List.fold_left (fun e1 e2 -> <:expr< $e1$ $e2$ >>) - <:expr< $lid:n$ >> el - in - <:expr< let rec $lid:n$ = $e1$ in $e2$ >> - | [se :: _] -> error se "let_binding" - | _ -> error_loc loc "let_binding" ] - | Sexpr loc [Slid _ "let*" :: sel] -> - match sel with - [ [Sexpr _ sel1 :: sel2] -> - List.fold_right - (fun se ek -> - let (p, e) = let_binding_se se in - <:expr< let $p$ = $e$ in $ek$ >>) - sel1 (begin_se loc sel2) - | [se :: _] -> error se "let_binding" - | _ -> error_loc loc "let_binding" ] - | Sexpr loc [Slid _ "match"; se :: sel] -> - let e = expr_se se in - let pel = List.map (match_case loc) sel in - <:expr< match $e$ with [ $list:pel$ ] >> - | Sexpr loc [Slid _ "parser" :: sel] -> - let e = - match sel with - [ [(Slid _ _ as se) :: sel] -> - let p = patt_se se in - let pc = parser_cases_se loc sel in - <:expr< let $p$ = Stream.count $lid:strm_n$ in $pc$ >> - | _ -> parser_cases_se loc sel ] - in - <:expr< fun ($lid:strm_n$ : Stream.t _) -> $e$ >> - | Sexpr loc [Slid _ "match_with_parser"; se :: sel] -> - let me = expr_se se in - let (bpo, sel) = - match sel with - [ [(Slid _ _ as se) :: sel] -> (Some (patt_se se), sel) - | _ -> (None, sel) ] - in - let pc = parser_cases_se loc sel in - let e = - match bpo with - [ Some bp -> <:expr< let $bp$ = Stream.count $lid:strm_n$ in $pc$ >> - | None -> pc ] - in - match me with - [ <:expr< $lid:x$ >> when x = strm_n -> e - | _ -> <:expr< let ($lid:strm_n$ : Stream.t _) = $me$ in $e$ >> ] - | Sexpr loc [Slid _ "try"; se :: sel] -> - let e = expr_se se in - let pel = List.map (match_case loc) sel in - <:expr< try $e$ with [ $list:pel$ ] >> - | Sexpr loc [Slid _ "begin" :: sel] -> - let el = List.map expr_se sel in - <:expr< do { $list:el$ } >> - | Sexpr loc [Slid _ ":="; se1; se2] -> - let e1 = expr_se se1 in - let e2 = expr_se se2 in - <:expr< $e1$ := $e2$ >> - | Sexpr loc [Slid _ "values" :: sel] -> - let el = List.map expr_se sel in - <:expr< ( $list:el$ ) >> - | Srec loc [Slid _ "with"; se :: sel] -> - let e = expr_se se in - let lel = List.map (label_expr_se loc) sel in - <:expr< { ($e$) with $list:lel$ } >> - | Srec loc sel -> - let lel = List.map (label_expr_se loc) sel in - <:expr< { $list:lel$ } >> - | Sexpr loc [Slid _ ":"; se1; se2] -> - let e = expr_se se1 in - let t = ctyp_se se2 in - <:expr< ( $e$ : $t$ ) >> - | Sexpr loc [se] -> - let e = expr_se se in - <:expr< $e$ () >> - | Sexpr loc [Slid _ "assert"; Suid _ "False" ] -> - <:expr< assert False >> - | Sexpr loc [Slid _ "assert"; se] -> - let e = expr_se se in - <:expr< assert $e$ >> - | Sexpr loc [Slid _ "lazy"; se] -> - let e = expr_se se in - <:expr< lazy $e$ >> - | Sexpr loc [se :: sel] -> - List.fold_left - (fun e se -> - let e1 = expr_se se in - <:expr< $e$ $e1$ >>) - (expr_se se) sel - | Slist loc sel -> - let rec loop = - fun - [ [] -> <:expr< [] >> - | [se1; Slid _ "."; se2] -> - let e = expr_se se1 in - let el = expr_se se2 in - <:expr< [$e$ :: $el$] >> - | [se :: sel] -> - let e = expr_se se in - let el = loop sel in - <:expr< [$e$ :: $el$] >> ] - in - loop sel - | Squot loc typ txt -> Pcaml.handle_expr_quotation loc (typ, txt) ] -and begin_se loc = - fun - [ [] -> <:expr< () >> - | [se] -> expr_se se - | sel -> - let el = List.map expr_se sel in - let loc = (fst (loc_of_sexpr (List.hd sel)), snd loc) in - <:expr< do { $list:el$ } >> ] -and let_binding_se = - fun - [ Sexpr loc [se :: sel] -> - let e = begin_se loc sel in - match ipatt_opt_se se with - [ Left p -> (p, e) - | Right _ -> fun_binding_se se e ] - | se -> error se "let_binding" ] -and fun_binding_se se e = - match se with - [ Sexpr _ [Slid _ "values" :: _] -> (ipatt_se se, e) - | Sexpr _ [Slid loc s :: sel] -> - let s = Pcaml.rename_id.val s in - let e = - List.fold_right - (fun se e -> - let loc = (fst (loc_of_sexpr se), snd (MLast.loc_of_expr e)) in - let p = ipatt_se se in - <:expr< fun $p$ -> $e$ >>) - sel e - in - let p = <:patt< $lid:s$ >> in - (p, e) - | _ -> (ipatt_se se, e) ] -and match_case loc = - fun - [ Sexpr loc [Sexpr _ [Slid _ "when"; se; sew] :: sel] -> - (patt_se se, Some (expr_se sew), begin_se loc sel) - | Sexpr loc [se :: sel] -> (patt_se se, None, begin_se loc sel) - | se -> error se "match_case" ] -and label_expr_se loc = - fun - [ Sexpr _ [se1; se2] -> (patt_se se1, expr_se se2) - | se -> error se "label_expr" ] -and label_patt_se loc = - fun - [ Sexpr _ [se1; se2] -> (patt_se se1, patt_se se2) - | se -> error se "label_patt" ] -and parser_cases_se loc = - fun - [ [] -> <:expr< raise Stream.Failure >> - | [Sexpr loc [Sexpr _ spsel :: act] :: sel] -> - let ekont _ = parser_cases_se loc sel in - let act = - match act with - [ [se] -> expr_se se - | [sep; se] -> - let p = patt_se sep in - let e = expr_se se in - <:expr< let $p$ = Stream.count $lid:strm_n$ in $e$ >> - | _ -> error_loc loc "parser_case" ] - in - stream_pattern_se loc act ekont spsel - | [se :: _] -> error se "parser_case" ] -and stream_pattern_se loc act ekont = - fun - [ [] -> act - | [se :: sel] -> - let ckont err = <:expr< raise (Stream.Error $err$) >> in - let skont = stream_pattern_se loc act ckont sel in - stream_pattern_component skont ekont <:expr< "" >> se ] -and stream_pattern_component skont ekont err = - fun - [ Sexpr loc [Slid _ "`"; se :: wol] -> - let wo = - match wol with - [ [se] -> Some (expr_se se) - | [] -> None - | _ -> error_loc loc "stream_pattern_component" ] - in - let e = peek_fun loc in - let p = patt_se se in - let j = junk_fun loc in - let k = ekont err in - <:expr< match $e$ $lid:strm_n$ with - [ Some $p$ $when:wo$ -> do { $j$ $lid:strm_n$ ; $skont$ } - | _ -> $k$ ] >> - | Sexpr loc [se1; se2] -> - let p = patt_se se1 in - let e = - let e = expr_se se2 in - <:expr< try Some ($e$ $lid:strm_n$) with [ Stream.Failure -> None ] >> - in - let k = ekont err in - <:expr< match $e$ with [ Some $p$ -> $skont$ | _ -> $k$ ] >> - | Sexpr loc [Slid _ "?"; se1; se2] -> - stream_pattern_component skont ekont (expr_se se2) se1 - | Slid loc s -> - let s = Pcaml.rename_id.val s in - <:expr< let $lid:s$ = $lid:strm_n$ in $skont$ >> - | se -> error se "stream_pattern_component" ] -and patt_se = - fun - [ Sacc loc se1 se2 -> - let p1 = patt_se se1 in - let p2 = patt_se se2 in - <:patt< $p1$ . $p2$ >> - | Slid loc "_" -> <:patt< _ >> - | Slid loc s -> <:patt< $lid:(Pcaml.rename_id.val s)$ >> - | Suid loc s -> <:patt< $uid:(Pcaml.rename_id.val s)$ >> - | Sint loc s -> <:patt< $int:s$ >> - | Sfloat loc s -> <:patt< $flo:s$ >> - | Schar loc s -> <:patt< $chr:s$ >> - | Sstring loc s -> <:patt< $str:s$ >> - | Stid loc _ -> error_loc loc "patt" - | Sqid loc _ -> error_loc loc "patt" - | Srec loc sel -> - let lpl = List.map (label_patt_se loc) sel in - <:patt< { $list:lpl$ } >> - | Sexpr loc [Slid _ ":"; se1; se2] -> - let p = patt_se se1 in - let t = ctyp_se se2 in - <:patt< ($p$ : $t$) >> - | Sexpr loc [Slid _ "or"; se :: sel] -> - List.fold_left - (fun p se -> - let p1 = patt_se se in - <:patt< $p$ | $p1$ >>) - (patt_se se) sel - | Sexpr loc [Slid _ "range"; se1; se2] -> - let p1 = patt_se se1 in - let p2 = patt_se se2 in - <:patt< $p1$ .. $p2$ >> - | Sexpr loc [Slid _ "values" :: sel] -> - let pl = List.map patt_se sel in - <:patt< ( $list:pl$ ) >> - | Sexpr loc [Slid _ "as"; se1; se2] -> - let p1 = patt_se se1 in - let p2 = patt_se se2 in - <:patt< ($p1$ as $p2$) >> - | Sexpr loc [se :: sel] -> - List.fold_left - (fun p se -> - let p1 = patt_se se in - <:patt< $p$ $p1$ >>) - (patt_se se) sel - | Sexpr loc [] -> <:patt< () >> - | Slist loc sel -> - let rec loop = - fun - [ [] -> <:patt< [] >> - | [se1; Slid _ "."; se2] -> - let p = patt_se se1 in - let pl = patt_se se2 in - <:patt< [$p$ :: $pl$] >> - | [se :: sel] -> - let p = patt_se se in - let pl = loop sel in - <:patt< [$p$ :: $pl$] >> ] - in - loop sel - | Squot loc typ txt -> Pcaml.handle_patt_quotation loc (typ, txt) ] -and ipatt_se se = - match ipatt_opt_se se with - [ Left p -> p - | Right (se, _) -> error se "ipatt" ] -and ipatt_opt_se = - fun - [ Slid loc "_" -> Left <:patt< _ >> - | Slid loc s -> Left <:patt< $lid:(Pcaml.rename_id.val s)$ >> - | Stid loc s -> Left <:patt< ~ $(Pcaml.rename_id.val s)$ >> - | Sqid loc s -> Left <:patt< ? $(Pcaml.rename_id.val s)$ >> - | Sexpr loc [Sqid _ s; se] -> - let s = Pcaml.rename_id.val s in - let e = expr_se se in - Left <:patt< ? ( $lid:s$ = $e$ ) >> - | Sexpr loc [Slid _ ":"; se1; se2] -> - let p = ipatt_se se1 in - let t = ctyp_se se2 in - Left <:patt< ($p$ : $t$) >> - | Sexpr loc [Slid _ "values" :: sel] -> - let pl = List.map ipatt_se sel in - Left <:patt< ( $list:pl$ ) >> - | Sexpr loc [] -> Left <:patt< () >> - | Sexpr loc [se :: sel] -> Right (se, sel) - | se -> error se "ipatt" ] -and type_declaration_list_se = - fun - [ [se1; se2 :: sel] -> - let (n1, loc1, tpl) = - match se1 with - [ Sexpr _ [Slid loc n :: sel] -> - (n, loc, List.map type_parameter_se sel) - | Slid loc n -> (n, loc, []) - | se -> error se "type declaration" ] - in - [((loc1, Pcaml.rename_id.val n1), tpl, ctyp_se se2, []) :: - type_declaration_list_se sel] - | [] -> [] - | [se :: _] -> error se "type_declaration" ] -and type_parameter_se = - fun - [ Slid _ s when String.length s >= 2 && s.[0] = ''' -> - (String.sub s 1 (String.length s - 1), (False, False)) - | se -> error se "type_parameter" ] -and ctyp_se = - fun - [ Sexpr loc [Slid _ "sum" :: sel] -> - let cdl = List.map constructor_declaration_se sel in - <:ctyp< [ $list:cdl$ ] >> - | Srec loc sel -> - let ldl = List.map label_declaration_se sel in - <:ctyp< { $list:ldl$ } >> - | Sexpr loc [Slid _ "->" :: ([_; _ :: _] as sel)] -> - let rec loop = - fun - [ [] -> assert False - | [se] -> ctyp_se se - | [se :: sel] -> - let t1 = ctyp_se se in - let loc = (fst (loc_of_sexpr se), snd loc) in - let t2 = loop sel in - <:ctyp< $t1$ -> $t2$ >> ] - in - loop sel - | Sexpr loc [Slid _ "*" :: sel] -> - let tl = List.map ctyp_se sel in - <:ctyp< ($list:tl$) >> - | Sexpr loc [se :: sel] -> - List.fold_left - (fun t se -> - let t2 = ctyp_se se in - <:ctyp< $t$ $t2$ >>) - (ctyp_se se) sel - | Sacc loc se1 se2 -> - let t1 = ctyp_se se1 in - let t2 = ctyp_se se2 in - <:ctyp< $t1$ . $t2$ >> - | Slid loc "_" -> <:ctyp< _ >> - | Slid loc s -> - if s.[0] = ''' then - let s = String.sub s 1 (String.length s - 1) in - <:ctyp< '$s$ >> - else <:ctyp< $lid:(Pcaml.rename_id.val s)$ >> - | Suid loc s -> <:ctyp< $uid:(Pcaml.rename_id.val s)$ >> - | se -> error se "ctyp" ] -and constructor_declaration_se = - fun - [ Sexpr loc [Suid _ ci :: sel] -> - (loc, Pcaml.rename_id.val ci, List.map ctyp_se sel) - | se -> error se "constructor_declaration" ] -and label_declaration_se = - fun - [ Sexpr loc [Slid _ lab; Slid _ "mutable"; se] -> - (loc, Pcaml.rename_id.val lab, True, ctyp_se se) - | Sexpr loc [Slid _ lab; se] -> - (loc, Pcaml.rename_id.val lab, False, ctyp_se se) - | se -> error se "label_declaration" ] -; - -value directive_se = - fun - [ Sexpr _ [Slid _ s] -> (s, None) - | Sexpr _ [Slid _ s; se] -> - let e = expr_se se in - (s, Some e) - | se -> error se "directive" ] -; - -(* Parser *) - -Pcaml.syntax_name.val := "Scheme"; -Pcaml.no_constructors_arity.val := False; - -do { - Grammar.Unsafe.gram_reinit gram (lexer_gmake ()); - Grammar.Unsafe.clear_entry interf; - Grammar.Unsafe.clear_entry implem; - Grammar.Unsafe.clear_entry top_phrase; - Grammar.Unsafe.clear_entry use_file; - Grammar.Unsafe.clear_entry module_type; - Grammar.Unsafe.clear_entry module_expr; - Grammar.Unsafe.clear_entry sig_item; - Grammar.Unsafe.clear_entry str_item; - Grammar.Unsafe.clear_entry expr; - Grammar.Unsafe.clear_entry patt; - Grammar.Unsafe.clear_entry ctyp; - Grammar.Unsafe.clear_entry let_binding; - Grammar.Unsafe.clear_entry type_declaration; - Grammar.Unsafe.clear_entry class_type; - Grammar.Unsafe.clear_entry class_expr; - Grammar.Unsafe.clear_entry class_sig_item; - Grammar.Unsafe.clear_entry class_str_item -}; - -Pcaml.parse_interf.val := Grammar.Entry.parse interf; -Pcaml.parse_implem.val := Grammar.Entry.parse implem; - -value sexpr = Grammar.Entry.create gram "sexpr"; - -value rec leftify = - fun - [ Sacc loc1 se1 se2 -> - match leftify se2 with - [ Sacc loc2 se2 se3 -> Sacc loc1 (Sacc loc2 se1 se2) se3 - | se2 -> Sacc loc1 se1 se2 ] - | x -> x ] -; - -EXTEND - GLOBAL: implem interf top_phrase use_file str_item sig_item expr patt sexpr; - implem: - [ [ "#"; se = sexpr -> - let (n, dp) = directive_se se in - ([(<:str_item< # $n$ $opt:dp$ >>, loc)], True) - | si = str_item; x = SELF -> - let (sil, stopped) = x in - let loc = MLast.loc_of_str_item si in - ([(si, loc) :: sil], stopped) - | EOI -> ([], False) ] ] - ; - interf: - [ [ "#"; se = sexpr -> - let (n, dp) = directive_se se in - ([(<:sig_item< # $n$ $opt:dp$ >>, loc)], True) - | si = sig_item; x = SELF -> - let (sil, stopped) = x in - let loc = MLast.loc_of_sig_item si in - ([(si, loc) :: sil], stopped) - | EOI -> ([], False) ] ] - ; - top_phrase: - [ [ "#"; se = sexpr -> - let (n, dp) = directive_se se in - Some <:str_item< # $n$ $opt:dp$ >> - | se = sexpr -> Some (str_item_se se) - | EOI -> None ] ] - ; - use_file: - [ [ "#"; se = sexpr -> - let (n, dp) = directive_se se in - ([<:str_item< # $n$ $opt:dp$ >>], True) - | si = str_item; x = SELF -> - let (sil, stopped) = x in - ([si :: sil], stopped) - | EOI -> ([], False) ] ] - ; - str_item: - [ [ se = sexpr -> str_item_se se - | e = expr -> <:str_item< $exp:e$ >> ] ] - ; - sig_item: - [ [ se = sexpr -> sig_item_se se ] ] - ; - expr: - [ "top" - [ se = sexpr -> expr_se se ] ] - ; - patt: - [ [ se = sexpr -> patt_se se ] ] - ; - sexpr: - [ [ se1 = sexpr_dot; se2 = SELF -> leftify (Sacc loc se1 se2) ] - | [ "("; sl = LIST0 sexpr; ")" -> Sexpr loc sl - | "("; sl = LIST0 sexpr; ")."; se = SELF -> - leftify (Sacc loc (Sexpr loc sl) se) - | "["; sl = LIST0 sexpr; "]" -> Slist loc sl - | "{"; sl = LIST0 sexpr; "}" -> Srec loc sl - | a = pa_extend_keyword -> Slid loc a - | s = LIDENT -> Slid loc s - | s = UIDENT -> Suid loc s - | s = TILDEIDENT -> Stid loc s - | s = QUESTIONIDENT -> Sqid loc s - | s = INT -> Sint loc s - | s = FLOAT -> Sfloat loc s - | s = CHAR -> Schar loc s - | s = STRING -> Sstring loc s - | s = QUOT -> - let i = String.index s ':' in - let typ = String.sub s 0 i in - let txt = String.sub s (i + 1) (String.length s - i - 1) in - Squot loc typ txt ] ] - ; - sexpr_dot: - [ [ s = LIDENTDOT -> Slid loc s - | s = UIDENTDOT -> Suid loc s ] ] - ; - pa_extend_keyword: - [ [ "_" -> "_" - | "," -> "," - | "=" -> "=" - | ":" -> ":" - | "." -> "." - | "/" -> "/" ] ] - ; -END; diff --git a/camlp4/etc/pa_sml.ml b/camlp4/etc/pa_sml.ml deleted file mode 100644 index ee5db540d1..0000000000 --- a/camlp4/etc/pa_sml.ml +++ /dev/null @@ -1,947 +0,0 @@ -(* camlp4r pa_extend.cmo q_MLast.cmo *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -open Stdpp; -open Pcaml; - -value ocaml_records = ref False; - -Pcaml.no_constructors_arity.val := True; - -value lexer = Plexer.gmake (); - -do { - Grammar.Unsafe.gram_reinit gram lexer; - Grammar.Unsafe.clear_entry interf; - Grammar.Unsafe.clear_entry implem; - Grammar.Unsafe.clear_entry top_phrase; - Grammar.Unsafe.clear_entry use_file; - Grammar.Unsafe.clear_entry module_type; - Grammar.Unsafe.clear_entry module_expr; - Grammar.Unsafe.clear_entry sig_item; - Grammar.Unsafe.clear_entry str_item; - Grammar.Unsafe.clear_entry expr; - Grammar.Unsafe.clear_entry patt; - Grammar.Unsafe.clear_entry ctyp; - Grammar.Unsafe.clear_entry let_binding; -}; - -Pcaml.parse_interf.val := Grammar.Entry.parse interf; -Pcaml.parse_implem.val := Grammar.Entry.parse implem; - -value not_impl loc s = - raise_with_loc loc (Stream.Error ("not implemented feature [" ^ s ^ "]")) -; - -type altern 'a 'b = [ Left of 'a | Right of 'b ]; - -value get_seq = - fun - [ <:expr< do { $list:el$ } >> -> el - | e -> [e] ] -; - -value choose_tvar tpl = - let rec find_alpha v = - let s = String.make 1 v in - if List.mem_assoc s tpl then - if v = 'z' then None else find_alpha (Char.chr (Char.code v + 1)) - else Some (String.make 1 v) - in - let rec make_n n = - let v = "a" ^ string_of_int n in - if List.mem_assoc v tpl then make_n (succ n) else v - in - match find_alpha 'a' with - [ Some x -> x - | None -> make_n 1 ] -; - -value mklistexp loc last = - loop True where rec loop top = - fun - [ [] -> - match last with - [ Some e -> e - | None -> <:expr< [] >> ] - | [e1 :: el] -> - let loc = if top then loc else (fst (MLast.loc_of_expr e1), snd loc) in - <:expr< [$e1$ :: $loop False el$] >> ] -; - -value mklistpat loc last = - loop True where rec loop top = - fun - [ [] -> - match last with - [ Some p -> p - | None -> <:patt< [] >> ] - | [p1 :: pl] -> - let loc = if top then loc else (fst (MLast.loc_of_patt p1), snd loc) in - <:patt< [$p1$ :: $loop False pl$] >> ] -; - -value expr_of_patt p = - let loc = MLast.loc_of_patt p in - match p with - [ <:patt< $lid:x$ >> -> <:expr< $lid:x$ >> - | _ -> Stdpp.raise_with_loc loc (Stream.Error "identifier expected") ] -; - -value apply_bind loc e bl = - let rec loop e = - fun - [ [] -> e - | [<:str_item< value $p1$ = $e1$ >> :: list] -> - loop_let e [(p1, e1)] list - | [<:str_item< value rec $p1$ = $e1$ >> :: list] -> - loop_letrec e [(p1, e1)] list - | [<:str_item< module $s$ = $me$ >> :: list] -> - let e = <:expr< let module $s$ = $me$ in $e$ >> in - loop e list - | [si :: list] -> - raise Exit ] - and loop_let e pel = - fun - [ [<:str_item< value $p1$ = $e1$ >> :: list] -> - loop_let e [(p1, e1) :: pel] list - | list -> - let e = <:expr< let $list:pel$ in $e$ >> in - loop e list ] - and loop_letrec e pel = - fun - [ [<:str_item< value rec $p1$ = $e1$ >> :: list] -> - loop_letrec e [(p1, e1) :: pel] list - | list -> - let e = <:expr< let rec $list:pel$ in $e$ >> in - loop e list ] - in - loop e (List.rev bl) -; - -value make_local loc sl1 sl2 = - try - let pl = - List.map - (fun - [ <:str_item< value $opt:_$ $p$ = $_$ >> -> p - | _ -> raise Exit ]) - sl2 - in - let e1 = - match List.map expr_of_patt pl with - [ [e] -> e - | el -> <:expr< ($list:el$) >> ] - in - let p1 = - match pl with - [ [p] -> p - | pl -> <:patt< ($list:pl$) >> ] - in - let e = apply_bind loc e1 sl2 in - let e = apply_bind loc e sl1 in - <:str_item< value $p1$ = $e$ >> - with - [ Exit -> - do { - Printf.eprintf "\ -*** Warning: a 'local' statement will be defined global because of bindings -which cannot be defined as first class values (modules, exceptions, ...)\n"; - flush stderr; - <:str_item< declare $list:sl1 @ sl2$ end >> - } ] -; - -value str_declare loc = - fun - [ [d] -> d - | dl -> <:str_item< declare $list:dl$ end >> ] -; - -value sig_declare loc = - fun - [ [d] -> d - | dl -> <:sig_item< declare $list:dl$ end >> ] -; - -value extract_label_types loc tn tal cdol = - let (cdl, aux) = - List.fold_right - (fun (loc, c, tl, aux_opt) (cdl, aux) -> - match aux_opt with - [ Some anon_record_type -> - let new_tn = tn ^ "_" ^ c in - let loc = MLast.loc_of_ctyp anon_record_type in - let aux_def = ((loc, new_tn), [], anon_record_type, []) in - let tl = [<:ctyp< $lid:new_tn$ >>] in - ([(loc, c, tl) :: cdl], [aux_def :: aux]) - | None -> ([(loc, c, tl) :: cdl], aux) ]) - cdol ([], []) - in - [((loc, tn), tal, <:ctyp< [ $list:cdl$ ] >>, []) :: aux] -; - -value function_of_clause_list loc xl = - let (fname, fname_loc, nbpat, l) = - List.fold_left - (fun (fname, fname_loc, nbpat, l) ((x1, loc), x2, x3, x4) -> - let (fname, fname_loc, nbpat) = - if fname = "" then (x1, loc, List.length x2) - else if x1 <> fname then - raise_with_loc loc - (Stream.Error ("'" ^ fname ^ "' expected")) - else if List.length x2 <> nbpat then - raise_with_loc loc - (Stream.Error "bad number of patterns in that clause") - else (fname, fname_loc, nbpat) - in - let x4 = - match x3 with - [ Some t -> <:expr< ($x4$ : $t$) >> - | _ -> x4 ] - in - let l = [(x2, x4) :: l] in - (fname, fname_loc, nbpat, l)) - ("", loc, 0, []) xl - in - let l = List.rev l in - let e = - match l with - [ [(pl, e)] -> - List.fold_right (fun p e -> <:expr< fun $p$ -> $e$ >>) pl e - | _ -> - if nbpat = 1 then - let pwel = - List.map - (fun (pl, e) -> (<:patt< $List.hd pl$ >>, None, e)) l - in - <:expr< fun [ $list:pwel$ ] >> - else - let sl = - loop 0 where rec loop n = - if n = nbpat then [] - else ["a" ^ string_of_int (n + 1) :: loop (n + 1)] - in - let e = - let el = List.map (fun s -> <:expr< $lid:s$ >>) sl in - let pwel = - List.map - (fun (pl, e) -> (<:patt< ($list:pl$) >>, None, e)) l - in - <:expr< match ($list:el$) with [ $list:pwel$ ] >> - in - List.fold_right (fun s e -> <:expr< fun $lid:s$ -> $e$ >>) sl e ] - in - (let loc = fname_loc in <:patt< $lid:fname$ >>, e) -; - -value record_expr loc x1 = - if ocaml_records.val then <:expr< { $list:x1$ } >> - else - let list1 = - List.map - (fun (l, v) -> - let id = - match l with - [ <:patt< $lid:l$ >> -> l - | _ -> "" ] - in - let loc = MLast.loc_of_expr v in - <:class_str_item< value $id$ = $v$ >>) - x1 - in - let list2 = - List.map - (fun (l, v) -> - let id = - match l with - [ <:patt< $lid:l$ >> -> l - | _ -> "" ] - in - let loc = MLast.loc_of_patt l in - <:class_str_item< method $id$ = $lid:id$ >>) - x1 - in - <:expr< - let module M = - struct - class a = object $list:list1 @ list2$ end; - end - in - new M.a - >> -; - -value record_match_assoc loc lpl e = - if ocaml_records.val then (<:patt< { $list:lpl$ } >>, e) - else - let pl = List.map (fun (_, p) -> p) lpl in - let e = - let el = - List.map - (fun (l, _) -> - let s = - match l with - [ <:patt< $lid:l$ >> -> l - | _ -> "" ] - in - let loc = MLast.loc_of_patt l in - <:expr< v # $lid:s$ >>) - lpl - in - let loc = MLast.loc_of_expr e in - <:expr< let v = $e$ in ($list:el$) >> - in - let p = <:patt< ($list:pl$) >> in - (p, e) -; - -value op = - Grammar.Entry.of_parser gram "op" - (parser [: `("", "op"); `(_, x) :] -> x) -; -lexer.Token.tok_using ("", "op"); - -value special x = - if String.length x >= 2 then - match x.[0] with - [ '+' | '<' | '^' -> True - | _ -> False ] - else False -; - -value idd = - let p = - parser - [ [: `("LIDENT", x) :] -> x - | [: `("UIDENT", x) :] -> x - | [: `("", "op"); `(_, x) :] -> x - | [: `("", x) when special x :] -> x ] - in - Grammar.Entry.of_parser Pcaml.gram "ID" p -; - -value uncap s = String.uncapitalize s; - -EXTEND - GLOBAL: implem interf top_phrase use_file sig_item str_item ctyp patt expr - module_type module_expr; - - implem: - [ [ x = interdec; EOI -> x ] ] - ; - interf: - [ [ x = LIST1 [ s = sig_item; OPT ";" -> (s, loc) ] -> (x, False) ] ] - ; - top_phrase: - [ [ ph = phrase; ";" -> Some ph - | EOI -> None ] ] - ; - use_file: - [ [ l = LIST0 phrase; EOI -> (l, False) ] ] - ; - phrase: - [ [ x = str_item -> x - | x = expr -> <:str_item< $exp:x$ >> - | "#"; n = LIDENT; dp = dir_param -> MLast.StDir loc n dp ] ] - ; - dir_param: - [ [ -> None - | e = expr -> Some e ] ] - ; - sdecs: - [ [ x = sdec; l = sdecs -> [x :: l] - | ";"; l = sdecs -> l - | -> [] ] ] - ; - - fsigb: [ [ -> not_impl loc "fsigb" ] ]; - fsigconstraint_op: [ [ -> not_impl loc "fsigconstraint_op" ] ]; - fct_exp: [ [ -> not_impl loc "fct_exp" ] ]; - exp_pa: [ [ -> not_impl loc "exp_pa" ] ]; - rvb: [ [ -> not_impl loc "rvb" ] ]; - tyvarseq: [ [ -> not_impl loc "tyvarseq" ] ]; - - tyvar_pc: - [ [ "'"; x1 = LIDENT -> [(x1, (False, False))] - | "'"; x1 = LIDENT; ","; l = tyvar_pc -> [(x1, (False, False)) :: l] ] ] - ; - id: - [ [ x1 = idd -> x1 - | "*" -> "*" ] ] - ; - ident: - [ [ x1 = idd -> x1 - | "*" -> "*" - | "=" -> "=" - | "<" -> "<" - | ">" -> ">" - | "<=" -> "<=" - | ">=" -> ">=" - | "^" -> "^" ] ] - ; - op_op: - [ [ x1 = op -> not_impl loc "op_op 1" - | -> () ] ] - ; - qid: - [ [ x1 = idd; "."; x2 = qid -> <:module_expr< $uid:x1$ . $x2$ >> - | x1 = idd -> <:module_expr< $uid:x1$ >> - | x1 = "*" -> <:module_expr< $uid:x1$ >> - | x1 = "=" -> <:module_expr< $uid:x1$ >> ] ] - ; - eqid: - [ [ x1 = UIDENT; "."; x2 = eqid -> <:expr< $uid:x1$ . $x2$ >> - | x1 = UIDENT -> <:expr< $uid:x1$ >> - | x1 = idd -> <:expr< $lid:x1$ >> - | x1 = "*" -> <:expr< $lid:x1$ >> - | x1 = "=" -> <:expr< $lid:x1$ >> ] ] - ; - sqid: - [ [ x1 = idd; "."; x2 = sqid -> [x1 :: x2] - | x1 = idd -> [x1] - | x1 = "*" -> [x1] - | x1 = "=" -> [x1] ] ] - ; - tycon: - [ [ LIDENT "real" -> <:ctyp< float >> - | x1 = idd; "."; x2 = tycon -> - let r = <:ctyp< $uid:x1$ . $x2$ >> in - loop r where rec loop = - fun - [ <:ctyp< $a$ . ($b$ . $c$) >> -> <:ctyp< $a$ . $b$ . $loop c$ >> - | x -> x ] - | x1 = idd -> <:ctyp< $lid:uncap x1$ >> ] ] - ; - selector: - [ [ x1 = id -> x1 - | x1 = INT -> not_impl loc "selector 1" ] ] - ; - tlabel: - [ [ x1 = selector; ":"; x2 = ctyp -> (loc, x1, False, x2) ] ] - ; - tuple_ty: - [ [ x1 = ctyp LEVEL "ty'"; "*"; x2 = tuple_ty -> [x1 :: x2] - | x1 = ctyp LEVEL "ty'" -> [x1] ] ] - ; - ctyp: - [ RIGHTA - [ x1 = ctyp; "->"; x2 = ctyp -> <:ctyp< $x1$ -> $x2$ >> ] - | [ x1 = ctyp; "*"; x2 = tuple_ty -> <:ctyp< ($list:[x1 :: x2]$) >> ] - | "ty'" - [ "'"; x1 = LIDENT -> <:ctyp< '$x1$ >> - | "'"; "'"; x1 = LIDENT -> <:ctyp< '$x1$ >> - | "{"; x1 = LIST1 tlabel SEP ","; "}" -> - if ocaml_records.val then <:ctyp< { $list:x1$ } >> - else - let list = List.map (fun (_, l, _, t) -> (l, t)) x1 in - <:ctyp< < $list:list$ > >> - | "{"; "}" -> not_impl loc "ty' 3" - | "("; x1 = ctyp; ","; x2 = LIST1 ctyp SEP ","; ")"; x3 = tycon -> - List.fold_left (fun t1 t2 -> <:ctyp< $t1$ $t2$ >>) x3 [x1 :: x2] - | "("; x1 = ctyp; ")" -> x1 - | x1 = ctyp; x2 = tycon -> <:ctyp< $x2$ $x1$ >> - | x1 = tycon -> x1 ] ] - ; - rule: - [ [ x1 = patt; "=>"; x2 = expr -> (x1, None, x2) ] ] - ; - elabel: - [ [ x1 = selector; "="; x2 = expr -> (<:patt< $lid:x1$ >>, x2) ] ] - ; - exp_ps: - [ [ x1 = expr -> x1 - | x1 = expr; ";"; x2 = exp_ps -> - <:expr< do { $list:[x1 :: get_seq x2]$ } >> ] ] - ; - expr: - [ [ "if"; x1 = expr; "then"; x2 = expr; "else"; x3 = expr -> - <:expr< if $x1$ then $x2$ else $x3$ >> - | "fn"; x1 = LIST1 rule SEP "|" -> <:expr< fun [$list:x1$] >> - | "case"; x1 = expr; "of"; x2 = LIST1 rule SEP "|" -> - <:expr< match $x1$ with [$list:x2$] >> - | "while"; x1 = expr; "do"; x2 = expr -> - <:expr< while $x1$ do { $x2$ } >> - | x1 = expr; "handle"; x2 = LIST1 rule SEP "|" -> - <:expr< try $x1$ with [$list:x2$] >> ] - | RIGHTA - [ "raise"; x1 = expr -> <:expr< raise $x1$ >> ] - | [ e1 = expr; ":="; e2 = expr -> <:expr< $e1$.val := $e2$ >> ] - | LEFTA - [ x1 = expr; "orelse"; x2 = expr -> <:expr< $x1$ || $x2$ >> ] - | LEFTA - [ x1 = expr; "andalso"; x2 = expr -> <:expr< $x1$ && $x2$ >> ] - | LEFTA - [ x1 = expr; ":"; x2 = ctyp -> <:expr< ($x1$ : $x2$) >> ] - | "4" NONA - [ x1 = expr; "<"; x2 = expr -> <:expr< $x1$ < $x2$ >> - | x1 = expr; ">"; x2 = expr -> <:expr< $x1$ > $x2$ >> - | x1 = expr; "<>"; x2 = expr -> <:expr< $x1$ <> $x2$ >> - | x1 = expr; "="; x2 = expr -> <:expr< $x1$ = $x2$ >> - | x1 = expr; ">="; x2 = expr -> <:expr< $x1$ >= $x2$ >> - | x1 = expr; "<="; x2 = expr -> <:expr< $x1$ <= $x2$ >> ] - | RIGHTA - [ x1 = expr; "^"; x2 = expr -> <:expr< $x1$ ^ $x2$ >> - | x1 = expr; "@"; x2 = expr -> <:expr< $x1$ @ $x2$ >> - | x1 = expr; "o"; x2 = expr -> <:expr< ooo $x1$ $x2$ >> ] - | "5" RIGHTA - [ x1 = expr; "::"; x2 = expr -> <:expr< [$x1$ :: $x2$] >> ] - | "6" LEFTA - [ x1 = expr; "+"; x2 = expr -> <:expr< $x1$ + $x2$ >> - | x1 = expr; "-"; x2 = expr -> <:expr< $x1$ - $x2$ >> ] - | "7" LEFTA - [ x1 = expr; "*"; x2 = expr -> <:expr< $x1$ * $x2$ >> - | x1 = expr; "/"; x2 = expr -> <:expr< $x1$ / $x2$ >> - | x1 = expr; "div"; x2 = expr -> <:expr< $x1$ / $x2$ >> - | x1 = expr; "mod"; x2 = expr -> <:expr< $x1$ mod $x2$ >> ] - | LEFTA - [ x1 = expr; x2 = expr -> <:expr< $x1$ $x2$ >> ] - | [ "#"; x1 = STRING -> <:expr< $chr:x1$ >> - | "#"; x1 = selector; x2 = expr -> - if ocaml_records.val then <:expr< $x2$ . $lid:x1$ >> - else <:expr< $x2$ # $lid:x1$ >> - | x1 = expr; "ocaml_record_access"; x2 = expr -> <:expr< $x1$ . $x2$ >> ] - | [ "!"; x1 = expr -> <:expr< $x1$ . val >> - | "~"; x1 = expr -> <:expr< - $x1$ >> ] - | [ x1 = LIDENT -> - match x1 with - [ "true" | "false" -> <:expr< $uid:String.capitalize x1$ >> - | "nil" -> <:expr< [] >> - | _ -> <:expr< $lid:x1$ >> ] - | x1 = UIDENT -> <:expr< $uid:x1$ >> - | x1 = UIDENT; "."; x2 = eqid -> <:expr< $uid:x1$ . $x2$ >> - | x1 = INT -> <:expr< $int:x1$ >> - | x1 = FLOAT -> <:expr< $flo:x1$ >> - | x1 = STRING -> <:expr< $str:x1$ >> - | "~"; x1 = INT -> <:expr< $int:"-"^x1$ >> - | i = op -> - if i = "::" then <:expr< fun (x, y) -> [x :: y] >> - else <:expr< fun (x, y) -> $lid:i$ x y >> - | "let"; x1 = ldecs; "in"; x2 = exp_ps; "end" -> - List.fold_right - (fun pel x2 -> - let loc = - match pel with - [ [(p, _) :: _] -> - (fst (MLast.loc_of_patt p), snd (MLast.loc_of_expr x2)) - | _ -> loc ] - in - match pel with - [ [(_, <:expr< fun [$list:_$] >>) :: _] -> - <:expr< let rec $list:pel$ in $x2$ >> - | _ -> - let pel = - List.map - (fun (p, e) -> - match p with - [ <:patt< { $list:lpl$ } >> -> - record_match_assoc (MLast.loc_of_patt p) lpl e - | _ -> (p, e) ]) - pel - in - <:expr< let $list:pel$ in $x2$ >> ]) - x1 x2 - | "{"; x1 = LIST1 elabel SEP ","; "}" -> record_expr loc x1 - | "["; "]" -> <:expr< [] >> - | "["; x1 = expr; "]" -> <:expr< [$x1$] >> - | "["; x1 = expr; ","; x2 = LIST1 SELF SEP ","; "]" -> - mklistexp loc None [x1 :: x2] - | "("; ")" -> <:expr< () >> - | "("; x1 = expr; ","; x2 = LIST1 SELF SEP ","; ")" -> - <:expr< ($list:[x1::x2]$) >> - | "("; x1 = expr; ";"; x2 = LIST1 SELF SEP ";"; ")" -> - <:expr< do { $list:[x1::x2]$ } >> - | "("; x1 = expr; ")" -> x1 ] ] - ; - fixity: - [ [ "infix" -> ("infix", None) - | "infix"; x1 = INT -> not_impl loc "fixity 2" - | "infixr" -> not_impl loc "fixity 3" - | "infixr"; x1 = INT -> ("infixr", Some x1) - | "nonfix" -> not_impl loc "fixity 5" ] ] - ; - patt: - [ [ x1 = patt; "as"; x2 = patt -> <:patt< ($x1$ as $x2$) >> ] - | LEFTA - [ x1 = patt; ":"; x2 = ctyp -> <:patt< ($x1$ : $x2$) >> ] - | RIGHTA - [ x1 = patt; "::"; x2 = patt -> <:patt< [$x1$ :: $x2$] >> ] - | [ x1 = patt; x2 = patt -> - match x1 with - [ <:patt< ref >> -> <:patt< {contents = $x2$} >> - | _ -> <:patt< $x1$ $x2$ >> ] ] - | "apat" - [ x1 = patt; "."; x2 = patt -> <:patt< $x1$ . $x2$ >> - | x1 = INT -> <:patt< $int:x1$ >> - | x1 = UIDENT -> <:patt< $uid:x1$ >> - | x1 = STRING -> <:patt< $str:x1$ >> - | "#"; x1 = STRING -> <:patt< $chr:x1$ >> - | "~"; x1 = INT -> <:patt< $int:"-"^x1$ >> - | LIDENT "nil" -> <:patt< [] >> - | LIDENT "false" -> <:patt< False >> - | LIDENT "true" -> <:patt< True >> - | x1 = id -> <:patt< $lid:x1$ >> - | x1 = op -> <:patt< $lid:x1$ >> - | "_" -> <:patt< _ >> - | "["; "]" -> <:patt< [] >> - | "["; x1 = patt; "]" -> <:patt< [$x1$] >> - | "["; x1 = patt; ","; x2 = LIST1 SELF SEP ","; "]" -> - mklistpat loc None [x1 :: x2] - | "{"; x1 = LIST1 plabel SEP ","; "}" -> <:patt< {$list:x1$} >> - | "("; ")" -> <:patt< () >> - | "("; x1 = patt; ","; x2 = LIST1 SELF SEP ","; ")" -> - <:patt< ($list:[x1::x2]$) >> - | "("; x1 = patt; ")" -> x1 ] ] - ; - plabel: - [ [ x1 = selector; "="; x2 = patt -> (<:patt< $lid:x1$ >>, x2) - | x1 = selector -> (<:patt< $lid:x1$ >>, <:patt< $lid:x1$ >>) ] ] - ; - vb: - [ [ "lazy"; x1 = patt; "="; x2 = expr -> not_impl loc "vb 1" - | x1 = patt; "="; x2 = expr -> (x1, x2) ] ] - ; - constrain: - [ [ -> None - | ":"; x1 = ctyp -> Some x1 ] ] - ; - fb: - [ [ xl = LIST1 clause SEP "|" -> function_of_clause_list loc xl - | "lazy"; x1 = LIST1 clause SEP "|" -> not_impl loc "fb 2" ] ] - ; - clause: - [ [ x1 = patt LEVEL "apat"; x2 = LIST1 (patt LEVEL "apat"); - x3 = constrain; "="; x4 = expr -> - let x1 = - match x1 with - [ <:patt< $lid:id$ >> -> (id, MLast.loc_of_patt x1) - | _ -> not_impl loc "clause 1" ] - in - (x1, x2, x3, x4) ] ] - ; - tb: - [ [ x1 = tyvars; x2 = idd; "="; x3 = ctyp -> - ((loc, uncap x2), x1, x3, []) - | x1 = tyvars; x2 = idd; "="; x3 = ctyp; "=="; x4 = dbrhs -> - let x4 = List.map (fun (loc, c, tl, _) -> (loc, c, tl)) x4 in - ((loc, uncap x2), x1, <:ctyp< $x3$ == [ $list:x4$ ] >>, []) ] ] - ; - tyvars: - [ [ "'"; x1 = LIDENT -> [(x1, (False, False))] - | "("; x1 = tyvar_pc; ")" -> x1 - | -> [] ] ] - ; - db1: - [ [ x1 = tyvars; x2 = ident; "="; x3 = dbrhs -> - let x2 = uncap x2 in - extract_label_types loc x2 x1 x3 - | "lazy"; x1 = tyvars; x2 = ident; "="; x3 = dbrhs -> - not_impl loc "db 2" ] ] - ; - db: - [ [ x1 = LIST1 db1 SEP "and" -> - List.fold_right (fun td tdl -> td @ tdl) x1 [] ] ] - ; - dbrhs: - [ [ x1 = LIST1 constr SEP "|" -> x1 - | "datatype"; x1 = tycon -> not_impl loc "dbrhs 2" ] ] - ; - constr: - [ [ x1 = op_op; x2 = ident -> (loc, x2, [], None) - | x1 = op_op; x2 = ident; "of"; x3 = ctyp -> - match x3 with - [ <:ctyp< {$list:_$} >> -> (loc, x2, [], Some x3) - | _ -> (loc, x2, [x3], None) ] ] ] - ; - eb: - [ [ x1 = op_op; x2 = ident -> (x2, [], []) - | x1 = op_op; x2 = ident; "of"; x3 = ctyp -> (x2, [x3], []) - | x1 = op_op; x2 = ident; "="; x3 = sqid -> (x2, [], x3) ] ] - ; - ldec1: - [ [ "val"; x1 = LIST1 vb SEP "and" -> x1 - | "fun"; x1 = LIST1 fb SEP "and" -> x1 ] ] - ; - ldecs: - [ [ -> [] - | x1 = ldec1; x2 = ldecs -> [x1 :: x2] - | ";"; x1 = ldecs -> x1 - | "local"; x1 = ldecs; "in"; x2 = ldecs; "end"; x3 = ldecs -> - not_impl loc "ldecs 4" ] ] - ; - spec_s: - [ [ -> [] - | x1 = spec; x2 = spec_s -> [x1 :: x2] - | ";"; x1 = spec_s -> x1 ] ] - ; - spec: - [ [ "structure"; x1 = LIST1 strspec SEP "and" -> sig_declare loc x1 - | "functor"; x1 = LIST1 fctspec SEP "and" -> sig_declare loc x1 - | "datatype"; x1 = db -> <:sig_item< type $list:x1$ >> - | "type"; x1 = LIST1 tyspec SEP "and" -> <:sig_item< type $list:x1$ >> - | "eqtype"; x1 = LIST1 tyspec SEP "and" -> <:sig_item< type $list:x1$ >> - | "val"; x1 = LIST1 valspec SEP "and" -> sig_declare loc x1 - | "exception"; x1 = LIST1 exnspec SEP "and" -> sig_declare loc x1 - | "sharing"; x1 = LIST1 sharespec SEP "and" -> <:sig_item< declare end >> - | "include"; x1 = module_type -> <:sig_item< include $x1$ >> ] ] - ; - sig_item: - [ [ x = spec -> x ] ] - ; - strspec: - [ [ x1 = ident; ":"; x2 = module_type; x3 = LIST0 sharing_def -> - let x2 = - List.fold_left - (fun mt sdl -> - List.fold_right - (fun spl mt -> - match spl with - [ Right ([m1], m2) -> - let (m1, m2) = - match m2 with - [ <:module_expr< $uid:x$ . $_$ >> -> - if x = x1 then (m2, m1) else (m1, m2) - | _ -> (m1, m2) ] - in - let m1 = - loop m1 where rec loop = - fun - [ <:module_expr< $uid:x$ >> -> x - | <:module_expr< $uid:x$ . $y$ >> -> loop y - | _ -> not_impl loc "strspec 2" ] - in - <:module_type< $mt$ with module $[m1]$ = $m2$ >> - | _ -> not_impl loc "strspec 1" ]) - sdl mt) - x2 x3 - in - <:sig_item< module $x1$ : $x2$ >> ] ] - ; - sharing_def: - [ [ "sharing"; x3 = LIST1 sharespec SEP "and" -> x3 ] ] - ; - fctspec: - [ [ x1 = ident; x2 = fsig -> <:sig_item< module $x1$ : $x2$ >> ] ] - ; - tyspec: - [ [ x1 = tyvars; x2 = idd -> - ((loc, uncap x2), x1, <:ctyp< '$choose_tvar x1$ >>, []) - | x1 = tyvars; x2 = idd; "="; x3 = ctyp -> - ((loc, uncap x2), x1, x3, []) ] ] - ; - valspec: - [ [ x1 = op_op; x2 = ident; ":"; x3 = ctyp -> - <:sig_item< value $x2$ : $x3$ >> ] ] - ; - exnspec: - [ [ x1 = ident -> <:sig_item< exception $x1$ >> - | x1 = ident; "of"; x2 = ctyp -> - <:sig_item< exception $x1$ of $x2$ >> ] ] - ; - sharespec: - [ [ "type"; x1 = patheqn -> Left x1 - | x1 = patheqn -> Right x1 ] ] - ; - patheqn: - [ [ l = patheqn1 -> l ] ] - ; - patheqn1: - [ [ (l, y) = patheqn1; "="; x = qid -> ([y :: l], x) - | x = qid -> ([], x) ] ] - ; - whspec: - [ [ "type"; x1 = tyvars; x2 = sqid; "="; x3 = ctyp -> - MLast.WcTyp loc x2 x1 x3 - | x1 = sqid; "="; x2 = qid -> MLast.WcMod loc x1 x2 ] ] - ; - module_type: - [ [ x1 = ident -> <:module_type< $uid:x1$ >> - | "sig"; x1 = spec_s; "end" -> <:module_type< sig $list:x1$ end >> - | x1 = module_type; "where"; x2 = LIST1 whspec SEP "and" -> - <:module_type< $x1$ with $list:x2$ >> ] ] - ; - sigconstraint_op: - [ [ -> None - | ":"; x1 = module_type -> Some x1 - | ":>"; x1 = module_type -> not_impl loc "sigconstraint_op 3" ] ] - ; - sigb: - [ [ x1 = ident; "="; x2 = module_type -> - <:str_item< module type $x1$ = $x2$ >> ] ] - ; - fsig: - [ [ ":"; x1 = ident -> not_impl loc "fsig 1" - | x1 = fparamList; ":"; x2 = module_type -> not_impl loc "fsig 2" ] ] - ; - module_expr: - [ [ x1 = qid -> x1 - | "struct"; x1 = strdecs; "end" -> <:module_expr< struct $list:x1$ end >> - | x1 = qid; x2 = arg_fct -> - match x2 with - [ Left [] -> x1 - | Left x2 -> <:module_expr< $x1$ (struct $list:x2$ end) >> - | Right x2 -> <:module_expr< $x1$ $x2$ >> ] - | "let"; x1 = strdecs; "in"; x2 = module_expr; "end" -> - not_impl loc "str 4" - | x1 = module_expr; ":"; x2 = module_type -> not_impl loc "str 5" - | x1 = module_expr; x2 = ":>"; x3 = module_type -> - not_impl loc "str 6" ] ] - ; - arg_fct: - [ [ "("; x1 = strdecs; ")"; x2 = arg_fct -> not_impl loc "arg_fct 1" - | "("; x1 = module_expr; ")"; x2 = arg_fct -> not_impl loc "arg_fct 2" - | "("; x1 = module_expr; ")" -> Right x1 - | "("; x2 = strdecs; ")" -> Left x2 ] ] - ; - strdecs: - [ [ x1 = str_item LEVEL "strdec"; x2 = strdecs -> [x1 :: x2] - | ";"; x1 = strdecs -> x1 - | -> [] ] ] - ; - str_item: - [ [ "signature"; x1 = LIST1 sigb SEP "and" -> str_declare loc x1 - | "funsig"; x1 = fsigb -> not_impl loc "sdec 3" ] - | "strdec" - [ "structure"; x1 = LIST1 strb SEP "and" -> str_declare loc x1 - | "functor"; x1 = LIST1 fctb SEP "and" -> str_declare loc x1 - | "local"; x1 = sdecs; "in"; x2 = sdecs; "end" -> - make_local loc x1 x2 ] - | [ "val"; x1 = LIST1 vb SEP "and" -> <:str_item< value $list:x1$ >> - | "val"; x1 = tyvarseq; x3 = LIST1 vb SEP "and" -> - not_impl loc "ldec 2" - | "val"; "rec"; x1 = rvb -> not_impl loc "ldec 3" - | "val"; "rec"; x1 = tyvarseq; x2 = rvb -> not_impl loc "ldec 4" - | "fun"; x1 = LIST1 fb SEP "and" -> <:str_item< value rec $list:x1$ >> - | "fun"; x1 = tyvarseq; x2 = fb -> not_impl loc "ldec 6" - | "type"; x1 = LIST1 tb SEP "and" -> <:str_item< type $list:x1$ >> - | "datatype"; x1 = db -> <:str_item< type $list:x1$ >> - | "datatype"; x1 = db; "withtype"; x2 = tb -> - <:str_item< type $list:x1 @ [x2]$ >> - | "abstype"; x1 = db; "with"; x2 = ldecs; "end" -> not_impl loc "ldec 10" - | "abstype"; x1 = db; "withtype"; x2 = tb; "with"; x3 = ldecs; "end" -> - not_impl loc "ldec 11" - | "exception"; x1 = LIST1 eb SEP "and" -> - let dl = - List.map - (fun (s, tl, eqn) -> - <:str_item< exception $s$ of $list:tl$ = $eqn$ >>) - x1 - in - str_declare loc dl - | "open"; x1 = LIST1 sqid -> - let dl = List.map (fun sl -> <:str_item< open $sl$ >>) x1 in - str_declare loc dl - | LIDENT "use"; s = STRING -> - <:str_item< #use $str:s$ >> - | x1 = fixity; list = LIST1 idd -> - match x1 with - [ ("infixr", Some n) -> - do { - List.iter - (fun s -> - EXTEND - expr: LEVEL $n$ - [ [ x1 = expr; $s$; x2 = expr -> - <:expr< $lid:s$ ($x1$, $x2$) >> ] ] - ; - END) - list; - str_declare loc [] - } - | ("infix", None) -> - do { - List.iter - (fun s -> - EXTEND - expr: LEVEL "4" - [ [ x1 = expr; $s$; x2 = expr -> - <:expr< $lid:s$ ($x1$, $x2$) >> ] ] - ; - clause: - [ [ x1 = patt LEVEL "apat"; $s$; - x2 = patt LEVEL "apat"; "="; x4 = expr -> - ((s, loc), [<:patt< ($x1$, $x2$) >>], - None, x4) ] ] - ; - END) - list; - str_declare loc [] - } - | _ -> not_impl loc "ldec 14" ] - | "overload"; x1 = ident; ":"; x2 = ctyp; "as"; x3 = exp_pa -> - not_impl loc "ldec 15" - | x = expr -> <:str_item< $exp:x$ >> ] ] - ; - sdec: - [ [ x = str_item -> x ] ] - ; - strb: - [ [ x1 = ident; x2 = sigconstraint_op; "="; x3 = module_expr -> - let x3 = - match x2 with - [ Some x2 -> <:module_expr< ($x3$ : $x2$) >> - | None -> x3 ] - in - <:str_item< module $x1$ = $x3$ >> ] ] - ; - fparam: - [ [ x1 = idd; ":"; x2 = module_type -> [<:sig_item< module $x1$ : $x2$ >>] - | x1 = spec_s -> x1 ] ] - ; - fparamList: - [ [ "("; x1 = fparam; ")" -> [x1] - | "("; x1 = fparam; ")"; x2 = fparamList -> [x1 :: x2] ] ] - ; - fctb: - [ [ x1 = ident; x2 = fparamList; x3 = sigconstraint_op; "="; - x4 = module_expr -> - let list = List.flatten x2 in - let x4 = - if list = [] then x4 - else - match x4 with - [ <:module_expr< struct $list:list$ end >> -> - let si = let loc = (0, 0) in <:str_item< open AAA >> in - <:module_expr< struct $list:[si :: list]$ end >> - | _ -> not_impl loc "fctb 1" ] - in - let x4 = - match x3 with - [ Some x3 -> <:module_expr< ($x4$ : $x3$) >> - | None -> x4 ] - in - let x4 = - if list = [] then x4 - else - let mt = - let loc = - (fst (MLast.loc_of_sig_item (List.hd list)), - snd (MLast.loc_of_sig_item (List.hd (List.rev list)))) - in - <:module_type< sig $list:list$ end >> - in - <:module_expr< functor (AAA : $mt$) -> $x4$ >> - in - <:str_item< module $x1$ = $x4$ >> - | x1 = ident; x2 = fsigconstraint_op; "="; x3 = fct_exp -> - not_impl loc "fctb 2" ] ] - ; - interdec: - [ [ x = LIST1 [ s = str_item; OPT ";" -> (s, loc) ] -> (x, False) - | x = expr; OPT ";" -> not_impl loc "interdec 2" ] ] - ; -END; - -Pcaml.add_option "-records" (Arg.Set ocaml_records) - "Convert record into OCaml records, instead of objects"; diff --git a/camlp4/etc/parserify.ml b/camlp4/etc/parserify.ml deleted file mode 100644 index c8ce441714..0000000000 --- a/camlp4/etc/parserify.ml +++ /dev/null @@ -1,301 +0,0 @@ -(* camlp4r q_MLast.cmo *) -(* $Id$ *) - -value loc = (0, 0); - -type spc = - [ SPCterm of (MLast.patt * option MLast.expr) - | SPCnterm of MLast.patt and MLast.expr - | SPCsterm of MLast.patt ] -; - -exception NotImpl; - -value rec subst v e = - match e with - [ <:expr< $lid:x$ >> -> if x = "strm__" then <:expr< $lid:v$ >> else e - | <:expr< $uid:_$ >> -> e - | <:expr< $int:_$ >> -> e - | <:expr< $chr:_$ >> -> e - | <:expr< $str:_$ >> -> e - | <:expr< $e1$ . $lab$ >> -> <:expr< $subst v e1$ . $lab$ >> - | <:expr< $x$ $y$ >> -> <:expr< $subst v x$ $subst v y$ >> - | <:expr< let $lid:s1$ = $e1$ in $e2$ >> -> - if s1 = v then <:expr< let $lid:s1$ = $subst v e1$ in $e2$ >> - else <:expr< let $lid:s1$ = $subst v e1$ in $subst v e2$ >> - | <:expr< let _ = $e1$ in $e2$ >> -> - <:expr< let _ = $subst v e1$ in $subst v e2$ >> - | <:expr< ($list:el$) >> -> <:expr< ($list:List.map (subst v) el$) >> - | _ -> raise NotImpl ] -; - -value rec is_free v = - fun - [ <:expr< $lid:x$ >> -> x <> v - | <:expr< $uid:_$ >> -> True - | <:expr< $int:_$ >> -> True - | <:expr< $chr:_$ >> -> True - | <:expr< $str:_$ >> -> True - | <:expr< $e$ . $_$ >> -> is_free v e - | <:expr< $x$ $y$ >> -> is_free v x && is_free v y - | <:expr< let $lid:s1$ = $e1$ in $e2$ >> -> - is_free v e1 && (s1 = v || is_free v e2) - | <:expr< let _ = $e1$ in $e2$ >> -> is_free v e1 && is_free v e2 - | <:expr< ($list:el$) >> -> List.for_all (is_free v) el - | _ -> raise NotImpl ] -; - -value gensym = - let cnt = ref 0 in - fun () -> - do { incr cnt; "pr_rp_symb_" ^ string_of_int cnt.val } -; - -value free_var_in_expr c e = - let rec loop_alpha v = - let x = String.make 1 v in - if is_free x e then Some x - else if v = 'z' then None - else loop_alpha (Char.chr (Char.code v + 1)) - in - let rec loop_count cnt = - let x = String.make 1 c ^ string_of_int cnt in - if is_free x e then x else loop_count (succ cnt) - in - try - match loop_alpha c with - [ Some v -> v - | None -> loop_count 1 ] - with - [ NotImpl -> gensym () ] -; - -value parserify = - fun - [ <:expr< $e$ strm__ >> -> e - | e -> <:expr< fun strm__ -> $e$ >> ] -; - -value is_raise_failure = - fun - [ <:expr< raise Stream.Failure >> -> True - | _ -> False ] -; - -value is_raise_error = - fun - [ <:expr< raise (Stream.Error $_$) >> -> True - | _ -> False ] -; - -value semantic e = - try - if is_free "strm__" e then e - else - let v = free_var_in_expr 's' e in - <:expr< let $lid:v$ = strm__ in $subst v e$ >> - with - [ NotImpl -> e ] -; - -value rewrite_parser = - rewrite True where rec rewrite top ge = - match ge with - [ <:expr< let $p$ = try $e$ with [ Stream.Failure -> raise $exc$ ] in - $sp_kont$ >> -> - let f = parserify e in - <:expr< - match try Some ($f$ strm__) with [ Stream.Failure -> None ] with - [ Some $p$ -> $rewrite False sp_kont$ - | _ -> raise $exc$ ] - >> - | <:expr< let $p$ = Stream.count strm__ in $f$ >> -> - try - if is_free "strm__" f then ge - else - let v = free_var_in_expr 's' f in - <:expr< - let $lid:v$ = strm__ in - let $p$ = Stream.count strm__ in $subst v f$ - >> - with - [ NotImpl -> ge ] - | <:expr< let $p$ = strm__ in $e$ >> -> - <:expr< let $p$ = strm__ in $rewrite False e$ >> - | <:expr< let $p$ = $f$ strm__ in $sp_kont$ >> when top -> - <:expr< - match try Some ($f$ strm__) with [ Stream.Failure -> None ] with - [ Some $p$ -> $rewrite False sp_kont$ - | _ -> raise Stream.Failure ] - >> - | <:expr< let $p$ = $e$ in $sp_kont$ >> -> - if match e with - [ <:expr< match try Some $_$ with [ Stream.Failure -> None ] with - [ $list:_$ ] >> - | <:expr< match Stream.peek strm__ with [ $list:_$ ] >> - | <:expr< try $_$ with [ Stream.Failure -> $_$ ] >> - | <:expr< let $_$ = Stream.count strm__ in $_$ >> -> True - | _ -> False ] - then - let f = rewrite True <:expr< fun strm__ -> $e$ >> in - let exc = - if top then <:expr< Stream.Failure >> - else <:expr< Stream.Error "" >> - in - <:expr< - match try Some ($f$ strm__) with [ Stream.Failure -> None ] with - [ Some $p$ -> $rewrite False sp_kont$ - | _ -> raise $exc$ ] - >> - else semantic ge - | <:expr< match try Some $e$ with [ Stream.Failure -> None ] with - [ Some $p$ -> $sp_kont$ - | _ -> $p_kont$ ] >> -> - let f = parserify e in - if not top && is_raise_failure p_kont then semantic ge - else - let (p, f, sp_kont, p_kont) = - if top || is_raise_error p_kont then - (p, f, rewrite False sp_kont, rewrite top p_kont) - else - let f = - <:expr< - fun strm__ -> - match - try Some ($f$ strm__) with [ Stream.Failure -> None ] - with - [ Some $p$ -> $rewrite False sp_kont$ - | _ -> $rewrite top p_kont$ ] - >> - in - (<:patt< a >>, f, <:expr< a >>, - <:expr< raise (Stream.Error "") >>) - in - <:expr< - match try Some ($f$ strm__) with [ Stream.Failure -> None ] with - [ Some $p$ -> $sp_kont$ - | _ -> $p_kont$ ] - >> - | <:expr< match Stream.peek strm__ with [ $list:pel$ ] >> -> - let rec iter pel = - match pel with - [ [(<:patt< Some $p$ >>, eo, - <:expr< do { Stream.junk strm__; $sp_kont$ } >>); - (<:patt< _ >>, None, p_kont) :: _] -> - <:expr< - match Stream.peek strm__ with - [ Some $p$ $when:eo$ -> - do { Stream.junk strm__; $rewrite False sp_kont$ } - | _ -> $rewrite top p_kont$ ] - >> - | [(<:patt< Some $p$ >>, eo, - <:expr< do { Stream.junk strm__; $sp_kont$ } >>) :: pel] -> - let p_kont = iter pel in - <:expr< - match Stream.peek strm__ with - [ Some $p$ $when:eo$ -> - do { Stream.junk strm__; $rewrite False sp_kont$ } - | _ -> $p_kont$ ] - >> - | _ -> - <:expr< match Stream.peek strm__ with [ $list:pel$ ] >> ] - in - iter pel - | <:expr< try Some $e$ with [ Stream.Failure -> $p_kont$ ] >> -> - let f = parserify e in - let e = - <:expr< - match try Some ($f$ strm__) with [ Stream.Failure -> None ] with - [ Some a -> Some a - | _ -> $p_kont$ ] - >> - in - rewrite top e - | <:expr< try $e$ with [ Stream.Failure -> $p_kont$ ] >> -> - let f = parserify e in - let e = - <:expr< - match try Some ($f$ strm__) with [ Stream.Failure -> None ] with - [ Some a -> a - | _ -> $rewrite top p_kont$ ] - >> - in - rewrite top e - | <:expr< $f$ strm__ >> -> - if top then - <:expr< - match try Some ($f$ strm__) with [ Stream.Failure -> None ] with - [ Some a -> a - | _ -> raise Stream.Failure ] - >> - else - let v = free_var_in_expr 's' f in - <:expr< let $lid:v$ = strm__ in $subst v f$ $lid:v$ >> - | e -> semantic e ] -; - -value spc_of_parser = - let rec parser_cases e = - match e with - [ <:expr< - match try Some ($f$ strm__) with [ Stream.Failure -> None ] with - [ Some $p$ -> $sp_kont$ - | _ -> $p_kont$ ] - >> -> - let spc = (SPCnterm p f, None) in - let (sp, epo, e) = kont sp_kont in - [([spc :: sp], epo, e) :: parser_cases p_kont] - | <:expr< - match Stream.peek strm__ with - [ Some $p$ $when:wo$ -> do { Stream.junk strm__; $sp_kont$ } - | _ -> $p_kont$ ] - >> -> - let spc = (SPCterm (p, wo), None) in - let (sp, epo, e) = kont sp_kont in - [([spc :: sp], epo, e) :: parser_cases p_kont] - | <:expr< let $p$ = strm__ in $sp_kont$ >> -> - let spc = (SPCsterm p, None) in - let (sp, epo, e) = kont sp_kont in - [([spc :: sp], epo, e)] - | <:expr< let $p$ = Stream.count strm__ in $e$ >> -> [([], Some p, e)] - | <:expr< raise Stream.Failure >> -> [] - | _ -> [([], None, e)] ] - and kont e = - match e with - [ <:expr< - match try Some ($f$ strm__) with [ Stream.Failure -> None ] with - [ Some $p$ -> $sp_kont$ - | _ -> raise (Stream.Error $err$) ] - >> -> - let err = - match err with - [ <:expr< "" >> -> None - | _ -> Some err ] - in - let spc = (SPCnterm p f, err) in - let (sp, epo, e) = kont sp_kont in - ([spc :: sp], epo, e) - | <:expr< - match Stream.peek strm__ with - [ Some $p$ $when:wo$ -> do { Stream.junk strm__; $sp_kont$ } - | _ -> raise (Stream.Error $err$) ] - >> -> - let err = - match err with - [ <:expr< "" >> -> None - | _ -> Some err ] - in - let spc = (SPCterm (p, wo), err) in - let (sp, epo, e) = kont sp_kont in - ([spc :: sp], epo, e) - | <:expr< let $p$ = strm__ in $sp_kont$ >> -> - let spc = (SPCsterm p, None) in - let (sp, epo, e) = kont sp_kont in - ([spc :: sp], epo, e) - | <:expr< let $p$ = Stream.count strm__ in $e$ >> -> ([], Some p, e) - | _ -> ([], None, e) ] - in - parser_cases -; - -value parser_of_expr e = spc_of_parser (rewrite_parser e); diff --git a/camlp4/etc/parserify.mli b/camlp4/etc/parserify.mli deleted file mode 100644 index ece8b8927f..0000000000 --- a/camlp4/etc/parserify.mli +++ /dev/null @@ -1,12 +0,0 @@ -(* camlp4r *) -(* $Id$ *) - -type spc = - [ SPCterm of (MLast.patt * option MLast.expr) - | SPCnterm of MLast.patt and MLast.expr - | SPCsterm of MLast.patt ] -; - -value parser_of_expr : - MLast.expr -> - list (list (spc * option MLast.expr) * option MLast.patt * MLast.expr); diff --git a/camlp4/etc/pr_depend.ml b/camlp4/etc/pr_depend.ml deleted file mode 100644 index 0cf6e4412f..0000000000 --- a/camlp4/etc/pr_depend.ml +++ /dev/null @@ -1,327 +0,0 @@ -(* camlp4r *) -(* $Id$ *) - -open MLast; - -value not_impl name x = - let desc = - if Obj.is_block (Obj.repr x) then - "tag = " ^ string_of_int (Obj.tag (Obj.repr x)) - else "int_val = " ^ string_of_int (Obj.magic x) - in - do { - Printf.eprintf "pr_depend: not impl: %s; %s\n" name desc; flush stderr; - } -; - -module StrSet = - Set.Make (struct type t = string; value compare = compare; end) -; - -value fset = ref StrSet.empty; -value addmodule s = fset.val := StrSet.add s fset.val; - -value list = List.iter; - -value option f = - fun - [ Some x -> f x - | None -> () ] -; - -value longident = - fun - [ [s; _ :: _] -> addmodule s - | _ -> () ] -; - -value rec ctyp = - fun - [ TyAcc _ t _ -> ctyp_module t - | TyAli _ t1 t2 -> do { ctyp t1; ctyp t2; } - | TyApp _ t1 t2 -> do { ctyp t1; ctyp t2; } - | TyAny _ -> () - | TyArr _ t1 t2 -> do { ctyp t1; ctyp t2; } - | TyCls _ li -> longident li - | TyLab _ _ t -> ctyp t - | TyLid _ _ -> () - | TyMan _ t1 t2 -> do { ctyp t1; ctyp t2; } - | TyOlb _ _ t -> ctyp t - | TyQuo _ _ -> () - | TyRec _ _ ldl -> list label_decl ldl - | TySum _ _ cdl -> list constr_decl cdl - | TyTup _ tl -> list ctyp tl - | TyVrn _ sbtll _ -> list variant sbtll - | x -> not_impl "ctyp" x ] -and constr_decl (_, _, tl) = list ctyp tl -and label_decl (_, _, _, t) = ctyp t -and variant = - fun - [ RfTag _ _ tl -> list ctyp tl - | RfInh t -> ctyp t ] -and ctyp_module = - fun - [ TyAcc _ t _ -> ctyp_module t - | TyApp _ t1 t2 -> do { ctyp t1; ctyp t2; } - | TyUid _ m -> addmodule m - | x -> not_impl "ctyp_module" x ] -; - -value rec patt = - fun - [ PaAcc _ p _ -> patt_module p - | PaAli _ p1 p2 -> do { patt p1; patt p2; } - | PaAny _ -> () - | PaApp _ p1 p2 -> do { patt p1; patt p2; } - | PaArr _ pl -> list patt pl - | PaChr _ _ -> () - | PaInt _ _ -> () - | PaLab _ _ po -> option patt po - | PaLid _ _ -> () - | PaOlb _ _ peoo -> - option (fun (p, eo) -> do { patt p; option expr eo }) peoo - | PaOrp _ p1 p2 -> do { patt p1; patt p2; } - | PaRec _ lpl -> list label_patt lpl - | PaRng _ p1 p2 -> do { patt p1; patt p2; } - | PaStr _ _ -> () - | PaTup _ pl -> list patt pl - | PaTyc _ p t -> do { patt p; ctyp t; } - | PaUid _ _ -> () - | PaVrn _ _ -> () - | x -> not_impl "patt" x ] -and patt_module = - fun - [ PaUid _ m -> addmodule m - | PaAcc _ p _ -> patt_module p - | x -> not_impl "patt_module" x ] -and label_patt (p1, p2) = do { patt p1; patt p2; } -and expr = - fun - [ ExAcc _ e1 e2 -> do { expr_module e1; expr e2; } - | ExApp _ e1 e2 -> do { expr e1; expr e2; } - | ExAre _ e1 e2 -> do { expr e1; expr e2; } - | ExArr _ el -> list expr el - | ExAsf _ -> () - | ExAsr _ e -> do { expr e; } - | ExAss _ e1 e2 -> do { expr e1; expr e2; } - | ExChr _ _ -> () - | ExCoe _ e t1 t2 -> do { expr e; option ctyp t1; ctyp t2 } - | ExFor _ _ e1 e2 _ el -> do { expr e1; expr e2; list expr el; } - | ExFun _ pwel -> list match_case pwel - | ExIfe _ e1 e2 e3 -> do { expr e1; expr e2; expr e3; } - | ExInt _ _ -> () - | ExInt32 _ _ -> () - | ExInt64 _ _ -> () - | ExNativeInt _ _ -> () - | ExFlo _ _ -> () - | ExLab _ _ eo -> option expr eo - | ExLaz _ e -> expr e - | ExLet _ _ pel e -> do { list let_binding pel; expr e; } - | ExLid _ _ -> () - | ExLmd _ _ me e -> do { module_expr me; expr e; } - | ExMat _ e pwel -> do { expr e; list match_case pwel; } - | ExNew _ li -> longident li - | ExOlb _ _ eo -> option expr eo - | ExRec _ lel w -> do { list label_expr lel; option expr w; } - | ExSeq _ el -> list expr el - | ExSnd _ e _ -> expr e - | ExSte _ e1 e2 -> do { expr e1; expr e2; } - | ExStr _ _ -> () - | ExTry _ e pwel -> do { expr e; list match_case pwel; } - | ExTup _ el -> list expr el - | ExTyc _ e t -> do { expr e; ctyp t; } - | ExUid _ _ -> () - | ExVrn _ _ -> () - | ExWhi _ e el -> do { expr e; list expr el; } - | x -> not_impl "expr" x ] -and expr_module = - fun - [ ExUid _ m -> addmodule m - | e -> expr e ] -and let_binding (p, e) = do { patt p; expr e } -and label_expr (p, e) = do { patt p; expr e } -and match_case (p, w, e) = do { patt p; option expr w; expr e; } -and module_type = - fun - [ MtAcc _ (MtUid _ m) _ -> addmodule m - | MtFun _ _ mt1 mt2 -> do { module_type mt1; module_type mt2; } - | MtSig _ sil -> list sig_item sil - | MtUid _ _ -> () - | MtWit _ mt wc -> do { module_type mt; list with_constr wc; } - | x -> not_impl "module_type" x ] -and with_constr = - fun - [ WcTyp _ _ _ t -> ctyp t - | x -> not_impl "with_constr" x ] -and sig_item = - fun - [ SgDcl _ sil -> list sig_item sil - | SgExc _ _ tl -> list ctyp tl - | SgExt _ _ t _ -> ctyp t - | SgMod _ _ mt -> module_type mt - | SgRecMod _ mts -> list (fun (_, mt) -> module_type mt) mts - | SgMty _ _ mt -> module_type mt - | SgOpn _ [s :: _] -> addmodule s - | SgTyp _ tdl -> list type_decl tdl - | SgVal _ _ t -> ctyp t - | x -> not_impl "sig_item" x ] -and module_expr = - fun - [ MeAcc _ (MeUid _ m) _ -> addmodule m - | MeApp _ me1 me2 -> do { module_expr me1; module_expr me2; } - | MeFun _ _ mt me -> do { module_type mt; module_expr me; } - | MeStr _ sil -> list str_item sil - | MeTyc _ me mt -> do { module_expr me; module_type mt; } - | MeUid _ _ -> () - | x -> not_impl "module_expr" x ] -and str_item = - fun - [ StCls _ cil -> list (fun ci -> class_expr ci.ciExp) cil - | StDcl _ sil -> list str_item sil - | StDir _ _ _ -> () - | StExc _ _ tl _ -> list ctyp tl - | StExp _ e -> expr e - | StExt _ _ t _ -> ctyp t - | StMod _ _ me -> module_expr me - | StRecMod _ nmtmes -> list (fun (_, mt, me) -> do { module_expr me; module_type mt; }) nmtmes - | StMty _ _ mt -> module_type mt - | StOpn _ [s :: _] -> addmodule s - | StTyp _ tdl -> list type_decl tdl - | StVal _ _ pel -> list let_binding pel - | x -> not_impl "str_item" x ] -and type_decl (_, _, t, _) = ctyp t -and class_expr = - fun - [ CeApp _ ce e -> do { class_expr ce; expr e; } - | CeCon _ li tl -> do { longident li; list ctyp tl; } - | CeFun _ p ce -> do { patt p; class_expr ce; } - | CeLet _ _ pel ce -> do { list let_binding pel; class_expr ce; } - | CeStr _ po csil -> do { option patt po; list class_str_item csil; } - | x -> not_impl "class_expr" x ] -and class_str_item = - fun - [ CrInh _ ce _ -> class_expr ce - | CrIni _ e -> expr e - | CrMth _ _ _ e None -> expr e - | CrMth _ _ _ e (Some t) -> do { expr e; ctyp t } - | CrVal _ _ _ e -> expr e - | CrVir _ _ _ t -> ctyp t - | x -> not_impl "class_str_item" x ] -; - -(* Print dependencies *) - -value load_path = ref [""]; - -value find_in_path path name = - if not (Filename.is_implicit name) then - if Sys.file_exists name then name else raise Not_found - else - let rec try_dir = - fun - [ [] -> raise Not_found - | [dir :: rem] -> - let fullname = Filename.concat dir name in - if Sys.file_exists fullname then fullname else try_dir rem ] - in - try_dir path -; - -value find_depend modname (byt_deps, opt_deps) = - let name = String.uncapitalize modname in - try - let filename = find_in_path load_path.val (name ^ ".mli") in - let basename = Filename.chop_suffix filename ".mli" in - let byt_dep = basename ^ ".cmi" in - let opt_dep = - if Sys.file_exists (basename ^ ".ml") then basename ^ ".cmx" - else basename ^ ".cmi" - in - ([byt_dep :: byt_deps], [opt_dep :: opt_deps]) - with - [ Not_found -> - try - let filename = find_in_path load_path.val (name ^ ".ml") in - let basename = Filename.chop_suffix filename ".ml" in - ([basename ^ ".cmo" :: byt_deps], [basename ^ ".cmx" :: opt_deps]) - with - [ Not_found -> (byt_deps, opt_deps) ] ] -; - -value (depends_on, escaped_eol) = - match Sys.os_type with - [ "Unix" | "Win32" | "Cygwin" -> (": ", "\\\n ") - | "MacOS" -> ("\196 ", "\182\n ") - | _ -> assert False ] -; - -value print_depend target_file deps = - match deps with - [ [] -> () - | _ -> - do { - print_string target_file; - print_string depends_on; - let rec print_items pos = - fun - [ [] -> print_string "\n" - | [dep :: rem] -> - if pos + String.length dep <= 77 then do { - print_string dep; - print_string " "; - print_items (pos + String.length dep + 1) rem - } - else do { - print_string escaped_eol; - print_string dep; - print_string " "; - print_items (String.length dep + 5) rem - } ] - in - print_items (String.length target_file + 2) deps - } ] -; - -(* Main *) - -value depend_sig ast = - do { - fset.val := StrSet.empty; - List.iter (fun (si, _) -> sig_item si) ast; - let basename = Filename.chop_suffix Pcaml.input_file.val ".mli" in - let (byt_deps, opt_deps) = StrSet.fold find_depend fset.val ([], []) in - print_depend (basename ^ ".cmi") byt_deps; - } -; - -value depend_str ast = - do { - fset.val := StrSet.empty; - List.iter (fun (si, _) -> str_item si) ast; - let basename = - if Filename.check_suffix Pcaml.input_file.val ".ml" then - Filename.chop_suffix Pcaml.input_file.val ".ml" - else - try - let len = String.rindex Pcaml.input_file.val '.' in - String.sub Pcaml.input_file.val 0 len - with - [ Failure _ | Not_found -> Pcaml.input_file.val ] - in - let init_deps = - if Sys.file_exists (basename ^ ".mli") then - let cmi_name = basename ^ ".cmi" in ([cmi_name], [cmi_name]) - else ([], []) - in - let (byt_deps, opt_deps) = StrSet.fold find_depend fset.val init_deps in - print_depend (basename ^ ".cmo") byt_deps; - print_depend (basename ^ ".cmx") opt_deps; - } -; - -Pcaml.print_interf.val := depend_sig; -Pcaml.print_implem.val := depend_str; - -Pcaml.add_option "-I" - (Arg.String (fun dir -> load_path.val := load_path.val @ [dir])) - " Add to the list of include directories."; diff --git a/camlp4/etc/pr_extend.ml b/camlp4/etc/pr_extend.ml deleted file mode 100644 index 43e3794e17..0000000000 --- a/camlp4/etc/pr_extend.ml +++ /dev/null @@ -1,514 +0,0 @@ -(* camlp4r q_MLast.cmo ./pa_extfun.cmo *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -open Pcaml; -open Spretty; - -value no_slist = ref False; - -value expr e dg k = pr_expr.pr_fun "top" e dg k; -value patt e dg k = pr_patt.pr_fun "top" e dg k; - -(* Utilities *) - -value rec list elem el k = - match el with - [ [] -> k - | [x] -> [: `elem x k :] - | [x :: l] -> [: `elem x [: :]; list elem l k :] ] -; - -value rec listws elem sep el k = - match el with - [ [] -> k - | [x] -> [: `elem x k :] - | [x :: l] -> [: `elem x [: `sep :]; listws elem sep l k :] ] -; - -value rec listwbws elem b sep el dg k = - match el with - [ [] -> [: b; k :] - | [x] -> [: `elem b x dg k :] - | [x :: l] -> - let sdg = - match sep with - [ S _ x -> x - | _ -> "" ] - in - [: `elem b x sdg [: :]; listwbws elem [: `sep :] sep l dg k :] ] -; - -(* Extracting *) - -value rec get_globals = - fun - [ [(<:patt< _ >>, <:expr< ($e$ : $uid:gmod1$.Entry.e '$_$) >>) :: pel] -> - let (gmod, gl) = get_globals pel in - if gmod = "" || gmod = gmod1 then (gmod1, [e :: gl]) - else raise Not_found - | [] -> ("", []) - | _ -> raise Not_found ] -; - -value rec get_locals = - fun - [ [(<:patt< $_$ >>, - <:expr< (grammar_entry_create $_$ : $_$) >>) :: pel] -> - get_locals pel - | [] -> () - | _ -> raise Not_found ] -; - -value unposition = - fun - [ <:expr< None >> -> None - | <:expr< Some Gramext.First >> -> Some Gramext.First - | <:expr< Some Gramext.Last >> -> Some Gramext.Last - | <:expr< Some (Gramext.Before $str:s$) >> -> Some (Gramext.Before s) - | <:expr< Some (Gramext.After $str:s$) >> -> Some (Gramext.After s) - | <:expr< Some (Gramext.Level $str:s$) >> -> Some (Gramext.Level s) - | _ -> raise Not_found ] -; - -value unlabel = - fun - [ <:expr< None >> -> None - | <:expr< Some $str:s$ >> -> Some s - | _ -> raise Not_found ] -; - -value unassoc = - fun - [ <:expr< None >> -> None - | <:expr< Some Gramext.NonA >> -> Some Gramext.NonA - | <:expr< Some Gramext.LeftA >> -> Some Gramext.LeftA - | <:expr< Some Gramext.RightA >> -> Some Gramext.RightA - | _ -> raise Not_found ] -; - -value rec unaction = - fun - [ <:expr< fun ($lid:locp$ : (int * int)) -> ($a$ : $_$) >> - when locp = Stdpp.loc_name.val -> - let ao = - match a with - [ <:expr< () >> -> None - | _ -> Some a ] - in - ([], ao) - | <:expr< fun ($p$ : $_$) -> $e$ >> -> - let (pl, a) = unaction e in ([p :: pl], a) - | <:expr< fun _ -> $e$ >> -> - let (pl, a) = unaction e in - (let loc = (0, 0) in [<:patt< _ >> :: pl], a) - | _ -> raise Not_found ] -; - -value untoken = - fun - [ <:expr< ($str:x$, $str:y$) >> -> (x, y) - | _ -> raise Not_found ] -; - -type symbol = - [ Snterm of MLast.expr - | Snterml of MLast.expr and string - | Slist0 of symbol - | Slist0sep of symbol and symbol - | Slist1 of symbol - | Slist1sep of symbol and symbol - | Sopt of symbol - | Sself - | Snext - | Stoken of Token.pattern - | Srules of list (list (option MLast.patt * symbol) * option MLast.expr) ] -; - -value rec unsymbol = - fun - [ <:expr< Gramext.Snterm ($uid:_$.Entry.obj ($e$ : $_$)) >> -> Snterm e - | <:expr< Gramext.Snterml ($uid:_$.Entry.obj ($e$ : $_$)) $str:s$ >> -> - Snterml e s - | <:expr< Gramext.Snterml ($uid:_$.Entry.obj ($e$ : $_$), $str:s$) >> -> - Snterml e s - | <:expr< Gramext.Slist0 $e$ >> -> Slist0 (unsymbol e) - | <:expr< Gramext.Slist0sep $e1$ $e2$ >> -> - Slist0sep (unsymbol e1) (unsymbol e2) - | <:expr< Gramext.Slist0sep ($e1$, $e2$) >> -> - Slist0sep (unsymbol e1) (unsymbol e2) - | <:expr< Gramext.Slist1 $e$ >> -> Slist1 (unsymbol e) - | <:expr< Gramext.Slist1sep $e1$ $e2$ >> -> - Slist1sep (unsymbol e1) (unsymbol e2) - | <:expr< Gramext.Slist1sep ($e1$, $e2$) >> -> - Slist1sep (unsymbol e1) (unsymbol e2) - | <:expr< Gramext.Sopt $e$ >> -> Sopt (unsymbol e) - | <:expr< Gramext.Sself >> -> Sself - | <:expr< Gramext.Snext >> -> Snext - | <:expr< Gramext.Stoken $e$ >> -> Stoken (untoken e) - | <:expr< Gramext.srules $e$ >> -> Srules (unrule_list [] e) - | _ -> raise Not_found ] -and unpsymbol_list pl e = - match (pl, e) with - [ ([], <:expr< [] >>) -> [] - | ([p :: pl], <:expr< [$e$ :: $el$] >>) -> - let op = - match p with - [ <:patt< _ >> -> None - | _ -> Some p ] - in - [(op, unsymbol e) :: unpsymbol_list pl el] - | _ -> raise Not_found ] -and unrule = - fun - [ <:expr< ($e1$, Gramext.action $e2$) >> -> - let (pl, a) = - match unaction e2 with - [ ([], None) -> let loc = (0, 0) in ([], Some <:expr< () >>) - | x -> x ] - in - let sl = unpsymbol_list (List.rev pl) e1 in - (sl, a) - | _ -> raise Not_found ] -and unrule_list rl = - fun - [ <:expr< [$e$ :: $el$] >> -> unrule_list [unrule e :: rl] el - | <:expr< [] >> -> rl - | _ -> raise Not_found ] -; - -value unlevel = - fun - [ <:expr< ($e1$, $e2$, $e3$) >> -> - (unlabel e1, unassoc e2, unrule_list [] e3) - | _ -> raise Not_found ] -; - -value rec unlevel_list = - fun - [ <:expr< [$e$ :: $el$] >> -> [unlevel e :: unlevel_list el] - | <:expr< [] >> -> [] - | _ -> raise Not_found ] -; - -value unentry = - fun - [ <:expr< (Grammar.Entry.obj ($e$ : Grammar.Entry.e '$_$), $pos$, $ll$) >> -> - (e, unposition pos, unlevel_list ll) - | _ -> raise Not_found ] -; - -value rec unentry_list = - fun - [ <:expr< [$e$ :: $el$] >> -> [unentry e :: unentry_list el] - | <:expr< [] >> -> [] - | _ -> raise Not_found ] -; - -value unextend_body e = - let ((_, globals), e) = - match e with - [ <:expr< let $list:pel$ in $e1$ >> -> - try (get_globals pel, e1) with - [ Not_found -> (("", []), e) ] - | _ -> (("", []), e) ] - in - let e = - match e with - [ <:expr< - let grammar_entry_create s = - Grammar.Entry.create (Grammar.of_entry $_$) s - in - $e$ >> -> - let e = - match e with - [ <:expr< let $list:pel$ in $e1$ >> -> - try let _ = get_locals pel in e1 with - [ Not_found -> e ] - | _ -> e ] - in - e - | _ -> e ] - in - let el = unentry_list e in - (globals, el) -; - -value ungextend_body e = - let e = - match e with - [ <:expr< - let grammar_entry_create = Gram.Entry.create in - let $list:ll$ in $e$ - >> -> - let _ = get_locals ll in e - | _ -> e ] - in - match e with - [ <:expr< do { $list:el$ } >> -> - List.map - (fun - [ <:expr< $uid:_$.extend ($e$ : $uid:_$.Entry.e '$_$) $pos$ $ll$ >> -> - (e, unposition pos, unlevel_list ll) - | _ -> raise Not_found ]) - el - | _ -> raise Not_found ] -; - -(* Printing *) - -value ident s k = HVbox [: `S LR s; k :]; -value string s k = HVbox [: `S LR ("\"" ^ s ^ "\""); k :]; - -value position = - fun - [ None -> [: :] - | Some Gramext.First -> [: `S LR "FIRST" :] - | Some Gramext.Last -> [: `S LR "LAST" :] - | Some (Gramext.Before s) -> [: `S LR "BEFORE"; `string s [: :] :] - | Some (Gramext.After s) -> [: `S LR "AFTER"; `string s [: :] :] - | Some (Gramext.Level s) -> [: `S LR "LEVEL"; `string s [: :] :] ] -; - -value action expr a dg k = - expr a dg k -; - -value token (con, prm) k = - if con = "" then string prm k - else if prm = "" then HVbox [: `S LR con; k :] - else HVbox [: `S LR con; `string prm k :] -; - -value simplify_rules rl = - try - List.map - (fun - [ ([(Some <:patt< $lid:x$ >>, s)], Some <:expr< $lid:y$ >>) -> - if x = y then ([(None, s)], None) else raise Exit - | ([], _) as r -> r - | _ -> raise Exit ]) - rl - with - [ Exit -> rl ] -; - -value rec symbol s k = - match s with - [ Snterm e -> expr e "" k - | Snterml e s -> HVbox [: `expr e "" [: :]; `S LR "LEVEL"; `string s k :] - | Slist0 s -> HVbox [: `S LR "LIST0"; `symbol s k :] - | Slist0sep s sep -> - HVbox - [: `S LR "LIST0"; `symbol s [: :]; `S LR "SEP"; - `symbol sep k :] - | Slist1 s -> HVbox [: `S LR "LIST1"; `symbol s k :] - | Slist1sep s sep -> - HVbox - [: `S LR "LIST1"; `symbol s [: :]; `S LR "SEP"; - `symbol sep k :] - | Sopt s -> HVbox [: `S LR "OPT"; `symbol s k :] - | Sself -> HVbox [: `S LR "SELF"; k :] - | Snext -> HVbox [: `S LR "NEXT"; k :] - | Stoken tok -> token tok k - | Srules - [([(Some <:patt< a >>, Snterm <:expr< a_list >>)], Some <:expr< a >>); - ([(Some <:patt< a >>, - ((Slist0 _ | Slist1 _ | Slist0sep _ _ | Slist1sep _ _) as s))], - Some <:expr< Qast.List a >>)] - when not no_slist.val - -> - match s with - [ Slist0 s -> HVbox [: `S LR "SLIST0"; `simple_symbol s k :] - | Slist1 s -> HVbox [: `S LR "SLIST1"; `simple_symbol s k :] - | Slist0sep s sep -> - HVbox - [: `S LR "SLIST0"; `simple_symbol s [: :]; `S LR "SEP"; - `symbol sep k :] - | Slist1sep s sep -> - HVbox - [: `S LR "SLIST1"; `simple_symbol s [: :]; `S LR "SEP"; - `simple_symbol sep k :] - | _ -> assert False ] - | Srules - [([(Some <:patt< a >>, Snterm <:expr< a_opt >>)], Some <:expr< a >>); - ([(Some <:patt< a >>, Sopt s)], Some <:expr< Qast.Option a >>)] - when not no_slist.val - -> - let s = - match s with - [ Srules - [([(Some <:patt< x >>, Stoken ("", str))], - Some <:expr< Qast.Str x >>)] -> - Stoken ("", str) - | s -> s ] - in - HVbox [: `S LR "SOPT"; `simple_symbol s k :] - | Srules rl -> - let rl = simplify_rules rl in - HVbox [: `HVbox [: :]; rule_list rl k :] ] -and simple_symbol s k = - match s with - [ Snterml _ _ -> HVbox [: `S LO "("; `symbol s [: `S RO ")"; k :] :] - | s -> symbol s k ] -and psymbol (p, s) k = - match p with - [ None -> symbol s k - | Some p -> HVbox [: `patt p "" [: `S LR "=" :]; `symbol s k :] ] -and psymbol_list sl k = - listws psymbol (S RO ";") sl k -and rule b (sl, a) dg k = - match a with - [ None -> HVbox [: b; `HOVbox [: psymbol_list sl k :] :] - | Some a -> - HVbox - [: b; - `HOVbox - [: `HOVbox - [: `HVbox [: :]; - psymbol_list sl [: `S LR "->" :] :]; - `action expr a dg k :] :] ] -and rule_list ll k = - listwbws rule [: `S LR "[" :] (S LR "|") ll "" - [: `S LR "]"; k :] -; - -value label = - fun - [ Some s -> [: `S LR ("\"" ^ s ^ "\"") :] - | None -> [: :] ] -; - -value assoc = - fun - [ Some Gramext.NonA -> [: `S LR "NONA" :] - | Some Gramext.LeftA -> [: `S LR "LEFTA" :] - | Some Gramext.RightA -> [: `S LR "RIGHTA" :] - | None -> [: :] ] -; - -value level b (lab, ass, rl) dg k = - let s = - if rl = [] then [: `S LR "[ ]"; k :] - else [: `Vbox [: `HVbox [: :]; rule_list rl k :] :] - in - match (lab, ass) with - [ (None, None) -> HVbox [: b; s :] - | _ -> - Vbox - [: `HVbox [: b; label lab; assoc ass :]; - `HVbox [: `HVbox [: :]; s :] :] ] -; - -value level_list ll k = - Vbox - [: `HVbox [: :]; - listwbws level [: `S LR "[" :] (S LR "|") ll "" - [: `S LR "]"; k :] :] -; - -value entry (e, pos, ll) k = - BEbox - [: `LocInfo (MLast.loc_of_expr e) - (HVbox [: `expr e "" [: `S RO ":" :]; position pos :]); - `level_list ll [: :]; - `HVbox [: `S RO ";"; k :] :] -; - -value entry_list el k = - Vbox [: `HVbox [: :]; list entry el k :] -; - -value extend_body (globals, e) k = - let s = entry_list e k in - match globals with - [ [] -> s - | sl -> - HVbox - [: `HVbox [: :]; - `HOVbox - [: `S LR "GLOBAL"; `S RO ":"; - list (fun e k -> HVbox [: `expr e "" k :]) sl - [: `S RO ";" :] :]; - `s :] ] -; - -value extend e dg k = - match e with - [ <:expr< Grammar.extend $e$ >> -> - try - let ex = unextend_body e in - BEbox - [: `S LR "EXTEND"; `extend_body ex [: :]; - `HVbox [: `S LR "END"; k :] :] - with - [ Not_found -> - HVbox - [: `S LR "Grammar.extend"; - `HOVbox - [: `S LO "("; - `expr e "" [: `HVbox [: `S RO ")"; k :] :] :] :] ] - | _ -> expr e "" k ] -; - -value get_gextend = - fun - [ <:expr< let $list:gl$ in $e$ >> -> - try - let (gmod, gl) = get_globals gl in - let el = ungextend_body e in - Some (gmod, gl, el) - with - [ Not_found -> None ] - | _ -> None ] -; - -value gextend e dg k = - match get_gextend e with - [ Some (gmod, gl, el) -> - BEbox - [: `HVbox [: `S LR "GEXTEND"; `S LR gmod :]; - `extend_body (gl, el) [: :]; - `HVbox [: `S LR "END"; k :] :] - | None -> expr e "" k ] -; - -value is_gextend e = get_gextend e <> None; - -(* Printer extensions *) - -let lev = - try find_pr_level "expr1" pr_expr.pr_levels with - [ Failure _ -> find_pr_level "top" pr_expr.pr_levels ] -in -lev.pr_rules := - extfun lev.pr_rules with - [ <:expr< let $list:_$ in $_$ >> as e when is_gextend e -> - fun curr next _ k -> [: `next e "" k :] ]; - -let lev = find_pr_level "apply" pr_expr.pr_levels in -lev.pr_rules := - extfun lev.pr_rules with - [ <:expr< Grammar.extend $_$ >> as e -> - fun curr next _ k -> [: `next e "" k :] ]; - -let lev = find_pr_level "simple" pr_expr.pr_levels in -lev.pr_rules := - extfun lev.pr_rules with - [ <:expr< Grammar.extend $_$ >> as e -> - fun curr next _ k -> [: `extend e "" k :] - | <:expr< let $list:_$ in $_$ >> as e when is_gextend e -> - fun curr next _ k -> [: `gextend e "" k :] ]; - -Pcaml.add_option "-no_slist" (Arg.Set no_slist) - "Don't reconstruct SLIST and SOPT"; diff --git a/camlp4/etc/pr_extfun.ml b/camlp4/etc/pr_extfun.ml deleted file mode 100644 index 4d5c036615..0000000000 --- a/camlp4/etc/pr_extfun.ml +++ /dev/null @@ -1,92 +0,0 @@ -(* camlp4r q_MLast.cmo ./pa_extfun.cmo *) -(* $Id$ *) - -open Pcaml; -open Spretty; - -value loc = (0, 0); - -value expr e dg k = pr_expr.pr_fun "top" e dg k; -value patt e dg k = pr_patt.pr_fun "top" e dg k; - -value rec un_extfun rpel = - fun - [ <:expr< [ ($_$, $_$, fun [ $list:pel$ ]) :: $el$ ] >> -> - let (p, wo, e) = - match pel with - [ [(p, wo, <:expr< Some $e$ >>); - (<:patt< _ >>, None, <:expr< None >>)] -> - (p, wo, e) - | [(p, wo, <:expr< Some $e$ >>)] -> (p, wo, e) - | _ -> raise Not_found ] - in - let rpel = - match rpel with - [ [(p1, wo1, e1) :: pel] -> - if wo1 = wo && e1 = e then - let p = - match (p1, p) with - [ (<:patt< ($x1$ as $x2$) >>, <:patt< ($y1$ as $y2$) >>) -> - if x2 = y2 then <:patt< ($x1$ | $y1$ as $x2$) >> - else <:patt< $p1$ | $p$ >> - | _ -> <:patt< $p1$ | $p$ >> ] - in - [(p, wo, e) :: pel] - else [(p, wo, e) :: rpel] - | [] -> [(p, wo, e)] ] - in - un_extfun rpel el - | <:expr< [] >> -> List.rev rpel - | _ -> raise Not_found ] -; - -value rec listwbws elem b sep el k = - match el with - [ [] -> [: b; k :] - | [x] -> [: `elem b x k :] - | [x :: l] -> [: `elem b x [: :]; listwbws elem [: `sep :] sep l k :] ] -; - -value rec match_assoc_list pwel k = - match pwel with - [ [pwe] -> match_assoc [: `S LR "[" :] pwe [: `S LR "]"; k :] - | pel -> - Vbox - [: `HVbox [: :]; - listwbws match_assoc [: `S LR "[" :] (S LR "|") pel - [: `S LR "]"; k :] :] ] -and match_assoc b (p, w, e) k = - let s = - let (p, k) = - match p with - [ <:patt< ($p$ as $p2$) >> -> (p, [: `S LR "as"; `patt p2 "" [: :] :]) - | _ -> (p, [: :]) ] - in - match w with - [ Some e1 -> - [: `HVbox - [: `HVbox [: :]; `patt p "" k; - `HVbox [: `S LR "when"; `expr e1 "" [: `S LR "->" :] :] :] :] - | _ -> [: `patt p "" [: k; `S LR "->" :] :] ] - in - HVbox [: b; `HVbox [: `HVbox s; `expr e "" k :] :] -; - -let lev = find_pr_level "top" pr_expr.pr_levels in -lev.pr_rules := - extfun lev.pr_rules with - [ <:expr< Extfun.extend $e$ $list$ >> as ge -> - fun curr next dg k -> - try - let pel = un_extfun [] list in - [: `HVbox [: :]; - `BEbox [: `S LR "extfun"; `expr e "" [: :]; `S LR "with" :]; - `match_assoc_list pel k :] - with - [ Not_found -> [: `next ge dg k :] ] ]; - -let lev = find_pr_level "apply" pr_expr.pr_levels in -lev.pr_rules := - extfun lev.pr_rules with - [ <:expr< Extfun.extend $e$ $list$ >> as ge -> - fun curr next dg k -> [: `next ge dg k :] ]; diff --git a/camlp4/etc/pr_null.ml b/camlp4/etc/pr_null.ml deleted file mode 100644 index 40566f24d3..0000000000 --- a/camlp4/etc/pr_null.ml +++ /dev/null @@ -1,16 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1998 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -Pcaml.print_interf.val := fun _ -> (); -Pcaml.print_implem.val := fun _ -> (); diff --git a/camlp4/etc/pr_o.ml b/camlp4/etc/pr_o.ml deleted file mode 100644 index d87566726a..0000000000 --- a/camlp4/etc/pr_o.ml +++ /dev/null @@ -1,2062 +0,0 @@ -(* camlp4r q_MLast.cmo ./pa_extfun.cmo *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -open Pcaml; -open Spretty; -open Stdpp; - -value no_ss = ref True; - -value not_impl name x = - let desc = - if Obj.is_block (Obj.repr x) then - "tag = " ^ string_of_int (Obj.tag (Obj.repr x)) - else "int_val = " ^ string_of_int (Obj.magic x) - in - HVbox [: `S NO ("") :] -; - -value apply_it l f = - apply_it_f l where rec apply_it_f = - fun - [ [] -> f - | [a :: l] -> a (apply_it_f l) ] -; - -value rec list elem = - fun - [ [] -> fun _ k -> k - | [x] -> fun dg k -> [: `elem x dg k :] - | [x :: l] -> fun dg k -> [: `elem x "" [: :]; list elem l dg k :] ] -; - -value rec listws elem sep el dg k = - match el with - [ [] -> k - | [x] -> [: `elem x dg k :] - | [x :: l] -> - let sdg = - match sep with - [ S _ x -> x - | _ -> "" ] - in - [: `elem x sdg [: `sep :]; listws elem sep l dg k :] ] -; - -value rec listwbws elem b sep el dg k = - match el with - [ [] -> [: b; k :] - | [x] -> [: `elem b x dg k :] - | [x :: l] -> - let sdg = - match sep with - [ S _ x -> x - | _ -> "" ] - in - [: `elem b x sdg [: :]; listwbws elem [: `sep :] sep l dg k :] ] -; - -value level box elem next e dg k = - let rec curr e dg k = elem curr next e dg k in - box (curr e dg k) -; - -value is_infix = - let infixes = Hashtbl.create 73 in - do { - List.iter (fun s -> Hashtbl.add infixes s True) - ["=="; "!="; "+"; "+."; "-"; "-."; "*"; "*."; "/"; "/."; "**"; "**."; - "="; "=."; "<>"; "<>."; "<"; "<."; ">"; ">."; "<="; "<=."; ">="; ">=."; - "^"; "@"; "asr"; "land"; "lor"; "lsl"; "lsr"; "lxor"; "mod"; "or"; - "&&"; "||"; "~-"; "~-."]; - fun s -> try Hashtbl.find infixes s with [ Not_found -> False ] - } -; - -value is_keyword = - let keywords = Hashtbl.create 301 in - do { - List.iter (fun s -> Hashtbl.add keywords s True) - ["!"; "!="; "#"; "$"; "%"; "&"; "&&"; "'"; "("; ")"; "*"; "**"; "+"; - ","; "-"; "-."; "->"; "."; ".."; "/"; ":"; "::"; ":="; ":>"; ";"; ";;"; - "<"; "<-"; "<="; "<>"; "="; "=="; ">"; ">="; ">]"; ">}"; "?"; "??"; - "@"; "["; "[<"; "[|"; "]"; "^"; "_"; "`"; "and"; "as"; "assert"; "asr"; - "begin"; "class"; "constraint"; "do"; "done"; "downto"; "else"; "end"; - "exception"; "external"; "false"; "for"; "fun"; "function"; "functor"; - "if"; "in"; "include"; "inherit"; "initializer"; "land"; "lazy"; "let"; - "lor"; "lsl"; "lsr"; "lxor"; "match"; "method"; "mod"; "module"; - "mutable"; "new"; "object"; "of"; "open"; "or"; "parser"; "private"; - "rec"; "sig"; "struct"; "then"; "to"; "true"; "try"; "type"; "val"; - "virtual"; "when"; "while"; "with"; "{"; "{<"; "|"; "|]"; "||"; "}"; - "~"; "~-"; "~-."]; - fun s -> try Hashtbl.find keywords s with [ Not_found -> False ] - } -; - -value has_special_chars v = - match v.[0] with - [ 'a'..'z' | 'A'..'Z' | '\192'..'\214' | '\216'..'\246' | '\248'..'\255' | - '_' -> - False - | _ -> - if String.length v >= 2 && v.[0] == '<' && - (v.[1] == '<' || v.[1] == ':') - then - False - else True ] -; - -value var_escaped v = - if v = "" then "$lid:\"\"$" - else if has_special_chars v || is_infix v then "( " ^ v ^ " )" - else if is_keyword v then v ^ "__" - else v -; - -value flag n f = if f then [: `S LR n :] else [: :]; - -value conv_con = - fun - [ "True" -> "true" - | "False" -> "false" - | " True" -> "True" - | " False" -> "False" - | x -> x ] -; - -value conv_lab = - fun - [ "val" -> "contents" - | x -> var_escaped x ] -; - -(* default global loc *) - -value loc = (0, 0); - -value id_var s = - if has_special_chars s || is_infix s then - HVbox [: `S LR "("; `S LR s; `S LR ")" :] - else if is_keyword s then HVbox [: `S LR (s ^ "__") :] - else HVbox [: `S LR s :] -; - -value virtual_flag = - fun - [ True -> [: `S LR "virtual" :] - | _ -> [: :] ] -; - -value rec_flag = - fun - [ True -> [: `S LR "rec" :] - | _ -> [: :] ] -; - -(* extensible printers *) - -value sig_item x dg k = - let k = if no_ss.val then k else [: `S RO ";;"; k :] in - pr_sig_item.pr_fun "top" x "" k -; -value str_item x dg k = - let k = if no_ss.val then k else [: `S RO ";;"; k :] in - pr_str_item.pr_fun "top" x "" k -; -value module_type e k = pr_module_type.pr_fun "top" e "" k; -value module_expr e dg k = pr_module_expr.pr_fun "top" e "" k; -value expr e dg k = pr_expr.pr_fun "top" e dg k; -value patt e dg k = pr_patt.pr_fun "top" e dg k; -value expr1 e dg k = pr_expr.pr_fun "expr1" e dg k; -value simple_expr e dg k = pr_expr.pr_fun "simple" e dg k; -value patt1 e dg k = pr_patt.pr_fun "patt1" e dg k; -value simple_patt e dg k = pr_patt.pr_fun "simple" e dg k; -value ctyp e dg k = pr_ctyp.pr_fun "top" e dg k; -value simple_ctyp e dg k = pr_ctyp.pr_fun "simple" e dg k; -value expr_fun_args ge = Extfun.apply pr_expr_fun_args.val ge; -value class_sig_item x dg k = pr_class_sig_item.pr_fun "top" x "" k; -value class_str_item x dg k = pr_class_str_item.pr_fun "top" x "" k; -value class_type x k = pr_class_type.pr_fun "top" x "" k; -value class_expr x k = pr_class_expr.pr_fun "top" x "" k; - -(* type core *) - -value mutable_flag = - fun - [ True -> [: `S LR "mutable" :] - | _ -> [: :] ] -; - -value private_flag = - fun - [ True -> [: `S LR "private" :] - | _ -> [: :] ] -; - -value rec labels loc b vl _ k = - match vl with - [ [] -> [: b; k :] - | [v] -> - [: `label True b v "" k; `LocInfo (snd loc, snd loc) (HVbox [: :]) :] - | [v :: l] -> [: `label False b v "" [: :]; labels loc [: :] l "" k :] ] -and label is_last b (loc, f, m, t) _ k = - let m = flag "mutable" m in - let k = [: if is_last then [: :] else [: `S RO ";" :]; k :] in - Hbox - [: `LocInfo loc - (HVbox - [: `HVbox [: b; m; `S LR (conv_lab f); `S LR ":" :]; - `ctyp t "" [: :] :]); - k :] -; - -value rec ctyp_list tel _ k = listws simple_ctyp (S LR "*") tel "" k; - -value rec variants loc b vl dg k = - match vl with - [ [] -> [: b; k :] - | [v] -> [: `variant b v "" k; `LocInfo (snd loc, snd loc) (HVbox [: :]) :] - | [v :: l] -> - [: `variant b v "" [: :]; variants loc [: `S LR "|" :] l "" k :] ] -and variant b (loc, c, tl) _ k = - match tl with - [ [] -> HVbox [: `LocInfo loc (HVbox b); `HOVbox [: `S LR c; k :] :] - | _ -> - HVbox - [: `LocInfo loc (HVbox b); - `HOVbox [: `S LR c; `S LR "of"; ctyp_list tl "" k :] :] ] -; - -value rec row_fields b rfl _ k = listwbws row_field b (S LR "|") rfl "" k -and row_field b rf _ k = - match rf with - [ MLast.RfTag c ao tl -> - let c = "`" ^ c in - match tl with - [ [] -> HVbox [: b; `HOVbox [: `S LR c; k :] :] - | _ -> - let ao = if ao then [: `S LR "&" :] else [: :] in - HVbox - [: b; - `HOVbox [: `S LR c; `S LR "of"; ao; ctyp_list tl "" k :] :] ] - | MLast.RfInh t -> HVbox [: b; `ctyp t "" k :] ] -; - -value rec get_type_args t tl = - match t with - [ <:ctyp< $t1$ $t2$ >> -> get_type_args t1 [t2 :: tl] - | _ -> (t, tl) ] -; - -value module_pref = - apply_it - [level (fun x -> HOVbox x) - (fun curr next t _ k -> - match t with - [ <:ctyp< $t1$ $t2$ >> -> - let (t, tl) = get_type_args t1 [t2] in - [: curr t "" [: :]; - list - (fun t _ k -> - HOVbox [: `S NO "("; curr t "" [: :]; `S RO ")"; k :]) - tl "" k :] - | <:ctyp< $t1$ . $t2$ >> -> - [: curr t1 "" [: `S NO "." :]; `next t2 "" k :] - | _ -> [: `next t "" k :] ])] - simple_ctyp -; - -value rec class_longident sl dg k = - match sl with - [ [i] -> HVbox [: `S LR i; k :] - | [m :: sl] -> HVbox [: `S LR m; `S NO "."; `class_longident sl dg k :] - | _ -> HVbox [: `not_impl "class_longident" sl; k :] ] -; - -value rec clty_longident sl dg k = - match sl with - [ [i] -> HVbox [: `S LR i; k :] - | [m :: sl] -> HVbox [: `S LR m; `S NO "."; `clty_longident sl dg k :] - | _ -> HVbox [: `not_impl "clty_longident" sl; k :] ] -; - -value rec meth_list (ml, v) dg k = - match (ml, v) with - [ ([f], False) -> [: `field f dg k :] - | ([], _) -> [: `S LR ".."; k :] - | ([f :: ml], v) -> - [: `field f "" [: `S RO ";" :]; meth_list (ml, v) dg k :] ] -and field (lab, t) dg k = - HVbox [: `S LR (var_escaped lab); `S LR ":"; `ctyp t dg k :] -; - -(* patterns *) - -value rec get_patt_args a al = - match a with - [ <:patt< $a1$ $a2$ >> -> get_patt_args a1 [a2 :: al] - | _ -> (a, al) ] -; - -value rec is_irrefut_patt = - fun - [ <:patt< $lid:_$ >> -> True - | <:patt< () >> -> True - | <:patt< _ >> -> True - | <:patt< ($x$ as $y$) >> -> is_irrefut_patt x && is_irrefut_patt y - | <:patt< { $list:fpl$ } >> -> - List.for_all (fun (_, p) -> is_irrefut_patt p) fpl - | <:patt< ($p$ : $_$) >> -> is_irrefut_patt p - | <:patt< ($list:pl$) >> -> List.for_all is_irrefut_patt pl - | <:patt< ? $_$ : ($p$) >> -> is_irrefut_patt p - | <:patt< ? $_$ : ($p$ = $_$) >> -> is_irrefut_patt p - | <:patt< ~ $_$ >> -> True - | <:patt< ~ $_$ : $p$ >> -> is_irrefut_patt p - | _ -> False ] -; - -(* expressions *) - -pr_expr_fun_args.val := - extfun Extfun.empty with - [ <:expr< fun [$p$ -> $e$] >> as ge -> - if is_irrefut_patt p then - let (pl, e) = expr_fun_args e in - ([p :: pl], e) - else ([], ge) - | ge -> ([], ge) ]; - -value raise_match_failure (bp, ep) k = - let (fname, line, char, _) = - if Pcaml.input_file.val <> "-" then - Stdpp.line_of_loc Pcaml.input_file.val (bp, ep) - else - ("-", 1, bp, ep) - in - HOVbox - [: `S LR "raise"; `S LO "("; `S LR "Match_failure"; `S LO "("; - `S LR ("\"" ^ fname ^ "\""); `S RO ","; - `S LR (string_of_int line); `S RO ","; `S LR (string_of_int char); - `S RO ")"; `S RO ")"; k :] -; - -value rec bind_list b pel _ k = - match pel with - [ [pe] -> let_binding b pe "" k - | pel -> - Vbox [: `HVbox [: :]; listwbws let_binding b (S LR "and") pel "" k :] ] -and let_binding b (p, e) _ k = - let loc = - let (bp1, ep1) = MLast.loc_of_patt p in - let (bp2, ep2) = MLast.loc_of_expr e in - (min bp1 bp2, max ep1 ep2) - in - LocInfo loc (BEbox (let_binding0 b p e k)) -and let_binding0 b p e k = - let (pl, e) = - match p with - [ <:patt< ($_$ : $_$) >> -> ([], e) - | _ -> expr_fun_args e ] - in - let b = [: b; `simple_patt p "" [: :] :] in - match (p, e) with - [ (<:patt< $lid:_$ >>, <:expr< ($e$ : $t$) >>) -> - [: `HVbox - [: `HVbox b; `HVbox (list simple_patt pl "" [: `S LR ":" :]); - `ctyp t "" [: `S LR "=" :] :]; - `expr e "" [: :]; k :] - | _ -> - [: `HVbox - [: `HVbox b; `HOVbox (list simple_patt pl "" [: `S LR "=" :]) :]; - `expr e "" [: :]; k :] ] -and match_assoc_list loc pel dg k = - match pel with - [ [] -> - HVbox - [: `HVbox [: `S LR "_"; `S LR "->" :]; `raise_match_failure loc k :] - | _ -> - BEVbox - [: `HVbox [: :]; listwbws match_assoc [: :] (S LR "|") pel "" k :] ] -and match_assoc b (p, w, e) dg k = - let s = - match w with - [ Some e1 -> - [: `HVbox - [: `HVbox [: :]; `patt p "" [: :]; - `HVbox [: `S LR "when"; `expr e1 "" [: `S LR "->" :] :] :] :] - | _ -> [: `patt p "" [: `S LR "->" :] :] ] - in - HVbox [: b; `HVbox [: `HVbox s; `expr e dg k :] :] -; - -value rec get_expr_args a al = - match a with - [ <:expr< $a1$ $a2$ >> -> get_expr_args a1 [a2 :: al] - | _ -> (a, al) ] -; - -value label lab = S LR (var_escaped lab); - -value field_expr (lab, e) dg k = - HVbox [: `label lab; `S LR "="; `expr e dg k :] -; - -value type_params sl _ k = - match sl with - [ [] -> k - | [(s, vari)] -> - let b = - match vari with - [ (True, False) -> [: `S LO "+" :] - | (False, True) -> [: `S LO "-" :] - | _ -> [: :] ] - in - [: b; `S LO "'"; `S LR s; k :] - | sl -> - [: `S LO "("; - listws (fun (s, _) _ k -> HVbox [: `S LO "'"; `S LR s; k :]) - (S RO ",") sl "" [: `S RO ")"; k :] :] ] -; - -value constrain (t1, t2) _ k = - HVbox [: `S LR "constraint"; `ctyp t1 "" [: `S LR "=" :]; `ctyp t2 "" k :] -; - -value type_list b tdl _ k = - HVbox - [: `HVbox [: :]; - listwbws - (fun b ((_, tn), tp, te, cl) _ k -> - let tn = var_escaped tn in - let cstr = list constrain cl "" k in - match te with - [ <:ctyp< '$s$ >> when not (List.mem_assoc s tp) -> - HVbox [: b; type_params tp "" [: :]; `S LR tn; cstr :] - | <:ctyp< [ $list:[]$ ] >> -> - HVbox [: b; type_params tp "" [: :]; `S LR tn; cstr :] - | _ -> - HVbox - [: `HVbox - [: b; type_params tp "" [: :]; `S LR tn; `S LR "=" :]; - `ctyp te "" [: :]; cstr :] ]) - b (S LR "and") tdl "" [: :]; - k :] -; - -value external_def (s, t, pl) _ k = - let ls = - list (fun s _ k -> HVbox [: `S LR ("\"" ^ s ^ "\""); k :]) pl "" k - in - HVbox - [: `HVbox [: `S LR "external"; `S LR (var_escaped s); `S LR ":" :]; - `ctyp t "" [: `S LR "="; ls :] :] -; - -value value_description (s, t) _ k = - HVbox - [: `HVbox [: `S LR "val"; `S LR (var_escaped s); `S LR ":" :]; - `ctyp t "" k :] -; - -value typevar s _ k = HVbox [: `S LR ("'" ^ s); k :]; - -value rec mod_ident sl _ k = - match sl with - [ [] -> k - | [s] -> [: `S LR s; k :] - | [s :: sl] -> [: `S LR s; `S NO "."; mod_ident sl "" k :] ] -; - -value rec module_declaration b mt k = - match mt with - [ <:module_type< functor ( $i$ : $t$ ) -> $mt$ >> -> - module_declaration - [: `HVbox - [: b; - `HVbox - [: `S LO "("; `S LR i; `S LR ":"; - `module_type t [: `S RO ")" :] :] :] :] - mt k - | _ -> - HVbox - [: `HVbox [: :]; - `HVbox [: `HVbox [: b; `S LR ":" :]; `module_type mt [: :] :]; - k :] ] -and module_rec_declaration b (n,mt) _ k = - HVbox - [: `HVbox - [: b; `S LR n; `S LR ":"; `module_type mt [: :] :]; - k :] -and modtype_declaration (s, mt) _ k = - match mt with - [ <:module_type< ' $_$ >> -> - HVbox [: `HVbox [: `S LR "module"; `S LR "type"; `S LR s; k :] :] - | _ -> - HVbox - [: `HVbox [: :]; - `HVbox - [: `HVbox - [: `S LR "module"; `S LR "type"; `S LR s; `S LR "=" :]; - `module_type mt [: :] :]; - k :] ] -and with_constraints b icl _ k = - HVbox [: `HVbox [: :]; listwbws with_constraint b (S LR "and") icl "" k :] -and with_constraint b wc _ k = - match wc with - [ MLast.WcTyp _ p al e -> - let params = - match al with - [ [] -> [: :] - | [s] -> [: `S LO "'"; `S LR (fst s) :] - | sl -> [: `S LO "("; type_params sl "" [: `S RO ")" :] :] ] - in - HVbox - [: `HVbox - [: `HVbox b; `S LR "type"; params; - mod_ident p "" [: `S LR "=" :] :]; - `ctyp e "" k :] - | MLast.WcMod _ sl me -> - HVbox - [: b; `S LR "module"; mod_ident sl "" [: `S LR "=" :]; - `module_expr me "" k :] ] -; - -value rec module_binding b me k = - match me with - [ <:module_expr< functor ($s$ : $mt$) -> $mb$ >> -> - module_binding - [: `HVbox - [: b; - `HVbox - [: `HVbox [: `S LO "("; `S LR s; `S LR ":" :]; - `module_type mt [: `S RO ")" :] :] :] :] - mb k - | <:module_expr< ( $me$ : $mt$ ) >> -> - HVbox - [: `HVbox [: :]; - `HVbox - [: `HVbox - [: `HVbox [: b; `S LR ":" :]; - `module_type mt [: `S LR "=" :] :]; - `module_expr me "" [: :] :]; - k :] - | _ -> - HVbox - [: `HVbox [: :]; - `HVbox [: `HVbox [: b; `S LR "=" :]; `module_expr me "" [: :] :]; - k :] ] -and module_rec_binding b (n, mt,me) _ k = - HVbox - [: `HVbox [: :]; - `HVbox - [: `HVbox - [: `HVbox [: b; `S LR n; `S LR ":" :]; - `module_type mt [: `S LR "=" :] :]; - `module_expr me "" [: :] :]; - k :] -and class_declaration b ci _ k = - class_fun_binding - [: b; virtual_flag ci.MLast.ciVir; class_type_parameters ci.MLast.ciPrm; - `S LR ci.MLast.ciNam :] - ci.MLast.ciExp k -and class_fun_binding b ce k = - match ce with - [ MLast.CeFun _ p cfb -> - class_fun_binding [: b; `simple_patt p "" [: :] :] cfb k - | ce -> HVbox [: `HVbox [: b; `S LR "=" :]; `class_expr ce k :] ] -and class_type_parameters (loc, tpl) = - match tpl with - [ [] -> [: :] - | tpl -> - [: `S LO "["; - listws type_parameter (S RO ",") tpl "" [: `S RO "]" :] :] ] -and type_parameter tp dg k = HVbox [: `S LO "'"; `S LR (fst tp); k :] -and class_self_patt_opt csp = - match csp with - [ Some p -> HVbox [: `S LO "("; `patt p "" [: `S RO ")" :] :] - | None -> HVbox [: :] ] -and cvalue b (lab, mf, e) k = - HVbox - [: `HVbox [: b; mutable_flag mf; `label lab; `S LR "=" :]; `expr e "" k :] -and fun_binding b fb k = - match fb with - [ <:expr< fun $p$ -> $e$ >> -> - fun_binding [: b; `simple_patt p "" [: :] :] e k - | e -> HVbox [: `HVbox [: b; `S LR "=" :]; `expr e "" k :] ] -and class_signature cs k = - match cs with - [ MLast.CtCon _ id [] -> clty_longident id "" k - | MLast.CtCon _ id tl -> - HVbox - [: `S LO "["; listws ctyp (S RO ",") tl "" [: `S RO "]" :]; - `clty_longident id "" k :] - | MLast.CtSig _ cst csf -> - let ep = snd (MLast.loc_of_class_type cs) in - class_self_type [: `S LR "object" :] cst - [: `HVbox - [: `HVbox [: :]; list class_sig_item csf "" [: :]; - `LocInfo (ep, ep) (HVbox [: :]) :]; - `HVbox [: `S LR "end"; k :] :] - | _ -> HVbox [: `not_impl "class_signature" cs; k :] ] -and class_self_type b cst k = - BEbox - [: `HVbox - [: b; - match cst with - [ None -> [: :] - | Some t -> [: `S LO "("; `ctyp t "" [: `S RO ")" :] :] ] :]; - k :] -and class_description b ci _ k = - HVbox - [: `HVbox - [: b; virtual_flag ci.MLast.ciVir; - class_type_parameters ci.MLast.ciPrm; `S LR ci.MLast.ciNam; - `S LR ":" :]; - `class_type ci.MLast.ciExp k :] -and class_type_declaration b ci _ k = - HVbox - [: `HVbox - [: b; virtual_flag ci.MLast.ciVir; - class_type_parameters ci.MLast.ciPrm; `S LR ci.MLast.ciNam; - `S LR "=" :]; - `class_signature ci.MLast.ciExp k :] -; - -pr_module_type.pr_levels := - [{pr_label = "top"; pr_box mt x = HVbox x; - pr_rules = - extfun Extfun.empty with - [ <:module_type< functor ( $s$ : $mt1$ ) -> $mt2$ >> -> - fun curr next dg k -> - let head = - HVbox - [: `S LR "functor"; `S LO "("; `S LR s; `S LR ":"; - `HVbox (curr mt1 "" [: `S RO ")" :]); `S LR "->" :] - in - [: `head; curr mt2 "" k :] - | e -> fun curr next dg k -> [: `next e dg k :] ]}; - {pr_label = ""; pr_box mt x = HVbox x; - pr_rules = - extfun Extfun.empty with - [ <:module_type< $mt$ with $list:icl$ >> -> - fun curr next dg k -> - [: curr mt "" [: :]; - `with_constraints [: `S LR "with" :] icl "" k :] - | e -> fun curr next dg k -> [: `next e dg k :] ]}; - {pr_label = ""; pr_box mt x = HVbox x; - pr_rules = - extfun Extfun.empty with - [ <:module_type< sig $list:s$ end >> as mt -> - fun curr next dg k -> - let ep = snd (MLast.loc_of_module_type mt) in - [: `BEbox - [: `S LR "sig"; - `HVbox - [: `HVbox [: :]; list sig_item s "" [: :]; - `LocInfo (ep, ep) (HVbox [: :]) :]; - `HVbox [: `S LR "end"; k :] :] :] - | e -> fun curr next dg k -> [: `next e dg k :] ]}; - {pr_label = ""; pr_box mt x = HVbox x; - pr_rules = - extfun Extfun.empty with - [ <:module_type< $mt1$ $mt2$ >> -> - fun curr next dg k -> - [: curr mt1 "" [: :]; `S LO "("; - `next mt2 "" [: `S RO ")"; k :] :] - | <:module_type< $mt1$ . $mt2$ >> -> - fun curr next dg k -> - [: curr mt1 "" [: `S NO "." :]; `next mt2 "" k :] - | e -> fun curr next dg k -> [: `next e dg k :] ]}; - {pr_label = ""; pr_box mt x = HVbox x; - pr_rules = - extfun Extfun.empty with - [ <:module_type< $lid:s$ >> -> fun curr next dg k -> [: `S LR s; k :] - | <:module_type< $uid:s$ >> -> fun curr next dg k -> [: `S LR s; k :] - | mt -> - fun curr next dg k -> - [: `S LO "("; `module_type mt [: `S RO ")"; k :] :] ]}]; - -pr_module_expr.pr_levels := - [{pr_label = "top"; pr_box mt x = HVbox x; - pr_rules = - extfun Extfun.empty with - [ <:module_expr< struct $list:s$ end >> as me -> - fun curr next dg k -> - let ep = snd (MLast.loc_of_module_expr me) in - [: `HVbox [: :]; - `HVbox - [: `S LR "struct"; list str_item s "" [: :]; - `LocInfo (ep, ep) (HVbox [: :]) :]; - `HVbox [: `S LR "end"; k :] :] - | <:module_expr< functor ($s$ : $mt$) -> $me$ >> -> - fun curr next dg k -> - let head = - HVbox - [: `S LR "functor"; `S LO "("; `S LR s; `S LR ":"; - `module_type mt [: `S RO ")" :]; `S LR "->" :] - in - [: `head; curr me "" k :] - | e -> fun curr next dg k -> [: `next e dg k :] ]}; - {pr_label = ""; pr_box mt x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:module_expr< $me1$ $me2$ >> -> - fun curr next dg k -> - [: curr me1 "" [: :]; - `HVbox - [: `S LO "("; `module_expr me2 "" [: `S RO ")"; k :] :] :] - | e -> fun curr next dg k -> [: `next e dg k :] ]}; - {pr_label = ""; pr_box mt x = HVbox x; - pr_rules = - extfun Extfun.empty with - [ <:module_expr< $me1$ . $me2$ >> -> - fun curr next dg k -> - [: curr me1 "" [: `S NO "." :]; `next me2 "" k :] - | e -> fun curr next dg k -> [: `next e dg k :] ]}; - {pr_label = ""; pr_box mt x = HVbox x; - pr_rules = - extfun Extfun.empty with - [ <:module_expr< $uid:s$ >> -> fun curr next dg k -> [: `S LR s; k :] - | <:module_expr< ( $me$ : $mt$ ) >> -> - fun curr next dg k -> - [: `S LO "("; `module_expr me "" [: `S LR ":" :]; - `module_type mt [: `S RO ")"; k :] :] - | <:module_expr< struct $list:_$ end >> | - <:module_expr< functor ($_$ : $_$) -> $_$ >> | - <:module_expr< $_$ $_$ >> | <:module_expr< $_$ . $_$ >> as me -> - fun curr next dg k -> - [: `S LO "("; `module_expr me "" [: `S RO ")"; k :] :] ]}]; - -pr_sig_item.pr_levels := - [{pr_label = "top"; - pr_box s x = LocInfo (MLast.loc_of_sig_item s) (HVbox x); - pr_rules = - extfun Extfun.empty with - [ <:sig_item< type $list:stl$ >> -> - fun curr next dg k -> [: `type_list [: `S LR "type" :] stl "" k :] - | <:sig_item< declare $list:s$ end >> -> - fun curr next dg k -> - if s = [] then [: `S LR "(* *)" :] - else [: `HVbox [: :]; list sig_item s "" [: :] :] - | MLast.SgDir _ _ _ as si -> - fun curr next dg k -> [: `not_impl "sig_item" si :] - | <:sig_item< exception $c$ of $list:tl$ >> -> - fun curr next dg k -> - [: `variant [: `S LR "exception" :] (loc, c, tl) "" k :] - | <:sig_item< value $s$ : $t$ >> -> - fun curr next dg k -> [: `value_description (s, t) "" k :] - | <:sig_item< external $s$ : $t$ = $list:pl$ >> -> - fun curr next dg k -> [: `external_def (s, t, pl) "" k :] - | <:sig_item< include $mt$ >> -> - fun curr next dg k -> [: `S LR "include"; `module_type mt k :] - | <:sig_item< module $s$ : $mt$ >> -> - fun curr next dg k -> - [: `module_declaration [: `S LR "module"; `S LR s :] mt k :] - | <:sig_item< module rec $list:nmts$ >> -> - fun curr next _ k -> - [: `HVbox [: :]; - listwbws module_rec_declaration [: `S LR "module rec" :] (S LR "and") nmts - "" k :] - | <:sig_item< module type $s$ = $mt$ >> -> - fun curr next dg k -> [: `modtype_declaration (s, mt) "" k :] - | <:sig_item< open $sl$ >> -> - fun curr next dg k -> [: `S LR "open"; mod_ident sl "" k :] - | MLast.SgCls _ cd -> - fun curr next dg k -> - [: `HVbox [: :]; - listwbws class_description [: `S LR "class" :] (S LR "and") cd - "" k :] - | MLast.SgClt _ cd -> - fun curr next dg k -> - [: `HVbox [: :]; - listwbws class_type_declaration - [: `S LR "class"; `S LR "type" :] (S LR "and") cd "" - k :] - | MLast.SgUse _ _ _ -> - fun curr next dg k -> [: :] ]}]; - -pr_str_item.pr_levels := - [{pr_label = "top"; - pr_box s x = LocInfo (MLast.loc_of_str_item s) (HVbox x); - pr_rules = - extfun Extfun.empty with - [ <:str_item< open $i$ >> -> - fun curr next dg k -> [: `S LR "open"; mod_ident i "" k :] - | <:str_item< $exp:e$ >> -> - fun curr next dg k -> - if no_ss.val then - [: `HVbox [: `S LR "let"; `S LR "_"; `S LR "=" :]; - `expr e "" k :] - else [: `HVbox [: :]; `expr e "" k :] - | <:str_item< declare $list:s$ end >> -> - fun curr next dg k -> - if s = [] then [: `S LR "(* *)" :] - else [: `HVbox [: :]; list str_item s "" [: :] :] - | <:str_item< # $s$ $opt:x$ >> -> - fun curr next dg k -> - let s = - "(* #" ^ s ^ " " ^ - (match x with - [ Some <:expr< $str:s$ >> -> "\"" ^ s ^ "\"" - | _ -> "?" ]) ^ - " *)" - in - [: `S LR s :] - | <:str_item< exception $c$ of $list:tl$ = $b$ >> -> - fun curr next dg k -> - match b with - [ [] -> [: `variant [: `S LR "exception" :] (loc, c, tl) "" k :] - | _ -> - [: `variant [: `S LR "exception" :] (loc, c, tl) "" - [: `S LR "=" :]; - mod_ident b "" k :] ] - | <:str_item< include $me$ >> -> - fun curr next dg k -> [: `S LR "include"; `module_expr me "" k :] - | <:str_item< type $list:tdl$ >> -> - fun curr next dg k -> [: `type_list [: `S LR "type" :] tdl "" k :] - | <:str_item< value $opt:rf$ $list:pel$ >> -> - fun curr next dg k -> - [: `bind_list - [: `S LR "let"; if rf then [: `S LR "rec" :] else [: :] :] - pel "" k :] - | <:str_item< external $s$ : $t$ = $list:pl$ >> -> - fun curr next dg k -> [: `external_def (s, t, pl) "" k :] - | <:str_item< module $s$ = $me$ >> -> - fun curr next dg k -> - [: `module_binding [: `S LR "module"; `S LR s :] me k :] - | <:str_item< module rec $list:nmtmes$ >> -> - fun curr next _ k -> - [: `HVbox [: :]; - listwbws module_rec_binding [: `S LR "module rec" :] (S LR "and") nmtmes - "" k :] - | <:str_item< module type $s$ = $mt$ >> -> - fun curr next dg k -> - [: `HVbox [: :]; - `HVbox - [: `HVbox - [: `S LR "module"; `S LR "type"; `S LR s; - `S LR "=" :]; - `module_type mt [: :] :]; - k :] - | MLast.StCls _ cd -> - fun curr next dg k -> - [: `HVbox [: :]; - listwbws class_declaration [: `S LR "class" :] (S LR "and") cd - "" k :] - | MLast.StClt _ cd -> - fun curr next dg k -> - [: `HVbox [: :]; - listwbws class_type_declaration - [: `S LR "class"; `S LR "type" :] (S LR "and") cd "" - k :] - | MLast.StUse _ _ _ -> - fun curr next dg k -> [: :] ]}]; - -value ocaml_char = - fun - [ "'" -> "\\'" - | "\"" -> "\\\"" - | c -> c ] -; - -pr_expr.pr_levels := - [{pr_label = "top"; pr_box e x = LocInfo (MLast.loc_of_expr e) (HOVbox x); - pr_rules = - extfun Extfun.empty with - [ <:expr< do { $list:el$ } >> -> - fun curr next dg k -> - [: `HVbox [: `HVbox [: :]; listws next (S RO ";") el dg k :] :] - | e -> fun curr next dg k -> [: `next e dg k :] ]}; - {pr_label = "expr1"; pr_box e x = LocInfo (MLast.loc_of_expr e) (HOVbox x); - pr_rules = - extfun Extfun.empty with - [ <:expr< let $opt:r$ $p1$ = $e1$ in $e$ >> -> - fun curr next dg k -> - let r = if r then [: `S LR "rec" :] else [: :] in - if dg <> ";" then - [: `HVbox - [: `HVbox [: :]; - `let_binding [: `S LR "let"; r :] (p1, e1) "" - [: `S LR "in" :]; - `expr e dg k :] :] - else - let pel = [(p1, e1)] in - [: `BEbox - [: `S LR "begin"; - `HVbox - [: `HVbox [: :]; - listwbws - (fun b (p, e) _ k -> let_binding b (p, e) "" k) - [: `S LR "let"; r :] (S LR "and") pel "" - [: `S LR "in" :]; - `expr e "" [: :] :]; - `HVbox [: `S LR "end"; k :] :] :] - | <:expr< let $opt:r$ $list:pel$ in $e$ >> -> - fun curr next dg k -> - let r = if r then [: `S LR "rec" :] else [: :] in - if dg <> ";" then - [: `Vbox - [: `HVbox [: :]; - listwbws - (fun b (p, e) _ k -> let_binding b (p, e) "" k) - [: `S LR "let"; r :] (S LR "and") pel "" - [: `S LR "in" :]; - `expr e dg k :] :] - else - [: `BEbox - [: `S LR "begin"; - `HVbox - [: `HVbox [: :]; - listwbws - (fun b (p, e) _ k -> let_binding b (p, e) "" k) - [: `S LR "let"; r :] (S LR "and") pel "" - [: `S LR "in" :]; - `expr e "" [: :] :]; - `HVbox [: `S LR "end"; k :] :] :] - | <:expr< let module $m$ = $mb$ in $e$ >> -> - fun curr next dg k -> - if dg <> ";" then - [: `HVbox - [: `HVbox [: :]; - `module_binding - [: `S LR "let"; `S LR "module"; `S LR m :] mb [: :]; - `S LR "in"; `expr e dg k :] :] - else - [: `BEbox - [: `module_binding - [: `S LR "begin let"; `S LR "module"; `S LR m :] mb - [: :]; - `HVbox - [: `HVbox [: :]; `S LR "in"; `expr e dg [: :] :]; - `HVbox [: `S LR "end"; k :] :] :] - | <:expr< fun [ $list:pel$ ] >> as e -> - fun curr next dg k -> - let loc = MLast.loc_of_expr e in - if not (List.mem dg ["|"; ";"]) then - match pel with - [ [] -> - [: `S LR "fun"; `S LR "_"; `S LR "->"; - `raise_match_failure loc k :] - | [(p, None, e)] -> - let (pl, e) = expr_fun_args e in - [: `BEbox - [: `HOVbox - [: `S LR "fun"; - list simple_patt [p :: pl] "" - [: `S LR "->" :] :]; - `expr e "" k :] :] - | _ -> - [: `Vbox - [: `HVbox [: :]; `S LR "function"; - `match_assoc_list loc pel "" k :] :] ] - else - match pel with - [ [] -> - [: `S LR "(fun"; `S LR "_"; `S LR "->"; - `raise_match_failure loc [: `S RO ")"; k :] :] - | [(p, None, e)] -> - if is_irrefut_patt p then - let (pl, e) = expr_fun_args e in - [: `S LO "("; - `BEbox - [: `HOVbox - [: `S LR "fun"; - list simple_patt [p :: pl] "" - [: `S LR "->" :] :]; - `expr e "" [: `S RO ")"; k :] :] :] - else - [: `HVbox - [: `S LR "fun ["; `patt p "" [: `S LR "->" :] :]; - `expr e "" [: `S LR "]"; k :] :] - | _ -> - [: `Vbox - [: `HVbox [: :]; `S LR "begin function"; - `match_assoc_list loc pel "" k; - `HVbox [: `S LR "end"; k :] :] :] ] - | <:expr< match $e$ with [ $list:pel$ ] >> as ge -> - fun curr next dg k -> - let loc = MLast.loc_of_expr ge in - if not (List.mem dg ["|"; ";"]) then - [: `HVbox - [: `HVbox [: :]; - `BEbox - [: `S LR "match"; `expr e "" [: :]; `S LR "with" :]; - `match_assoc_list loc pel "" k :] :] - else - [: `HVbox - [: `HVbox [: :]; - `BEbox - [: `S LR "begin match"; `expr e "" [: :]; - `S LR "with" :]; - `match_assoc_list loc pel "" [: :]; - `HVbox [: `S LR "end"; k :] :] :] - | <:expr< try $e$ with [ $list:pel$ ] >> as ge -> - fun curr next dg k -> - let loc = MLast.loc_of_expr ge in - if not (List.mem dg ["|"; ";"]) then - [: `HVbox - [: `HVbox [: :]; - `BEbox - [: `S LR "try"; `expr e "" [: :]; `S LR "with" :]; - `match_assoc_list loc pel "" k :] :] - else - [: `HVbox - [: `HVbox [: :]; - `BEbox - [: `S LR "begin try"; `expr e "" [: :]; - `S LR "with" :]; - `match_assoc_list loc pel "" [: :]; - `HVbox [: `S LR "end"; k :] :] :] - | <:expr< if $e1$ then $e2$ else $e3$ >> as e -> - fun curr next dg k -> - let eel_e = - elseif e3 where rec elseif e = - match e with - [ <:expr< if $e1$ then $e2$ else $e3$ >> -> - let (eel, e) = elseif e3 in - ([(e1, e2) :: eel], e) - | _ -> ([], e) ] - in - if not (List.mem dg ["else"]) then - match eel_e with - [ ([], <:expr< () >>) -> - [: `BEbox [: `S LR "if"; `expr e1 "" [: :]; `S LR "then" :]; - `expr1 e2 dg k :] - | (eel, <:expr< () >>) -> - let (eel, (e1f, e2f)) = - let r = List.rev eel in - (List.rev (List.tl r), List.hd r) - in - [: `HVbox - [: `HVbox [: :]; - `HVbox - [: `BEbox - [: `S LR "if"; `expr e1 "" [: :]; - `S LR "then" :]; - `expr1 e2 "else" [: :] :]; - list - (fun (e1, e2) _ k -> - HVbox - [: `BEbox - [: `HVbox - [: `S LR "else"; `S LR "if" :]; - `expr e1 "" [: :]; `S LR "then" :]; - `expr1 e2 "else" k :]) - eel "" [: :]; - `HVbox - [: `BEbox - [: `HVbox [: `S LR "else"; `S LR "if" :]; - `expr e1f "" [: :]; `S LR "then" :]; - `expr1 e2f dg k :] :] :] - | (eel, e) -> - [: `HVbox - [: `HVbox [: :]; - `HVbox - [: `BEbox - [: `S LR "if"; `expr e1 "" [: :]; - `S LR "then" :]; - `expr1 e2 "else" [: :] :]; - list - (fun (e1, e2) _ k -> - HVbox - [: `BEbox - [: `HVbox - [: `S LR "else"; `S LR "if" :]; - `expr e1 "" [: :]; `S LR "then" :]; - `expr1 e2 "else" k :]) - eel "" [: :]; - `HVbox [: `S LR "else"; `expr1 e dg k :] :] :] ] - else - match eel_e with - [ (_, <:expr< () >>) -> [: `next e "" k :] - | (eel, e) -> - [: `HVbox - [: `HVbox [: :]; - `HVbox - [: `BEbox - [: `S LR "if"; `expr e1 "" [: :]; - `S LR "then" :]; - `expr1 e2 "" [: :] :]; - list - (fun (e1, e2) _ k -> - HVbox - [: `BEbox - [: `HVbox - [: `S LR "else"; `S LR "if" :]; - `expr e1 "" [: :]; `S LR "then" :]; - `expr1 e2 "" [: :] :]) - eel "" [: :]; - `HVbox [: `S LR "else"; `expr1 e "" k :] :] :] ] - | <:expr< for $i$ = $e1$ $to:d$ $e2$ do { $list:el$ } >> -> - fun curr next dg k -> - let d = if d then "to" else "downto" in - [: `BEbox - [: `HOVbox - [: `S LR "for"; `S LR i; `S LR "="; - `expr e1 "" [: `S LR d :]; - `expr e2 "" [: `S LR "do" :] :]; - `HVbox - [: `HVbox [: :]; - listws expr (S RO ";") el "" [: :] :]; - `HVbox [: `S LR "done"; k :] :] :] - | <:expr< while $e1$ do { $list:el$ } >> -> - fun curr next dg k -> - [: `BEbox - [: `BEbox - [: `S LR "while"; `expr e1 "" [: :]; `S LR "do" :]; - `HVbox - [: `HVbox [: :]; - listws expr (S RO ";") el "" [: :] :]; - `HVbox [: `S LR "done"; k :] :] :] - | e -> fun curr next dg k -> [: `next e dg k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:expr< ($list:el$) >> -> - fun curr next dg k -> - [: `HVbox [: :]; listws next (S RO ",") el "" k :] - | e -> fun curr next dg k -> [: `next e dg k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:expr< $x$.val := $y$ >> -> - fun curr next dg k -> - [: `next x "" [: `S LR ":=" :]; `expr y dg k :] - | <:expr< $x$ := $y$ >> -> - fun curr next dg k -> - [: `next x "" [: `S LR "<-" :]; `expr y dg k :] - | e -> fun curr next dg k -> [: `next e "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox [: `HVbox [: :]; x :]; - pr_rules = - extfun Extfun.empty with - [ <:expr< $lid:("||" as f)$ $x$ $y$ >> -> - fun curr next dg k -> [: `next x "" [: `S LR f :]; curr y "" k :] - | <:expr< $lid:("or" as f)$ $x$ $y$ >> -> - fun curr next dg k -> [: `next x "" [: `S LR f :]; curr y "" k :] - | e -> fun curr next dg k -> [: `next e dg k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox [: `HVbox [: :]; x :]; - pr_rules = - extfun Extfun.empty with - [ <:expr< $lid:(("&&") as f)$ $x$ $y$ >> -> - fun curr next dg k -> [: `next x "" [: `S LR f :]; curr y "" k :] - | <:expr< $lid:(("&") as f)$ $x$ $y$ >> -> - fun curr next dg k -> [: `next x "" [: `S LR f :]; curr y "" k :] - | e -> fun curr next dg k -> [: `next e dg k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:expr< $lid:op$ $x$ $y$ >> as e -> - fun curr next dg k -> - match op with - [ "=" | "<>" | "<" | "<." | "<=" | ">" | ">=" | ">=." | "==" | - "!=" -> - [: curr x "" [: `S LR op :]; `next y "" k :] - | _ -> [: `next e "" k :] ] - | e -> fun curr next dg k -> [: `next e dg k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:expr< $lid:op$ $x$ $y$ >> as e -> - fun curr next dg k -> - match op with - [ "^" | "@" -> [: `next x "" [: `S LR op :]; curr y "" k :] - | _ -> [: `next e "" k :] ] - | e -> fun curr next dg k -> [: `next e dg k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:expr< [$_$ :: $_$] >> as e -> - fun curr next dg k -> - let (el, c) = - make_list e where rec make_list e = - match e with - [ <:expr< [$e$ :: $y$] >> -> - let (el, c) = make_list y in - ([e :: el], c) - | <:expr< [] >> -> ([], None) - | x -> ([], Some e) ] - in - match c with - [ None -> [: `next e "" k :] - | Some x -> - [: listws next (S LR "::") el "" [: `S LR "::" :]; - `next x "" k :] ] - | e -> fun curr next dg k -> [: `next e dg k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:expr< $lid:op$ $x$ $y$ >> as e -> - fun curr next dg k -> - match op with - [ "+" | "+." | "-" | "-." -> - [: curr x "" [: `S LR op :]; `next y "" k :] - | _ -> [: `next e "" k :] ] - | e -> fun curr next dg k -> [: `next e dg k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:expr< $lid:op$ $x$ $y$ >> as e -> - fun curr next dg k -> - match op with - [ "*" | "/" | "*." | "/." | "land" | "lor" | "lxor" | "mod" -> - [: curr x "" [: `S LR op :]; `next y "" k :] - | _ -> [: `next e "" k :] ] - | e -> fun curr next dg k -> [: `next e dg k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:expr< $lid:op$ $x$ $y$ >> as e -> - fun curr next dg k -> - match op with - [ "**" | "asr" | "lsl" | "lsr" -> - [: `next x "" [: `S LR op :]; curr y "" k :] - | _ -> [: `next e "" k :] ] - | e -> fun curr next dg k -> [: `next e dg k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:expr< $lid:"~-"$ $x$ >> -> - fun curr next dg k -> [: `S LR "-"; curr x "" k :] - | <:expr< $lid:"~-."$ $x$ >> -> - fun curr next dg k -> [: `S LR "-."; curr x "" k :] - | e -> fun curr next dg k -> [: `next e dg k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ ( <:expr< $int:x$ >> | <:expr< $flo:x$ >> ) - -> fun curr next dg k -> [: `S LR x; k :] - | MLast.ExInt32 _ x -> fun curr next dg k -> [: `S LR (x^"l"); k :] - | MLast.ExInt64 _ x -> fun curr next dg k -> [: `S LR (x^"L"); k :] - | MLast.ExNativeInt _ x -> fun curr next dg k -> [: `S LR (x^"n"); k :] - | e -> fun curr next dg k -> [: `next e dg k :] ]}; - {pr_label = "apply"; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:expr< [$_$ :: $_$] >> as e -> - fun curr next dg k -> [: `next e "" k :] - | <:expr< lazy ($x$) >> -> - fun curr next dg k -> [: `S LR "lazy"; `next x "" k :] - | MLast.ExAsf _ -> -(* | <:expr< assert False >> -> *) - fun curr next dg k -> [: `S LR "assert"; `S LR "false"; k :] - | MLast.ExAsr _ e -> -(* | <:expr< assert ($e$) >> -> *) - fun curr next dg k -> [: `S LR "assert"; `next e "" k :] - | <:expr< $lid:n$ $x$ $y$ >> as e -> - fun curr next dg k -> - let loc = MLast.loc_of_expr e in - if is_infix n then [: `next e "" k :] - else [: curr <:expr< $lid:n$ $x$ >> "" [: :]; `next y "" k :] - | <:expr< $x$ $y$ >> -> - fun curr next dg k -> - match get_expr_args x [y] with - [ (_, [_]) -> [: curr x "" [: :]; `next y "" k :] - | ((<:expr< $uid:_$ >> | <:expr< $_$ . $uid:_$ >> as a), al) -> - [: curr a "" [: :]; - `HOVbox - [: `S LO "("; - listws (fun x _ k -> HOVbox [: curr x "" k :]) - (S RO ",") al "" [: `S RO ")"; k :] :] :] - | _ -> [: curr x "" [: :]; `next y "" k :] ] - | e -> fun curr next dg k -> [: `next e dg k :] ]}; - {pr_label = "dot"; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:expr< $x$ . ( $y$ ) >> -> - fun curr next dg k -> - [: curr x "" [: :]; `S NO ".("; `expr y "" [: `S RO ")"; k :] :] - | <:expr< $x$ . [ $y$ ] >> -> - fun curr next dg k -> - [: curr x "" [: :]; `S NO ".["; `expr y "" [: `S RO "]"; k :] :] - | <:expr< $e$. val >> -> - fun curr next dg k -> [: `S LO "!"; `next e "" k :] - | <:expr< $e1$ . $e2$ >> -> - fun curr next dg k -> - [: curr e1 "" [: :]; `S NO "."; curr e2 "" k :] - | <:expr< $e$ # $lab$ >> -> - fun curr next dg k -> - [: curr e "" [: :]; `S NO "#"; `label lab; k :] - | e -> fun curr next dg k -> [: `next e "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:expr< [$_$ :: $_$] >> as e -> - fun curr next dg k -> - let (el, c) = - make_list e where rec make_list e = - match e with - [ <:expr< [$e$ :: $y$] >> -> - let (el, c) = make_list y in - ([e :: el], c) - | <:expr< [] >> -> ([], None) - | x -> ([], Some e) ] - in - match c with - [ None -> - [: `S LO "["; - listws expr (S RO ";") el "" [: `S RO "]"; k :] :] - | Some x -> [: `next e "" k :] ] - | e -> fun curr next dg k -> [: `next e dg k :] ]}; - {pr_label = "simple"; - pr_box e x = LocInfo (MLast.loc_of_expr e) (HOVbox x); - pr_rules = - extfun Extfun.empty with - [ ( <:expr< $int:x$ >> | <:expr< $flo:x$ >> ) - -> fun curr next dg k -> - if x.[0] = '-' then [: `S LO "("; `S LR x; `S RO ")"; k :] - else [: `S LR x; k :] - | MLast.ExInt32 _ x -> - fun curr next dg k -> - let x = x^"l" in - if x.[0] = '-' then [: `S LO "("; `S LR x; `S RO ")"; k :] - else [: `S LR x; k :] - | MLast.ExInt64 _ x -> - let x = x^"L" in - fun curr next dg k -> - if x.[0] = '-' then [: `S LO "("; `S LR x; `S RO ")"; k :] - else [: `S LR x; k :] - | MLast.ExNativeInt _ x -> - let x = x^"n" in - fun curr next dg k -> - if x.[0] = '-' then [: `S LO "("; `S LR x; `S RO ")"; k :] - else [: `S LR x; k :] - | <:expr< $str:s$ >> -> - fun curr next dg k -> [: `S LR ("\"" ^ s ^ "\""); k :] - | <:expr< $chr:c$ >> -> - fun curr next dg k -> - let c = ocaml_char c in - [: `S LR ("'" ^ c ^ "'"); k :] - | <:expr< $uid:s$ >> -> - fun curr next dg k -> [: `S LR (conv_con s); k :] - | <:expr< $lid:s$ >> -> - fun curr next dg k -> [: `S LR (var_escaped s); k :] - | <:expr< ` $i$ >> -> fun curr next dg k -> [: `S LR ("`" ^ i); k :] - | <:expr< ~ $i$ >> -> - fun curr next dg k -> [: `S LR ("~" ^ i); k :] - | <:expr< ~ $i$ : $e$ >> -> - fun curr next dg k -> [: `S LO ("~" ^ i ^ ":"); curr e "" k :] - | <:expr< ? $i$ >> -> - fun curr next dg k -> [: `S LR ("?" ^ i); k :] - | <:expr< ? $i$ : $e$ >> -> - fun curr next dg k -> [: `S LO ("?" ^ i ^ ":"); curr e "" k :] - | <:expr< [| $list:el$ |] >> -> - fun curr next dg k -> - [: `S LR "[|"; listws expr (S RO ";") el "" [: `S LR "|]"; k :] :] - | <:expr< { $list:fel$ } >> -> - fun curr next dg k -> - [: `S LO "{"; - listws - (fun (lab, e) dg k -> - HVbox [: `patt lab "" [: `S LR "=" :]; `expr1 e dg k :]) - (S RO ";") fel "" [: `S RO "}"; k :] :] - | <:expr< { ($e$) with $list:fel$ } >> -> - fun curr next dg k -> - [: `HVbox [: `S LO "{"; curr e "" [: `S LR "with" :] :]; - listws - (fun (lab, e) dg k -> - HVbox [: `patt lab "" [: `S LR "=" :]; `expr1 e dg k :]) - (S RO ";") fel "" [: `S RO "}"; k :] :] - | <:expr< ($e$ : $t$) >> -> - fun curr next dg k -> - [: `S LO "("; `expr e "" [: `S LR ":" :]; - `ctyp t "" [: `S RO ")"; k :] :] - | <:expr< ($e$ : $t1$ :> $t2$) >> -> - fun curr next dg k -> - [: `S LO "("; `expr e "" [: `S LR ":" :]; - `ctyp t1 "" [: `S LR ":>" :]; `ctyp t2 "" [: `S RO ")"; k :] :] - | <:expr< ($e$ :> $t2$) >> -> - fun curr next dg k -> - [: `S LO "("; `expr e "" [: `S LR ":>" :]; - `ctyp t2 "" [: `S RO ")"; k :] :] - | <:expr< new $list:sl$ >> -> - fun curr next dg k -> [: `S LR "new"; `class_longident sl "" k :] - | <:expr< {< >} >> -> fun curr next dg k -> [: `S LR "{< >}"; k :] - | <:expr< {< $list:fel$ >} >> -> - fun curr next dg k -> - [: `S LR "{<"; - listws field_expr (S RO ";") fel dg [: `S LR ">}"; k :] :] - | <:expr< do { $list:el$ } >> -> - fun curr next dg k -> - match el with - [ [e] -> curr e dg k - | _ -> - [: `BEbox - [: `S LR "begin"; - `HVbox - [: `HVbox [: :]; - listws expr1 (S RO ";") el "" [: :] :]; - `HVbox [: `S LR "end"; k :] :] :] ] - | <:expr< $_$ $_$ >> | <:expr< $_$ . $_$ >> | <:expr< $_$ . ( $_$ ) >> | - <:expr< $_$ . [ $_$ ] >> | <:expr< $_$ := $_$ >> | - <:expr< $_$ # $_$ >> | - <:expr< fun [ $list:_$ ] >> | <:expr< match $_$ with [ $list:_$ ] >> | - <:expr< try $_$ with [ $list:_$ ] >> | - <:expr< if $_$ then $_$ else $_$ >> | - <:expr< for $_$ = $_$ $to:_$ $_$ do { $list:_$ } >> | - <:expr< while $_$ do { $list:_$ } >> | <:expr< ($list: _$) >> | - <:expr< let $opt:_$ $list:_$ in $_$ >> | - <:expr< let module $_$ = $_$ in $_$ >> as e -> - fun curr next dg k -> - [: `S LO "("; `expr e "" [: `HVbox [: `S RO ")"; k :] :] :] - | e -> fun curr next _ k -> [: `not_impl "expr" e :] ]}]; - -pr_patt.pr_levels := - [{pr_label = "top"; pr_box p x = LocInfo (MLast.loc_of_patt p) (HOVCbox x); - pr_rules = - extfun Extfun.empty with - [ <:patt< ($x$ as $lid:y$) >> -> - fun curr next dg k -> - [: curr x "" [: :]; `S LR "as"; `S LR (var_escaped y); k :] - | <:patt< ($x$ as $y$) >> -> - fun curr next dg k -> - [: curr y "" [: :]; `S LR "as"; `next x "" k :] - | p -> fun curr next dg k -> [: `next p "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox [: `HVbox [: :]; x :]; - pr_rules = - extfun Extfun.empty with - [ <:patt< $x$ | $y$ >> -> - fun curr next dg k -> [: curr x "" [: `S LR "|" :]; `next y "" k :] - | p -> fun curr next dg k -> [: `next p "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVCbox [: `HVbox [: :]; x :]; - pr_rules = - extfun Extfun.empty with - [ <:patt< ($list:pl$) >> -> - fun curr next dg k -> - [: `HVbox [: :]; listws next (S RO ",") pl "" k :] - | p -> fun curr next dg k -> [: `next p "" k :] ]}; - {pr_label = "patt1"; pr_box _ x = HOVbox [: `HVbox [: :]; x :]; - pr_rules = - extfun Extfun.empty with - [ <:patt< $x$ .. $y$ >> -> - fun curr next dg k -> [: curr x "" [: `S NO ".." :]; `next y "" k :] - | p -> fun curr next dg k -> [: `next p "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVCbox x; - pr_rules = - extfun Extfun.empty with - [ <:patt< [$_$ :: $_$] >> as p -> - fun curr next dg k -> - let (pl, c) = - make_list p where rec make_list p = - match p with - [ <:patt< [$p$ :: $y$] >> -> - let (pl, c) = make_list y in - ([p :: pl], c) - | <:patt< [] >> -> ([], None) - | x -> ([], Some p) ] - in - match c with - [ None -> - [: `S LO "["; - listws patt (S RO ";") pl "" [: `S RO "]"; k :] :] - | Some x -> - [: `HVbox [: :]; listws next (S LR "::") (pl @ [x]) "" k :] ] - | p -> fun curr next dg k -> [: `next p "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:patt< [$_$ :: $_$] >> as p -> - fun curr next dg k -> [: `next p "" k :] - | <:patt< $x$ $y$ >> -> - fun curr next dg k -> - match get_patt_args x [y] with - [ (_, [_]) -> [: curr x "" [: :]; `next y "" k :] - | ((<:patt< $uid:_$ >> | <:patt< $_$ . $uid:_$ >> as a), al) -> - [: curr a "" [: :]; - `HOVbox - [: `S LO "("; - listws (fun x _ k -> HOVbox [: curr x "" k :]) - (S RO ",") al "" [: `S RO ")"; k :] :] :] - | _ -> [: curr x "" [: :]; `next y "" k :] ] - | p -> fun curr next dg k -> [: `next p "" k :] ]}; - {pr_label = "simple"; - pr_box p x = LocInfo (MLast.loc_of_patt p) (HOVbox x); - pr_rules = - extfun Extfun.empty with - [ <:patt< $x$ . $y$ >> -> - fun curr next dg k -> [: curr x "" [: :]; `S NO "."; - `simple_patt y "" k :] - | <:patt< [| $list:pl$ |] >> -> - fun curr next dg k -> - [: `S LR "[|"; listws patt (S RO ";") pl "" [: `S LR "|]"; k :] :] - | <:patt< { $list:fpl$ } >> -> - fun curr next dg k -> - [: `HVbox - [: `S LO "{"; - listws - (fun (lab, p) _ k -> - HVbox - [: `patt lab "" [: `S LR "=" :]; `patt p "" k :]) - (S RO ";") fpl "" [: `S RO "}"; k :] :] :] - | <:patt< [$_$ :: $_$] >> as p -> - fun curr next dg k -> - let (pl, c) = - make_list p where rec make_list p = - match p with - [ <:patt< [$p$ :: $y$] >> -> - let (pl, c) = make_list y in - ([p :: pl], c) - | <:patt< [] >> -> ([], None) - | x -> ([], Some p) ] - in - match c with - [ None -> - [: `S LO "["; - listws patt (S RO ";") pl "" [: `S RO "]"; k :] :] - | Some x -> - [: `S LO "("; `patt p "" [: `HVbox [: `S RO ")"; k :] :] :] ] - | <:patt< ($p$ : $ct$) >> -> - fun curr next dg k -> - [: `S LO "("; `patt p "" [: `S LR ":" :]; - `ctyp ct "" [: `S RO ")"; k :] :] - | ( <:patt< $int:s$ >> | <:patt< $flo:s$ >> ) - -> fun curr next dg k -> [: `S LR s; k :] - | MLast.PaInt32 _ s - -> fun curr next dg k -> [: `S LR (s^"l"); k :] - | MLast.PaInt64 _ s - -> fun curr next dg k -> [: `S LR (s^"L"); k :] - | MLast.PaNativeInt _ s - -> fun curr next dg k -> [: `S LR (s^"n"); k :] - | <:patt< $str:s$ >> -> - fun curr next dg k -> [: `S LR ("\"" ^ s ^ "\""); k :] - | <:patt< $chr:c$ >> -> - fun curr next dg k -> - let c = ocaml_char c in - [: `S LR ("'" ^ c ^ "'"); k :] - | <:patt< $lid:i$ >> -> fun curr next dg k -> [: `id_var i; k :] - | <:patt< $uid:i$ >> -> - fun curr next dg k -> [: `S LR (conv_con i); k :] - | <:patt< ` $i$ >> -> fun curr next dg k -> [: `S LR ("`" ^ i); k :] - | <:patt< # $list:sl$ >> -> - fun curr next dg k -> [: `S LO "#"; mod_ident sl dg k :] - | <:patt< ~ $i$ >> -> - fun curr next dg k -> [: `S LR ("~" ^ i); k :] - | <:patt< ~ $i$ : $p$ >> -> - fun curr next dg k -> - [: `S LO ("~" ^ i ^ ":"); `simple_patt p "" k :] - | <:patt< ? $i$ >> -> - fun curr next _ k -> [: `S LR ("?" ^ i); k :] - | <:patt< ? $i$ : ($p$) >> -> - fun curr next dg k -> - if i = "" then [: `S LO "?"; `simple_patt p "" k :] - else [: `S LO ("?" ^ i ^ ":"); `simple_patt p "" k :] - | <:patt< ? $i$ : ($p$ = $e$) >> -> - fun curr next dg k -> - if i = "" then - [: `S LO "?"; `S LO "("; `patt p "" [: `S LR "=" :]; - `expr e "" [: `S RO ")"; k :] :] - else - [: `S LO ("?" ^ i ^ ":"); `S LO "("; `patt p "" [: `S LR "=" :]; - `expr e "" [: `S RO ")"; k :] :] - | <:patt< ? $i$ : ($p$ : $t$ = $e$) >> -> - fun curr next dg k -> - if i = "" then - [: `S LO "?"; `S LO "("; `patt p "" [: `S LR "=" :]; - `expr e "" [: `S RO ")"; k :] :] - else - [: `S LO ("?" ^ i ^ ":"); `S LO "("; `patt p "" [: `S LR "=" :]; - `expr e "" [: `S RO ")"; k :] :] - | <:patt< _ >> -> fun curr next dg k -> [: `S LR "_"; k :] - | <:patt< $_$ $_$ >> | <:patt< ($_$ as $_$) >> | <:patt< $_$ | $_$ >> | - <:patt< ($list:_$) >> | <:patt< $_$ .. $_$ >> as p -> - fun curr next dg k -> - [: `S LO "("; `patt p "" [: `HVbox [: `S RO ")"; k :] :] :] - | p -> fun curr next dg k -> [: `next p "" k :] ]}]; - -pr_ctyp.pr_levels := - [{pr_label = "top"; pr_box t x = LocInfo (MLast.loc_of_ctyp t) (HOVbox x); - pr_rules = - extfun Extfun.empty with - [ <:ctyp< $x$ as $y$ >> -> - fun curr next dg k -> [: curr x "" [: `S LR "as" :]; `next y "" k :] - | t -> fun curr next dg k -> [: `next t "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:ctyp< $x$ -> $y$ >> -> - fun curr next dg k -> [: `next x "" [: `S LR "->" :]; curr y "" k :] - | t -> fun curr next dg k -> [: `next t "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:ctyp< ? $lab$ : $t$ >> -> - fun curr next dg k -> - [: `S LO "?"; `S LR lab; `S RO ":"; `next t "" k :] - | t -> fun curr next dg k -> [: `next t "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:ctyp< ($list:tl$) >> -> - fun curr next dg k -> listws next (S LR "*") tl "" k - | t -> fun curr next dg k -> [: `next t "" k :] ]}; - {pr_label = "simple"; - pr_box t x = LocInfo (MLast.loc_of_ctyp t) (HOVbox x); - pr_rules = - extfun Extfun.empty with - [ <:ctyp< $t1$ == $t2$ >> -> - fun curr next dg k -> - [: curr t1 "=" [: `S LR "=" :]; `next t2 "" k :] - | t -> fun curr next dg k -> [: `next t "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:ctyp< ? $lab$ : $t$ >> -> - fun curr next dg k -> - [: `S LO "?"; `S LR lab; `S RO ":"; `next t "" k :] - | <:ctyp< ~ $lab$ : $t$ >> -> - fun curr next dg k -> [: `S LO (lab ^ ":"); `next t "" k :] - | t -> fun curr next dg k -> [: `next t "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:ctyp< $t1$ $t2$ >> -> - fun curr next dg k -> - let (t, tl) = get_type_args t1 [t2] in - match tl with - [ [<:ctyp< $_$ $_$ >>] -> [: curr t2 "" [: :]; curr t1 "" k :] - | [_] -> [: `next t2 "" [: :]; curr t1 "" k :] - | _ -> - [: `S LO "("; - listws (fun x _ k -> HOVbox [: curr x "" k :]) (S RO ",") - tl "" [: `S RO ")" :]; - curr t "" k :] ] - | t -> fun curr next dg k -> [: `next t "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:ctyp< $t1$ . $t2$ >> -> - fun curr next dg k -> - [: `module_pref t1 "" [: `S NO "." :]; `next t2 "" k :] - | t -> fun curr next dg k -> [: `next t "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:ctyp< '$s$ >> -> - fun curr next dg k -> [: `S LO "'"; `S LR (var_escaped s); k :] - | <:ctyp< $lid:s$ >> -> - fun curr next dg k -> [: `S LR (var_escaped s); k :] - | <:ctyp< $uid:s$ >> -> fun curr next dg k -> [: `S LR s; k :] - | <:ctyp< _ >> -> fun curr next dg k -> [: `S LR "_"; k :] - | <:ctyp< private { $list:ftl$ } >> as t -> - fun curr next dg k -> - let loc = MLast.loc_of_ctyp t in - [: `HVbox - [: `HVbox [:`S LR "private" :]; - `HVbox [: labels loc [:`S LR "{" :] - ftl "" [: `S LR "}" :] :]; - k :] :] - | <:ctyp< { $list:ftl$ } >> as t -> - fun curr next dg k -> - let loc = MLast.loc_of_ctyp t in - [: `HVbox - [: labels loc [: `S LR "{" :] ftl "" [: `S LR "}" :]; - k :] :] - | <:ctyp< private [ $list:ctl$ ] >> as t -> - fun curr next dg k -> - let loc = MLast.loc_of_ctyp t in - [: `Vbox - [: `HVbox [: `S LR "private" :]; - variants loc [: `S LR " " :] ctl "" [: :]; - k :] :] - | <:ctyp< [ $list:ctl$ ] >> as t -> - fun curr next dg k -> - let loc = MLast.loc_of_ctyp t in - [: `Vbox - [: `HVbox [: :]; variants loc [: `S LR " " :] ctl "" [: :]; - k :] :] - | <:ctyp< [ = $list:rfl$ ] >> -> - fun curr next dg k -> - [: `HVbox - [: `HVbox [: :]; - row_fields [: `S LR "[" :] rfl "" [: `S LR "]" :]; - k :] :] - | <:ctyp< [ > $list:rfl$ ] >> -> - fun curr next dg k -> - [: `HVbox - [: `HVbox [: :]; - row_fields [: `S LR "[>" :] rfl "" [: `S LR "]" :]; - k :] :] - | <:ctyp< [ < $list:rfl$ > $list:sl$ ] >> -> - fun curr next dg k -> - let k1 = [: `S LR "]" :] in - let k1 = - match sl with - [ [] -> k1 - | l -> - [: `S LR ">"; - list (fun x _ k -> HVbox [: `S LR x; k :]) l "" k1 :] ] - in - [: `HVbox - [: `HVbox [: :]; row_fields [: `S LR "[<" :] rfl "" k1; - k :] :] - | MLast.TyCls _ id -> - fun curr next dg k -> [: `S LO "#"; `class_longident id "" k :] - | MLast.TyObj _ [] False -> fun curr next dg k -> [: `S LR "<>"; k :] - | MLast.TyObj _ ml v -> - fun curr next dg k -> - [: `S LR "<"; meth_list (ml, v) "" [: `S LR ">"; k :] :] - | MLast.TyPol _ pl t -> - fun curr next dg k -> - if pl = [] then [: `ctyp t "" k :] - else [: list typevar pl "" [: `S LR "." :]; `ctyp t "" k :] - | <:ctyp< $_$ -> $_$ >> | <:ctyp< $_$ $_$ >> | <:ctyp< $_$ == $_$ >> | - <:ctyp< $_$ . $_$ >> | <:ctyp< ($list:_$) >> | <:ctyp< $_$ as $_$ >> | - <:ctyp< ~ $_$ : $_$ >> | <:ctyp< ? $_$ : $_$ >> as t -> - fun curr next dg k -> - [: `S LO "("; `ctyp t "" [: `HVbox [: `S RO ")"; k :] :] :] - | t -> fun curr next dg k -> [: `next t "" k :] ]}]; - -pr_class_str_item.pr_levels := - [{pr_label = "top"; - pr_box s x = LocInfo (MLast.loc_of_class_str_item s) (HVbox x); - pr_rules = - extfun Extfun.empty with - [ MLast.CrDcl _ s -> - fun curr next dg k -> [: `HVbox [: :]; list class_str_item s "" k :] - | MLast.CrInh _ ce pb -> - fun curr next dg k -> - [: `S LR "inherit"; `class_expr ce [: :]; - match pb with - [ Some i -> [: `S LR "as"; `S LR i :] - | _ -> [: :] ]; - k :] - | MLast.CrVal _ lab mf e -> - fun curr next dg k -> [: `cvalue [: `S LR "val" :] (lab, mf, e) k :] - | MLast.CrVir _ lab pf t -> - fun curr next dg k -> - [: `S LR "method"; `S LR "virtual"; private_flag pf; `label lab; - `S LR ":"; `ctyp t "" k :] - | MLast.CrMth _ lab pf fb None -> - fun curr next dg k -> - [: `fun_binding [: `S LR "method"; private_flag pf; `label lab :] - fb k :] - | MLast.CrMth _ lab pf fb (Some t) -> - fun curr next dg k -> - [: `HOVbox - [: `S LR "method"; private_flag pf; `label lab; `S LR ":"; - `ctyp t "" [: `S LR "=" :] :]; - `expr fb "" k :] - | MLast.CrCtr _ t1 t2 -> - fun curr next dg k -> - [: `HVbox [: `S LR "constraint"; `ctyp t1 "" [: `S LR "=" :] :]; - `ctyp t2 "" k :] - | MLast.CrIni _ se -> - fun curr next dg k -> [: `S LR "initializer"; `expr se "" k :] - | csi -> fun curr next dg k -> [: `next csi "" k :] ]}]; - -pr_class_sig_item.pr_levels := - [{pr_label = "top"; - pr_box s x = LocInfo (MLast.loc_of_class_sig_item s) (HVbox x); - pr_rules = - extfun Extfun.empty with - [ MLast.CgCtr _ t1 t2 -> - fun curr next dg k -> - [: `S LR "constraint"; `ctyp t1 "" [: `S LR "=" :]; - `ctyp t2 "" k :] - | MLast.CgDcl _ s -> - fun curr next dg k -> - [: `HVbox [: :]; list class_sig_item s "" [: :] :] - | MLast.CgInh _ ce -> - fun curr next dg k -> [: `S LR "inherit"; `class_type ce k :] - | MLast.CgMth _ lab pf t -> - fun curr next dg k -> - [: `HVbox - [: `S LR "method"; private_flag pf; `label lab; - `S LR ":" :]; - `ctyp t "" k :] - | MLast.CgVal _ lab mf t -> - fun curr next dg k -> - [: `HVbox - [: `S LR "val"; mutable_flag mf; `label lab; `S LR ":" :]; - `ctyp t "" k :] - | MLast.CgVir _ lab pf t -> - fun curr next dg k -> - [: `HVbox - [: `S LR "method"; `S LR "virtual"; private_flag pf; - `label lab; `S LR ":" :]; - `ctyp t "" k :] - | csi -> fun curr next dg k -> [: `next csi "" k :] ]}]; - -pr_class_type.pr_levels := - [{pr_label = "top"; pr_box s x = HVbox x; - pr_rules = - extfun Extfun.empty with - [ MLast.CtFun _ t ct -> - fun curr next dg k -> - [: `ctyp t "" [: `S LR "->" :]; curr ct "" k :] - | ct -> fun curr next dg k -> [: `class_signature ct k :] ]}]; - -pr_class_expr.pr_levels := - [{pr_label = "top"; pr_box s x = HVbox x; - pr_rules = - extfun Extfun.empty with - [ MLast.CeFun _ p ce -> - fun curr next dg k -> - [: `S LR "fun"; `simple_patt p "" [: `S LR "->" :]; - `class_expr ce k :] - | MLast.CeLet _ rf lb ce -> - fun curr next dg k -> - [: `Vbox - [: `HVbox [: :]; - `bind_list [: `S LR "let"; rec_flag rf :] lb "" - [: `S LR "in" :]; - `class_expr ce k :] :] - | x -> fun curr next dg k -> [: `next x "" k :] ]}; - {pr_label = ""; pr_box s x = HVbox x; - pr_rules = - extfun Extfun.empty with - [ MLast.CeApp _ ce e -> - fun curr next dg k -> [: curr ce "" [: :]; `simple_expr e "" k :] - | x -> fun curr next dg k -> [: `next x "" k :] ]}; - {pr_label = ""; pr_box s x = HVbox x; - pr_rules = - extfun Extfun.empty with - [ MLast.CeCon _ ci [] -> - fun curr next dg k -> [: `class_longident ci "" k :] - | MLast.CeCon _ ci ctcl -> - fun curr next dg k -> - [: `S LO "["; listws ctyp (S RO ",") ctcl "" [: `S RO "]" :]; - `class_longident ci "" k :] - | MLast.CeStr _ csp cf as ce -> - let ep = snd (MLast.loc_of_class_expr ce) in - fun curr next dg k -> - [: `BEbox - [: `HVbox [: `S LR "object"; `class_self_patt_opt csp :]; - `HVbox - [: `HVbox [: :]; list class_str_item cf "" [: :]; - `LocInfo (ep, ep) (HVbox [: :]) :]; - `HVbox [: `S LR "end"; k :] :] :] - | MLast.CeTyc _ ce ct -> - fun curr next dg k -> - [: `S LO "("; `class_expr ce [: `S LR ":" :]; - `class_type ct [: `S RO ")"; k :] :] - | MLast.CeFun _ _ _ as ce -> - fun curr next dg k -> - [: `S LO "("; `class_expr ce [: `S RO ")"; k :] :] - | ce -> fun curr next dg k -> [: `not_impl "class_expr" ce; k :] ]}]; - -value output_string_eval oc s = - loop 0 where rec loop i = - if i == String.length s then () - else if i == String.length s - 1 then output_char oc s.[i] - else - match (s.[i], s.[i + 1]) with - [ ('\\', 'n') -> do { output_char oc '\n'; loop (i + 2) } - | (c, _) -> do { output_char oc c; loop (i + 1) } ] -; - -value maxl = ref 78; -value sep = Pcaml.inter_phrases; -value ncip = ref True; - -value input_source ic len = - let buff = Buffer.create 20 in - try - let rec loop i = - if i >= len then Buffer.contents buff - else do { let c = input_char ic in Buffer.add_char buff c; loop (i + 1) } - in - loop 0 - with - [ End_of_file -> - let s = Buffer.contents buff in - if s = "" then - match sep.val with - [ Some s -> s - | None -> "\n" ] - else s ] -; - -value copy_source ic oc first bp ep = - match sep.val with - [ Some str -> - if first then () - else if ep == in_channel_length ic then output_string oc "\n" - else output_string_eval oc str - | None -> - do { - seek_in ic bp; let s = input_source ic (ep - bp) in output_string oc s - } ] -; - -value copy_to_end ic oc first bp = - let ilen = in_channel_length ic in - if bp < ilen then copy_source ic oc first bp ilen else output_string oc "\n" -; - -module Buff = - struct - value buff = ref (String.create 80); - value store len x = - do { - if len >= String.length buff.val then - buff.val := buff.val ^ String.create (String.length buff.val) - else (); - buff.val.[len] := x; - succ len - } - ; - value mstore len s = - add_rec len 0 where rec add_rec len i = - if i == String.length s then len - else add_rec (store len s.[i]) (succ i) - ; - value get len = String.sub buff.val 0 len; - end -; - -value extract_comment strm = - let rec find_comm nl_bef tab_bef = - parser - [ [: `'('; a = find_star nl_bef tab_bef :] -> a - | [: `' '; s :] -> find_comm nl_bef (tab_bef + 1) s - | [: `'\t'; s :] -> find_comm nl_bef (tab_bef + 8) s - | [: `'\n'; s :] -> find_comm (nl_bef + 1) 0 s - | [: `_; s :] -> find_comm 0 0 s - | [: :] -> ("", nl_bef, tab_bef) ] - and find_star nl_bef tab_bef = - parser - [ [: `'*'; a = insert (Buff.mstore 0 "(*") :] -> (a, nl_bef, tab_bef) - | [: a = find_comm 0 0 :] -> a ] - and insert len = - parser - [ [: `'*'; a = rparen (Buff.store len '*') :] -> a - | [: `'('; len = find_star2 (Buff.store len '('); s :] -> insert len s - | [: `'\t'; s :] -> insert (Buff.mstore len (String.make 8 ' ')) s - | [: `x; s :] -> insert (Buff.store len x) s - | [: :] -> "" ] - and rparen len = - parser - [ [: `')'; s :] -> while_space (Buff.store len ')') s - | [: a = insert len :] -> a ] - and while_space len = - parser - [ [: `' '; a = while_space (Buff.store len ' ') :] -> a - | [: `'\t'; a = while_space (Buff.mstore len (String.make 8 ' ')) :] -> a - | [: `'\n'; a = while_space (Buff.store len '\n') :] -> a - | [: `'('; a = find_star_again len :] -> a - | [: :] -> Buff.get len ] - and find_star_again len = - parser - [ [: `'*'; a = insert (Buff.mstore len "(*") :] -> a - | [: :] -> Buff.get len ] - and find_star2 len = - parser - [ [: `'*'; a = insert2 (Buff.store len '*') :] -> a - | [: :] -> len ] - and insert2 len = - parser - [ [: `'*'; a = rparen2 (Buff.store len '*') :] -> a - | [: `'('; len = find_star2 (Buff.store len '('); s :] -> insert2 len s - | [: `x; s :] -> insert2 (Buff.store len x) s - | [: :] -> 0 ] - and rparen2 len = - parser - [ [: `')' :] -> Buff.store len ')' - | [: a = insert2 len :] -> a ] - in - find_comm 0 0 strm -; - -value get_no_comment _ _ = ("", 0, 0, 0); - -value get_comment ic beg len = - do { - seek_in ic beg; - let strm = - Stream.from (fun i -> if i >= len then None else Some (input_char ic)) - in - let (s, nl_bef, tab_bef) = extract_comment strm in - (s, nl_bef, tab_bef, Stream.count strm) - } -; - -value apply_printer printer ast = - let oc = - match Pcaml.output_file.val with - [ Some f -> open_out_bin f - | None -> stdout ] - in - let cleanup () = - match Pcaml.output_file.val with - [ Some _ -> close_out oc - | None -> () ] - in - let pr_ch = output_char oc in - let pr_str = output_string oc in - let pr_nl () = output_char oc '\n' in - if Pcaml.input_file.val <> "-" && Pcaml.input_file.val <> "" then do { - let ic = open_in_bin Pcaml.input_file.val in - let getcom = - if not ncip.val && sep.val = None then get_comment ic - else get_no_comment - in - try - let (first, last_pos) = - List.fold_left - (fun (first, last_pos) (si, (bp, ep)) -> - do { - copy_source ic oc first last_pos bp; - flush oc; - print_pretty pr_ch pr_str pr_nl "" "" maxl.val getcom bp - (printer si "" [: :]); - flush oc; - (False, ep) - }) - (True, 0) ast - in - do { copy_to_end ic oc first last_pos; flush oc } - with x -> - do { close_in ic; cleanup (); raise x }; - close_in ic; - cleanup () - } - else do { - List.iter - (fun (si, _) -> - do { - print_pretty pr_ch pr_str pr_nl "" "" maxl.val get_no_comment 0 - (printer si "" [: :]); - match sep.val with - [ Some str -> output_string_eval oc str - | None -> output_char oc '\n' ]; - flush oc - }) - ast; - cleanup () - } -; - -Pcaml.print_interf.val := apply_printer sig_item; -Pcaml.print_implem.val := apply_printer str_item; - -Pcaml.add_option "-l" (Arg.Int (fun x -> maxl.val := x)) - " line length for pretty printing."; - -Pcaml.add_option "-ss" (Arg.Clear no_ss) "Print double semicolons."; - -Pcaml.add_option "-no_ss" (Arg.Set no_ss) - "Do not print double semicolons (default)."; - -Pcaml.add_option "-sep_src" (Arg.Unit (fun () -> sep.val := None)) - "Read source file for text between phrases (default)."; - -Pcaml.add_option "-sep" (Arg.String (fun x -> sep.val := Some x)) - " Use this string between phrases instead of reading source."; - -Pcaml.add_option "-cip" (Arg.Clear ncip) "Add comments in phrases."; - -Pcaml.add_option "-ncip" (Arg.Set ncip) "No comments in phrases (default)."; - -Pcaml.add_option "-tc" (Arg.Clear ncip) - "Deprecated since version 3.05; equivalent to -cip."; diff --git a/camlp4/etc/pr_op.ml b/camlp4/etc/pr_op.ml deleted file mode 100644 index 983a3a3cd7..0000000000 --- a/camlp4/etc/pr_op.ml +++ /dev/null @@ -1,503 +0,0 @@ -(* camlp4r q_MLast.cmo ./pa_extfun.cmo *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1998 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -open Pcaml; -open Spretty; - -value loc = (0, 0); - -value expr e dg k = pr_expr.pr_fun "top" e dg k; -value patt e dg k = pr_patt.pr_fun "top" e dg k; - -value spatt p dg k = - match p with - [ <:patt< $lid:s$ >> -> - if String.length s >= 2 && s.[1] == ''' then - HVbox [: `S LR (" " ^ s); k :] - else patt p dg k - | _ -> patt p dg k ] -; - -(* Streams *) - -value stream e _ k = - let rec get = - fun - [ <:expr< Stream.iapp $x$ $y$ >> -> [(False, x) :: get y] - | <:expr< Stream.icons $x$ $y$ >> -> [(True, x) :: get y] - | <:expr< Stream.ising $x$ >> -> [(True, x)] - | <:expr< Stream.lapp (fun _ -> $x$) $y$ >> -> [(False, x) :: get y] - | <:expr< Stream.lcons (fun _ -> $x$) $y$ >> -> [(True, x) :: get y] - | <:expr< Stream.lsing (fun _ -> $x$) >> -> [(True, x)] - | <:expr< Stream.sempty >> -> [] - | <:expr< Stream.slazy (fun _ -> $x$) >> -> [(False, x)] - | <:expr< Stream.slazy $x$ >> -> [(False, <:expr< $x$ () >>)] - | e -> [(False, e)] ] - in - let elem e dg k = - match e with - [ (True, e) -> [: `HOVbox [: `S LO "'"; `expr e dg k :] :] - | (False, e) -> [: `expr e dg k :] ] - in - let rec glop e k = - match e with - [ [] -> k - | [e] -> [: elem e "" k :] - | [e :: el] -> [: elem e ";" [: `S RO ";" :]; glop el k :] ] - in - HOVbox [: `S LR "[<"; glop (get e) [: `S LR ">]"; k :] :] -; - -(* Parsers *) - -type spc = - [ SPCterm of (MLast.patt * option MLast.expr) - | SPCnterm of MLast.patt and MLast.expr - | SPCsterm of MLast.patt ] -; - -exception NotImpl; - -value rec subst v e = - match e with - [ <:expr< $lid:x$ >> -> if x = "strm__" then <:expr< $lid:v$ >> else e - | <:expr< $uid:_$ >> -> e - | <:expr< $int:_$ >> -> e - | <:expr< $chr:_$ >> -> e - | <:expr< $str:_$ >> -> e - | <:expr< $e1$ . $lab$ >> -> <:expr< $subst v e1$ . $lab$ >> - | <:expr< $x$ $y$ >> -> <:expr< $subst v x$ $subst v y$ >> - | <:expr< let $lid:s1$ = $e1$ in $e2$ >> -> - if s1 = v then <:expr< let $lid:s1$ = $subst v e1$ in $e2$ >> - else <:expr< let $lid:s1$ = $subst v e1$ in $subst v e2$ >> - | <:expr< let _ = $e1$ in $e2$ >> -> - <:expr< let _ = $subst v e1$ in $subst v e2$ >> - | <:expr< ($list:el$) >> -> <:expr< ($list:List.map (subst v) el$) >> - | _ -> raise NotImpl ] -; - -value rec is_free v = - fun - [ <:expr< $lid:x$ >> -> x <> v - | <:expr< $uid:_$ >> -> True - | <:expr< $int:_$ >> -> True - | <:expr< $chr:_$ >> -> True - | <:expr< $str:_$ >> -> True - | <:expr< $e$ . $_$ >> -> is_free v e - | <:expr< $x$ $y$ >> -> is_free v x && is_free v y - | <:expr< let $lid:s1$ = $e1$ in $e2$ >> -> - is_free v e1 && (s1 = v || is_free v e2) - | <:expr< let _ = $e1$ in $e2$ >> -> is_free v e1 && is_free v e2 - | <:expr< ($list:el$) >> -> List.for_all (is_free v) el - | _ -> raise NotImpl ] -; - -value free_var_in_expr c e = - let rec loop_alpha v = - let x = String.make 1 v in - if is_free x e then Some x - else if v = 'z' then None - else loop_alpha (Char.chr (Char.code v + 1)) - in - let rec loop_count cnt = - let x = String.make 1 c ^ string_of_int cnt in - if is_free x e then x else loop_count (succ cnt) - in - try - match loop_alpha c with - [ Some v -> v - | None -> loop_count 1 ] - with - [ NotImpl -> "\\%a" ] -; - -value parserify = - fun - [ <:expr< $e$ strm__ >> -> e - | e -> <:expr< fun strm__ -> $e$ >> ] -; - -value is_raise_failure = - fun - [ <:expr< raise Stream.Failure >> -> True - | _ -> False ] -; - -value is_raise_error = - fun - [ <:expr< raise (Stream.Error $_$) >> -> True - | _ -> False ] -; - -value semantic e = - try - if is_free "strm__" e then e - else - let v = free_var_in_expr 's' e in - <:expr< let $lid:v$ = strm__ in $subst v e$ >> - with - [ NotImpl -> e ] -; - -value rewrite_parser = - rewrite True where rec rewrite top ge = - match ge with - [ <:expr< let $p$ = try $e$ with [ Stream.Failure -> raise $exc$ ] in - $sp_kont$ >> -> - let f = parserify e in - <:expr< - match try Some ($f$ strm__) with [ Stream.Failure -> None ] with - [ Some $p$ -> $rewrite False sp_kont$ - | _ -> raise $exc$ ] - >> - | <:expr< let $p$ = Stream.count strm__ in $f$ >> -> - try - if is_free "strm__" f then ge - else - let v = free_var_in_expr 's' f in - <:expr< - let $lid:v$ = strm__ in - let $p$ = Stream.count strm__ in $subst v f$ - >> - with - [ NotImpl -> ge ] - | <:expr< let $p$ = strm__ in $e$ >> -> - <:expr< let $p$ = strm__ in $rewrite False e$ >> - | <:expr< let $p$ = $f$ strm__ in $sp_kont$ >> when top -> - <:expr< - match try Some ($f$ strm__) with [ Stream.Failure -> None ] with - [ Some $p$ -> $rewrite False sp_kont$ - | _ -> raise Stream.Failure ] - >> - | <:expr< let $p$ = $e$ in $sp_kont$ >> -> - if match e with - [ <:expr< match try Some $_$ with [ Stream.Failure -> None ] with - [ $list:_$ ] >> - | <:expr< match Stream.peek strm__ with [ $list:_$ ] >> - | <:expr< try $_$ with [ Stream.Failure -> $_$ ] >> - | <:expr< let $_$ = Stream.count strm__ in $_$ >> -> True - | _ -> False ] - then - let f = rewrite True <:expr< fun strm__ -> $e$ >> in - let exc = - if top then <:expr< Stream.Failure >> - else <:expr< Stream.Error "" >> - in - <:expr< - match try Some ($f$ strm__) with [ Stream.Failure -> None ] with - [ Some $p$ -> $rewrite False sp_kont$ - | _ -> raise $exc$ ] - >> - else semantic ge - | <:expr< match try Some $e$ with [ Stream.Failure -> None ] with - [ Some $p$ -> $sp_kont$ - | _ -> $p_kont$ ] >> -> - let f = parserify e in - if not top && is_raise_failure p_kont then semantic ge - else - let (p, f, sp_kont, p_kont) = - if top || is_raise_error p_kont then - (p, f, rewrite False sp_kont, rewrite top p_kont) - else - let f = - <:expr< - fun strm__ -> - match - try Some ($f$ strm__) with [ Stream.Failure -> None ] - with - [ Some $p$ -> $rewrite False sp_kont$ - | _ -> $rewrite top p_kont$ ] - >> - in - (<:patt< a >>, f, <:expr< a >>, - <:expr< raise (Stream.Error "") >>) - in - <:expr< - match try Some ($f$ strm__) with [ Stream.Failure -> None ] with - [ Some $p$ -> $sp_kont$ - | _ -> $p_kont$ ] - >> - | <:expr< match Stream.peek strm__ with [ $list:pel$ ] >> -> - let rec iter pel = - match pel with - [ [(<:patt< Some $p$ >>, eo, - <:expr< do { Stream.junk strm__; $sp_kont$ } >>); - (<:patt< _ >>, None, p_kont) :: _] -> - <:expr< - match Stream.peek strm__ with - [ Some $p$ $when:eo$ -> - do { Stream.junk strm__; $rewrite False sp_kont$ } - | _ -> $rewrite top p_kont$ ] - >> - | [(<:patt< Some $p$ >>, eo, - <:expr< do { Stream.junk strm__; $sp_kont$ } >>) :: pel] -> - let p_kont = iter pel in - <:expr< - match Stream.peek strm__ with - [ Some $p$ $when:eo$ -> - do { Stream.junk strm__; $rewrite False sp_kont$ } - | _ -> $p_kont$ ] - >> - | _ -> - <:expr< match Stream.peek strm__ with [ $list:pel$ ] >> ] - in - iter pel - | <:expr< try Some $e$ with [ Stream.Failure -> $p_kont$ ] >> -> - let f = parserify e in - let e = - <:expr< - match try Some ($f$ strm__) with [ Stream.Failure -> None ] with - [ Some a -> Some a - | _ -> $p_kont$ ] - >> - in - rewrite top e - | <:expr< try $e$ with [ Stream.Failure -> $p_kont$ ] >> -> - let f = parserify e in - let e = - <:expr< - match try Some ($f$ strm__) with [ Stream.Failure -> None ] with - [ Some a -> a - | _ -> $rewrite top p_kont$ ] - >> - in - rewrite top e - | <:expr< $f$ strm__ >> -> - if top then - <:expr< - match try Some ($f$ strm__) with [ Stream.Failure -> None ] with - [ Some a -> a - | _ -> raise Stream.Failure ] - >> - else - let v = free_var_in_expr 's' f in - <:expr< let $lid:v$ = strm__ in $f$ $lid:v$ >> - | e -> semantic e ] -; - -value parser_of_expr = - let rec parser_cases e = - match e with - [ <:expr< - match try Some ($f$ strm__) with [ Stream.Failure -> None ] with - [ Some $p$ -> $sp_kont$ - | _ -> $p_kont$ ] - >> -> - let spc = (SPCnterm p f, None) in - let (sp, epo, e) = kont sp_kont in - [([spc :: sp], epo, e) :: parser_cases p_kont] - | <:expr< - match Stream.peek strm__ with - [ Some $p$ $when:wo$ -> do { Stream.junk strm__; $sp_kont$ } - | _ -> $p_kont$ ] - >> -> - let spc = (SPCterm (p, wo), None) in - let (sp, epo, e) = kont sp_kont in - [([spc :: sp], epo, e) :: parser_cases p_kont] - | <:expr< let $p$ = strm__ in $sp_kont$ >> -> - let spc = (SPCsterm p, None) in - let (sp, epo, e) = kont sp_kont in - [([spc :: sp], epo, e)] - | <:expr< let $p$ = Stream.count strm__ in $e$ >> -> [([], Some p, e)] - | <:expr< raise Stream.Failure >> -> [] - | _ -> [([], None, e)] ] - and kont e = - match e with - [ <:expr< - match try Some ($f$ strm__) with [ Stream.Failure -> None ] with - [ Some $p$ -> $sp_kont$ - | _ -> raise (Stream.Error $err$) ] - >> -> - let err = - match err with - [ <:expr< "" >> -> None - | _ -> Some err ] - in - let spc = (SPCnterm p f, err) in - let (sp, epo, e) = kont sp_kont in - ([spc :: sp], epo, e) - | <:expr< - match Stream.peek strm__ with - [ Some $p$ $when:wo$ -> do { Stream.junk strm__; $sp_kont$ } - | _ -> raise (Stream.Error $err$) ] - >> -> - let err = - match err with - [ <:expr< "" >> -> None - | _ -> Some err ] - in - let spc = (SPCterm (p, wo), err) in - let (sp, epo, e) = kont sp_kont in - ([spc :: sp], epo, e) - | <:expr< let $p$ = strm__ in $sp_kont$ >> -> - let spc = (SPCsterm p, None) in - let (sp, epo, e) = kont sp_kont in - ([spc :: sp], epo, e) - | <:expr< let $p$ = Stream.count strm__ in $e$ >> -> ([], Some p, e) - | _ -> ([], None, e) ] - in - parser_cases -; - -value parser_cases b spel dg k = - let rec parser_cases b spel dg k = - match spel with - [ [] -> [: `HVbox [: b; k :] :] - | [(sp, epo, e)] -> [: `parser_case b sp epo e dg k :] - | [(sp, epo, e) :: spel] -> - [: `parser_case b sp epo e "|" [: :]; - parser_cases [: `S LR "|" :] spel dg k :] ] - and parser_case b sp epo e dg k = - let epo = - match epo with - [ Some p -> [: `patt p "" [: `S LR "->" :] :] - | _ -> [: `S LR "->" :] ] - in - HVbox - [: b; - `HOVbox - [: `HOVbox - [: `S LR "[<"; - stream_patt [: :] sp [: `S LR ">]"; epo :] :]; - `expr e dg k :] :] - and stream_patt b sp k = - match sp with - [ [] -> [: `HVbox [: b; k :] :] - | [(spc, None)] -> [: `stream_patt_comp b spc "" k :] - | [(spc, Some e)] -> - [: `HVbox - [: `stream_patt_comp b spc "" [: :]; - `HVbox [: `S LR "??"; `expr e "" k :] :] :] - | [(spc, None) :: spcl] -> - [: `stream_patt_comp b spc ";" [: `S RO ";" :]; - stream_patt [: :] spcl k :] - | [(spc, Some e) :: spcl] -> - [: `HVbox - [: `stream_patt_comp b spc "" [: :]; - `HVbox [: `S LR "??"; `expr e ";" [: `S RO ";" :] :] :]; - stream_patt [: :] spcl k :] ] - and stream_patt_comp b spc dg k = - match spc with - [ SPCterm (p, w) -> - HVbox [: b; `S LO "'"; `spatt p "" (when_opt w k) :] - | SPCnterm p e -> - HVbox [: b; `HVbox [: `patt p "" [: `S LR "=" :]; `expr e dg k :] :] - | SPCsterm p -> HVbox [: b; `patt p "" k :] ] - and when_opt wo k = - match wo with - [ Some e -> [: `S LR "when"; `expr e "" k :] - | _ -> k ] - in - parser_cases b spel dg k -; - -value parser_body e dg k = - let (bp, e) = - match e with - [ <:expr< let $bp$ = Stream.count strm__ in $e$ >> -> (Some bp, e) - | e -> (None, e) ] - in - let e = rewrite_parser e in - match parser_of_expr e with - [ [] -> - let spe = ([], None, <:expr< raise Stream.Failure >>) in - HVbox - [: `HVbox - [: `S LR "parser"; - match bp with - [ Some p -> [: `patt p "" [: :] :] - | _ -> [: :] ] :]; - parser_cases [: :] [spe] dg k :] - | spel -> - BEVbox - [: `HVbox - [: `S LR "parser"; - match bp with - [ Some p -> [: `patt p "" [: :] :] - | _ -> [: :] ] :]; - parser_cases [: :] spel dg k :] ] -; - -value pmatch e dg k = - let (me, e) = - match e with - [ <:expr< let (strm__ : Stream.t _) = $me$ in $e$ >> -> (me, e) - | _ -> failwith "Pr_op.pmatch" ] - in - let (bp, e) = - match e with - [ <:expr< let $bp$ = Stream.count strm__ in $e$ >> -> (Some bp, e) - | e -> (None, e) ] - in - let e = rewrite_parser e in - let spel = parser_of_expr e in - Vbox - [: `HVbox [: :]; - `HVbox - [: `S LR "match"; `expr me "" [: `S LR "with" :]; `S LR "parser"; - match bp with - [ Some p -> [: `patt p "" [: :] :] - | _ -> [: :] ] :]; - `BEbox [: `HVbox [: :]; parser_cases [: :] spel dg k :] :] -; - -(* Printer extensions *) - -pr_expr_fun_args.val := - extfun pr_expr_fun_args.val with - [ <:expr< fun strm__ -> $_$ >> as ge -> ([], ge) - | <:expr< fun [(strm__ : $_$) -> $_$] >> as ge -> ([], ge) ]; - -let lev = find_pr_level "expr1" pr_expr.pr_levels in -lev.pr_rules := - extfun lev.pr_rules with - [ <:expr< let (strm__ : Stream.t _) = $_$ in $_$ >> as e -> - fun curr next dg k -> - if not (List.mem dg ["|"; ";"]) then [: `pmatch e dg k :] - else [: `S LO "("; `pmatch e "" [: `S RO ")"; k :] :] - | <:expr< fun strm__ -> $x$ >> -> - fun curr next dg k -> - if not (List.mem dg ["|"; ";"]) then [: `parser_body x dg k :] - else [: `S LO "("; `parser_body x "" [: `S RO ")"; k :] :] - | <:expr< fun [ (strm__ : $_$) -> $x$ ] >> -> - fun curr next dg k -> - if not (List.mem dg ["|"; ";"]) then [: `parser_body x dg k :] - else [: `S LO "("; `parser_body x "" [: `S RO ")"; k :] :] ]; - -let lev = find_pr_level "apply" pr_expr.pr_levels in -lev.pr_rules := - extfun lev.pr_rules with - [ <:expr< Stream.iapp $_$ $_$ >> | <:expr< Stream.icons $_$ $_$ >> | - <:expr< Stream.ising $_$ >> | <:expr< Stream.lapp (fun _ -> $_$) $_$ >> | - <:expr< Stream.lcons (fun _ -> $_$) $_$ >> | - <:expr< Stream.lsing (fun _ -> $_$) >> | <:expr< Stream.sempty >> | - <:expr< Stream.slazy $_$ >> as e -> - fun curr next dg k -> [: `next e "" k :] ]; - -let lev = find_pr_level "dot" pr_expr.pr_levels in -lev.pr_rules := - extfun lev.pr_rules with - [ <:expr< Stream.sempty >> as e -> - fun curr next dg k -> [: `next e "" k :] ]; - -let lev = find_pr_level "simple" pr_expr.pr_levels in -lev.pr_rules := - extfun lev.pr_rules with - [ <:expr< Stream.iapp $_$ $_$ >> | <:expr< Stream.icons $_$ $_$ >> | - <:expr< Stream.ising $_$ >> | <:expr< Stream.lapp (fun _ -> $_$) $_$ >> | - <:expr< Stream.lcons (fun _ -> $_$) $_$ >> | - <:expr< Stream.lsing (fun _ -> $_$) >> | <:expr< Stream.sempty >> | - <:expr< Stream.slazy $_$ >> as e -> - fun curr next dg k -> - [: `stream e "" k :] ]; diff --git a/camlp4/etc/pr_op_main.ml b/camlp4/etc/pr_op_main.ml deleted file mode 100644 index d7203e6e38..0000000000 --- a/camlp4/etc/pr_op_main.ml +++ /dev/null @@ -1,214 +0,0 @@ -(* camlp4r q_MLast.cmo ./pa_extfun.cmo *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1998 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -open Pcaml; -open Spretty; - -value loc = (0, 0); - -value expr e dg k = pr_expr.pr_fun "top" e dg k; -value patt e dg k = pr_patt.pr_fun "top" e dg k; - -value spatt p dg k = - match p with - [ <:patt< $lid:s$ >> -> - if String.length s >= 2 && s.[1] == ''' then - HVbox [: `S LR (" " ^ s); k :] - else patt p dg k - | _ -> patt p dg k ] -; - -(* Streams *) - -value stream e _ k = - let rec get = - fun - [ <:expr< Stream.iapp $x$ $y$ >> -> [(False, x) :: get y] - | <:expr< Stream.icons $x$ $y$ >> -> [(True, x) :: get y] - | <:expr< Stream.ising $x$ >> -> [(True, x)] - | <:expr< Stream.lapp (fun _ -> $x$) $y$ >> -> [(False, x) :: get y] - | <:expr< Stream.lcons (fun _ -> $x$) $y$ >> -> [(True, x) :: get y] - | <:expr< Stream.lsing (fun _ -> $x$) >> -> [(True, x)] - | <:expr< Stream.sempty >> -> [] - | <:expr< Stream.slazy (fun _ -> $x$) >> -> [(False, x)] - | <:expr< Stream.slazy $x$ >> -> [(False, <:expr< $x$ () >>)] - | e -> [(False, e)] ] - in - let elem e dg k = - match e with - [ (True, e) -> [: `HOVbox [: `S LO "'"; `expr e dg k :] :] - | (False, e) -> [: `expr e dg k :] ] - in - let rec glop e k = - match e with - [ [] -> k - | [e] -> [: elem e "" k :] - | [e :: el] -> [: elem e ";" [: `S RO ";" :]; glop el k :] ] - in - HOVbox [: `S LR "[<"; glop (get e) [: `S LR ">]"; k :] :] -; - -(* Parsers *) - -open Parserify; - -value parser_cases b spel dg k = - let rec parser_cases b spel dg k = - match spel with - [ [] -> [: `HVbox [: b; k :] :] - | [(sp, epo, e)] -> [: `parser_case b sp epo e dg k :] - | [(sp, epo, e) :: spel] -> - [: `parser_case b sp epo e "|" [: :]; - parser_cases [: `S LR "|" :] spel dg k :] ] - and parser_case b sp epo e dg k = - let epo = - match epo with - [ Some p -> [: `patt p "" [: `S LR "->" :] :] - | _ -> [: `S LR "->" :] ] - in - HVbox - [: b; - `HOVbox - [: `HOVbox - [: `S LR "[<"; - stream_patt [: :] sp [: `S LR ">]"; epo :] :]; - `expr e dg k :] :] - and stream_patt b sp k = - match sp with - [ [] -> [: `HVbox [: b; k :] :] - | [(spc, None)] -> [: `stream_patt_comp b spc "" k :] - | [(spc, Some e)] -> - [: `HVbox - [: `stream_patt_comp b spc "" [: :]; - `HVbox [: `S LR "??"; `expr e "" k :] :] :] - | [(spc, None) :: spcl] -> - [: `stream_patt_comp b spc ";" [: `S RO ";" :]; - stream_patt [: :] spcl k :] - | [(spc, Some e) :: spcl] -> - [: `HVbox - [: `stream_patt_comp b spc "" [: :]; - `HVbox [: `S LR "??"; `expr e ";" [: `S RO ";" :] :] :]; - stream_patt [: :] spcl k :] ] - and stream_patt_comp b spc dg k = - match spc with - [ SPCterm (p, w) -> - HVbox [: b; `S LO "'"; `spatt p "" (when_opt w k) :] - | SPCnterm p e -> - HVbox [: b; `HVbox [: `patt p "" [: `S LR "=" :]; `expr e dg k :] :] - | SPCsterm p -> HVbox [: b; `patt p "" k :] ] - and when_opt wo k = - match wo with - [ Some e -> [: `S LR "when"; `expr e "" k :] - | _ -> k ] - in - parser_cases b spel dg k -; - -value parser_body e dg k = - let (bp, e) = - match e with - [ <:expr< let $bp$ = Stream.count strm__ in $e$ >> -> (Some bp, e) - | e -> (None, e) ] - in - match parser_of_expr e with - [ [] -> - let spe = ([], None, <:expr< raise Stream.Failure >>) in - HVbox - [: `HVbox - [: `S LR "parser"; - match bp with - [ Some p -> [: `patt p "" [: :] :] - | _ -> [: :] ] :]; - parser_cases [: :] [spe] dg k :] - | spel -> - BEVbox - [: `HVbox - [: `S LR "parser"; - match bp with - [ Some p -> [: `patt p "" [: :] :] - | _ -> [: :] ] :]; - parser_cases [: :] spel dg k :] ] -; - -value pmatch e dg k = - let (me, e) = - match e with - [ <:expr< let (strm__ : Stream.t _) = $me$ in $e$ >> -> (me, e) - | _ -> failwith "Pr_op.pmatch" ] - in - let (bp, e) = - match e with - [ <:expr< let $bp$ = Stream.count strm__ in $e$ >> -> (Some bp, e) - | e -> (None, e) ] - in - let spel = parser_of_expr e in - Vbox - [: `HVbox [: :]; - `HVbox - [: `S LR "match"; `expr me "" [: `S LR "with" :]; `S LR "parser"; - match bp with - [ Some p -> [: `patt p "" [: :] :] - | _ -> [: :] ] :]; - `BEbox [: `HVbox [: :]; parser_cases [: :] spel dg k :] :] -; - -(* Printer extensions *) - -pr_expr_fun_args.val := - extfun pr_expr_fun_args.val with - [ <:expr< fun strm__ -> $_$ >> as ge -> ([], ge) - | <:expr< fun [(strm__ : $_$) -> $_$] >> as ge -> ([], ge) ]; - -let lev = find_pr_level "expr1" pr_expr.pr_levels in -lev.pr_rules := - extfun lev.pr_rules with - [ <:expr< let (strm__ : Stream.t _) = $_$ in $_$ >> as e -> - fun curr next dg k -> - if not (List.mem dg ["|"; ";"]) then [: `pmatch e dg k :] - else [: `S LO "("; `pmatch e "" [: `S RO ")"; k :] :] - | <:expr< fun strm__ -> $x$ >> -> - fun curr next dg k -> - if not (List.mem dg ["|"; ";"]) then [: `parser_body x dg k :] - else [: `S LO "("; `parser_body x "" [: `S RO ")"; k :] :] - | <:expr< fun [ (strm__ : $_$) -> $x$ ] >> -> - fun curr next dg k -> - if not (List.mem dg ["|"; ";"]) then [: `parser_body x dg k :] - else [: `S LO "("; `parser_body x "" [: `S RO ")"; k :] :] ]; - -let lev = find_pr_level "apply" pr_expr.pr_levels in -lev.pr_rules := - extfun lev.pr_rules with - [ <:expr< Stream.iapp $_$ $_$ >> | <:expr< Stream.icons $_$ $_$ >> | - <:expr< Stream.ising $_$ >> | <:expr< Stream.lapp (fun _ -> $_$) $_$ >> | - <:expr< Stream.lcons (fun _ -> $_$) $_$ >> | - <:expr< Stream.lsing (fun _ -> $_$) >> | <:expr< Stream.sempty >> | - <:expr< Stream.slazy $_$ >> as e -> - fun curr next dg k -> [: `next e "" k :] ]; - -let lev = find_pr_level "dot" pr_expr.pr_levels in -lev.pr_rules := - extfun lev.pr_rules with - [ <:expr< Stream.sempty >> as e -> - fun curr next dg k -> [: `next e "" k :] ]; - -let lev = find_pr_level "simple" pr_expr.pr_levels in -lev.pr_rules := - extfun lev.pr_rules with - [ <:expr< Stream.iapp $_$ $_$ >> | <:expr< Stream.icons $_$ $_$ >> | - <:expr< Stream.ising $_$ >> | <:expr< Stream.lapp (fun _ -> $_$) $_$ >> | - <:expr< Stream.lcons (fun _ -> $_$) $_$ >> | - <:expr< Stream.lsing (fun _ -> $_$) >> | <:expr< Stream.sempty >> | - <:expr< Stream.slazy $_$ >> as e -> - fun curr next dg k -> - [: `stream e "" k :] ]; diff --git a/camlp4/etc/pr_r.ml b/camlp4/etc/pr_r.ml deleted file mode 100644 index eb14e73762..0000000000 --- a/camlp4/etc/pr_r.ml +++ /dev/null @@ -1,1898 +0,0 @@ -(* camlp4r q_MLast.cmo ./pa_extfun.cmo *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2001 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -open Pcaml; -open Spretty; - -value not_impl name x = - let desc = - if Obj.is_block (Obj.repr x) then - "tag = " ^ string_of_int (Obj.tag (Obj.repr x)) - else "int_val = " ^ string_of_int (Obj.magic x) - in - HVbox [: `S NO ("") :] -; - -value gen_where = ref True; -value old_sequences = ref False; -value expand_declare = ref False; - -external is_printable : char -> bool = "is_printable"; - -value char_escaped = - fun - [ '\\' -> "\\\\" - | '\b' -> "\\b" - | '\n' -> "\\n" - | '\r' -> "\\r" - | '\t' -> "\\t" - | c -> - if is_printable c then String.make 1 c - else do { - let n = Char.code c in - let s = String.create 4 in - String.unsafe_set s 0 '\\'; - String.unsafe_set s 1 (Char.unsafe_chr (48 + n / 100)); - String.unsafe_set s 2 (Char.unsafe_chr (48 + n / 10 mod 10)); - String.unsafe_set s 3 (Char.unsafe_chr (48 + n mod 10)); - s - } ] -; - -value rec list elem el k = - match el with - [ [] -> k - | [x] -> [: `elem x k :] - | [x :: l] -> [: `elem x [: :]; list elem l k :] ] -; - -value rec listws elem sep el k = - match el with - [ [] -> k - | [x] -> [: `elem x k :] - | [x :: l] -> [: `elem x [: `sep :]; listws elem sep l k :] ] -; - -value rec listwbws elem b sep el k = - match el with - [ [] -> [: b; k :] - | [x] -> [: `elem b x k :] - | [x :: l] -> [: `elem b x [: :]; listwbws elem [: `sep :] sep l k :] ] -; - -value is_infix = - let infixes = Hashtbl.create 73 in - do { - List.iter (fun s -> Hashtbl.add infixes s True) - ["=="; "!="; "+"; "+."; "-"; "-."; "*"; "*."; "/"; "/."; "**"; - "="; "=."; "<>"; "<>."; "<"; "<."; ">"; ">."; "<="; "<=."; ">="; ">=."; - "^"; "@"; "asr"; "land"; "lor"; "lsl"; "lsr"; "lxor"; "mod"; "or"; - "&&"; "||"; "~-"; "~-."]; - fun s -> try Hashtbl.find infixes s with [ Not_found -> False ] - } -; - -value is_keyword = - let keywords = Hashtbl.create 301 in - do { - List.iter (fun s -> Hashtbl.add keywords s True) - ["!"; "!="; "#"; "&"; "&&"; "'"; "("; ")"; "*"; "**"; "*."; "+"; "+."; - ","; "-"; "-."; "->"; "."; ".."; "/"; "/."; ":"; "::"; ":="; ":>"; - ":]"; ";"; "<"; "<="; "<>"; "="; "=="; ">"; ">="; ">}"; "?"; "@"; "["; - "[:"; "[|"; "]"; "^"; "_"; "`"; "and"; "as"; "asr"; "assert"; "class"; - "constraint"; "declare"; "do"; "done"; "downto"; "else"; "end"; - "exception"; "external"; "for"; "fun"; "functor"; "if"; "in"; - "include"; "inherit"; "initializer"; "land"; "lazy"; "let"; "lor"; - "lsl"; "lsr"; "lxor"; "match"; "method"; "mod"; "module"; "mutable"; - "new"; "object"; "of"; "open"; "parser"; "private"; "rec"; "return"; - "sig"; "struct"; "then"; "to"; "try"; "type"; "value"; "virtual"; - "when"; "where"; "while"; "with"; "{"; "{<"; "|"; "|]"; "||"; "}"; - "~-"; "~-."]; - fun s -> try Hashtbl.find keywords s with [ Not_found -> False ] - } -; - -value has_special_chars v = - match v.[0] with - [ 'a'..'z' | 'A'..'Z' | '\192'..'\214' | '\216'..'\246' | '\248'..'\255' | - '_' -> - False - | _ -> - if String.length v >= 2 && v.[0] == '<' && - (v.[1] == '<' || v.[1] == ':') - then - False - else True ] -; - -value var_escaped v = - if v = "" then "$lid:\"\"$" - else if has_special_chars v || is_infix v then "\\" ^ v - else if is_keyword v then v ^ "__" - else v -; - -value flag n f = if f then [: `S LR n :] else [: :]; - -(* default global loc *) - -value loc = (0, 0); - -(* extensible printers *) - -value module_type e k = pr_module_type.pr_fun "top" e "" k; -value module_expr e k = pr_module_expr.pr_fun "top" e "" k; -value sig_item x k = pr_sig_item.pr_fun "top" x "" [: `S RO ";"; k :]; -value str_item x k = pr_str_item.pr_fun "top" x "" [: `S RO ";"; k :]; -value expr x k = pr_expr.pr_fun "top" x "" k; -value patt x k = pr_patt.pr_fun "top" x "" k; -value ctyp x k = pr_ctyp.pr_fun "top" x "" k; -value expr_fun_args ge = Extfun.apply pr_expr_fun_args.val ge; -value simple_expr x k = pr_expr.pr_fun "simple" x "" k; -value class_sig_item x k = - pr_class_sig_item.pr_fun "top" x "" [: `S RO ";"; k :] -; -value class_str_item x k = - pr_class_str_item.pr_fun "top" x "" [: `S RO ";"; k :] -; -value class_type x k = pr_class_type.pr_fun "top" x "" k; -value class_expr x k = pr_class_expr.pr_fun "top" x "" k; - - -(* type core *) - -value rec labels loc b vl k = - match vl with - [ [] -> [: b; k :] - | [v] -> - [: `HVbox - [: `HVbox [: :]; `label True b v [: :]; - `LocInfo (snd loc, snd loc) (HVbox k) :] :] - | [v :: l] -> [: `label False b v [: :]; labels loc [: :] l k :] ] -and label is_last b (loc, f, m, t) k = - let m = flag "mutable" m in - let k = [: if is_last then [: :] else [: `S RO ";" :]; k :] in - Hbox - [: `LocInfo loc - (HVbox - [: `HVbox [: b; `S LR f; `S LR ":" :]; - `HVbox [: m; `ctyp t [: :] :] :]); - k :] -; - -value rec ctyp_list tel k = listws ctyp (S LR "and") tel k; - -value rec variants loc b vl k = - match vl with - [ [] -> [: b; k :] - | [v] -> - [: `HVbox - [: `HVbox [: :]; `variant b v [: :]; - `LocInfo (snd loc, snd loc) (HVbox k) :] :] - | [v :: l] -> [: `variant b v [: :]; variants loc [: `S LR "|" :] l k :] ] -and variant b (loc, c, tl) k = - match tl with - [ [] -> HVbox [: `LocInfo loc (HVbox b); `HOVbox [: `S LR c; k :] :] - | _ -> - HVbox - [: `LocInfo loc (HVbox b); - `HOVbox [: `S LR c; `S LR "of"; ctyp_list tl k :] :] ] -; - -value rec row_fields b rfl k = listwbws row_field b (S LR "|") rfl k -and row_field b rf k = - match rf with - [ MLast.RfTag c ao tl -> - let c = "`" ^ c in - match tl with - [ [] -> HVbox [: b; `HOVbox [: `S LR c; k :] :] - | _ -> - let ao = if ao then [: `S LR "&" :] else [: :] in - HVbox - [: b; `HOVbox [: `S LR c; `S LR "of"; ao; ctyp_list tl k :] :] ] - | MLast.RfInh t -> HVbox [: b; `ctyp t k :] ] -; - -(* *) - -value rec class_longident sl k = - match sl with - [ [i] -> HVbox [: `S LR i; k :] - | [m :: sl] -> HVbox [: `S LR m; `S NO "."; `class_longident sl k :] - | _ -> HVbox [: `not_impl "class_longident" sl; k :] ] -; - -value rec clty_longident sl k = - match sl with - [ [i] -> HVbox [: `S LR i; k :] - | [m :: sl] -> HVbox [: `S LR m; `S NO "."; `clty_longident sl k :] - | _ -> HVbox [: `not_impl "clty_longident" sl; k :] ] -; - -value rec meth_list (ml, v) k = - match (ml, v) with - [ ([f], False) -> [: `field f k :] - | ([], _) -> [: `S LR ".."; k :] - | ([f :: ml], v) -> [: `field f [: `S RO ";" :]; meth_list (ml, v) k :] ] -and field (lab, t) k = - HVbox [: `S LR (var_escaped lab); `S LR ":"; `ctyp t k :] -; - -(* patterns *) - -value rec is_irrefut_patt = - fun - [ <:patt< $lid:_$ >> -> True - | <:patt< () >> -> True - | <:patt< _ >> -> True - | <:patt< ($x$ as $y$) >> -> is_irrefut_patt x && is_irrefut_patt y - | <:patt< { $list:fpl$ } >> -> - List.for_all (fun (_, p) -> is_irrefut_patt p) fpl - | <:patt< ($p$ : $_$) >> -> is_irrefut_patt p - | <:patt< ($list:pl$) >> -> List.for_all is_irrefut_patt pl - | <:patt< ? $_$ >> -> True - | <:patt< ? $_$ : ( $p$ ) >> -> is_irrefut_patt p - | <:patt< ? $_$ : ($p$ = $_$) >> -> is_irrefut_patt p - | <:patt< ~ $_$ >> -> True - | <:patt< ~ $_$ : $p$ >> -> is_irrefut_patt p - | _ -> False ] -; - -value rec get_defined_ident = - fun - [ <:patt< $_$ . $_$ >> -> [] - | <:patt< _ >> -> [] - | <:patt< $lid:x$ >> -> [x] - | <:patt< ($p1$ as $p2$) >> -> get_defined_ident p1 @ get_defined_ident p2 - | <:patt< $int:_$ >> -> [] - | (MLast.PaNativeInt _ _ | MLast.PaInt64 _ _ | MLast.PaInt32 _ _) -> [] - | <:patt< $flo:_$ >> -> [] - | <:patt< $str:_$ >> -> [] - | <:patt< $chr:_$ >> -> [] - | <:patt< [| $list:pl$ |] >> -> List.flatten (List.map get_defined_ident pl) - | <:patt< ($list:pl$) >> -> List.flatten (List.map get_defined_ident pl) - | <:patt< $uid:_$ >> -> [] - | <:patt< ` $_$ >> -> [] - | <:patt< # $list:_$ >> -> [] - | <:patt< $p1$ $p2$ >> -> get_defined_ident p1 @ get_defined_ident p2 - | <:patt< { $list:lpl$ } >> -> - List.flatten (List.map (fun (lab, p) -> get_defined_ident p) lpl) - | <:patt< $p1$ | $p2$ >> -> get_defined_ident p1 @ get_defined_ident p2 - | <:patt< $p1$ .. $p2$ >> -> get_defined_ident p1 @ get_defined_ident p2 - | <:patt< ($p$ : $_$) >> -> get_defined_ident p - | <:patt< ~ $_$ >> -> [] - | <:patt< ~ $_$ : $p$ >> -> get_defined_ident p - | <:patt< ? $_$ >> -> [] - | <:patt< ? $_$ : ($p$) >> -> get_defined_ident p - | <:patt< ? $_$ : ($p$ = $e$) >> -> get_defined_ident p - | <:patt< $anti:p$ >> -> get_defined_ident p ] -; - -value un_irrefut_patt p = - match get_defined_ident p with - [ [] -> (<:patt< _ >>, <:expr< () >>) - | [i] -> (<:patt< $lid:i$ >>, <:expr< $lid:i$ >>) - | il -> - let (upl, uel) = - List.fold_right - (fun i (upl, uel) -> - ([<:patt< $lid:i$ >> :: upl], [<:expr< $lid:i$ >> :: uel])) - il ([], []) - in - (<:patt< ($list:upl$) >>, <:expr< ($list:uel$) >>) ] -; - -(* expressions *) - -pr_expr_fun_args.val := - extfun Extfun.empty with - [ <:expr< fun [$p$ -> $e$] >> as ge -> - if is_irrefut_patt p then - let (pl, e) = expr_fun_args e in - ([p :: pl], e) - else ([], ge) - | ge -> ([], ge) ]; - -value rec bind_list b pel k = - match pel with - [ [pe] -> let_binding b pe k - | pel -> - Vbox [: `HVbox [: :]; listwbws let_binding b (S LR "and") pel k :] ] -and let_binding b (p, e) k = - let (p, e) = - if is_irrefut_patt p then (p, e) - else - let (up, ue) = un_irrefut_patt p in - (up, <:expr< match $e$ with [ $p$ -> $ue$ ] >>) - in - let loc = - let (bp1, ep1) = MLast.loc_of_patt p in - let (bp2, ep2) = MLast.loc_of_expr e in - (min bp1 bp2, max ep1 ep2) - in - LocInfo loc (BEbox [: let_binding0 [: b; `patt p [: :] :] e [: :]; k :]) -and let_binding0 b e k = - let (pl, e) = expr_fun_args e in - match e with - [ <:expr< let $opt:r$ $lid:f$ = fun [ $list:pel$ ] in $e$ >> - when - let rec call_f = - fun - [ <:expr< $lid:f'$ >> -> f = f' - | <:expr< $e$ $_$ >> -> call_f e - | _ -> False ] - in - gen_where.val && call_f e -> - let (pl1, e1) = expr_fun_args <:expr< fun [ $list:pel$ ] >> in - [: `HVbox [: `HVbox b; `HOVbox (list patt pl [: `S LR "=" :]) :]; - `HVbox - [: `HOVbox - [: `expr e [: :]; `S LR "where"; flag "rec" r; `S LR f; - `HVbox (list patt pl1 [: `S LR "=" :]) :]; - `expr e1 k :] :] - | <:expr< ($e$ : $t$) >> -> - [: `HVbox - [: `HVbox b; `HOVbox (list patt pl [: `S LR ":" :]); - `ctyp t [: `S LR "=" :] :]; - `expr e k :] - | _ -> - [: `HVbox [: `HVbox b; `HOVbox (list patt pl [: `S LR "=" :]) :]; - `expr e k :] ] -and match_assoc_list pwel k = - match pwel with - [ [pwe] -> match_assoc [: `S LR "[" :] pwe [: `S LR "]"; k :] - | pel -> - Vbox - [: `HVbox [: :]; - listwbws match_assoc [: `S LR "[" :] (S LR "|") pel - [: `S LR "]"; k :] :] ] -and match_assoc b (p, w, e) k = - let s = - let (p, k) = - match p with - [ <:patt< ($p$ as $p2$) >> -> (p, [: `S LR "as"; `patt p2 [: :] :]) - | _ -> (p, [: :]) ] - in - match w with - [ Some e1 -> - [: `HVbox - [: `HVbox [: :]; `patt p k; - `HVbox [: `S LR "when"; `expr e1 [: `S LR "->" :] :] :] :] - | _ -> [: `patt p [: k; `S LR "->" :] :] ] - in - HVbox [: b; `HVbox [: `HVbox s; `expr e k :] :] -; - -value label lab = S LR (var_escaped lab); - -value field_expr (lab, e) k = HVbox [: `label lab; `S LR "="; `expr e k :]; - -value rec sequence_loop = - fun - [ [<:expr< let $opt:r$ $list:pel$ in $e$ >>] -> - let el = - match e with - [ <:expr< do { $list:el$ } >> -> el - | _ -> [e] ] - in - let r = flag "rec" r in - [: listwbws (fun b (p, e) k -> let_binding b (p, e) k) - [: `S LR "let"; r :] (S LR "and") pel [: `S LR "in" :]; - sequence_loop el :] - | [(<:expr< let $opt:_$ $list:_$ in $_$ >> as e) :: el] -> - [: `simple_expr e [: `S RO ";" :]; sequence_loop el :] - | [e] -> [: `expr e [: :] :] - | [e :: el] -> [: `expr e [: `S RO ";" :]; sequence_loop el :] - | [] -> [: :] ] -; - -value sequence b1 b2 b3 el k = - BEbox - [: `BEbox [: b1; b2; `HVbox [: b3; `S LR "do {" :] :]; - `HVbox [: `HVbox [: :]; sequence_loop el :]; - `HVbox [: `S LR "}"; k :] :] -; - -value rec let_sequence e = - match e with - [ <:expr< do { $list:el$ } >> -> Some el - | <:expr< let $opt:_$ $list:_$ in $e1$ >> -> - match let_sequence e1 with - [ Some _ -> Some [e] - | None -> None ] - | _ -> None ] -; - -value ifbox b1 b2 b3 e k = - if old_sequences.val then HVbox [: `HOVbox [: b1; b2; b3 :]; `expr e k :] - else - match let_sequence e with - [ Some el -> sequence b1 b2 b3 el k - | None -> HVbox [: `BEbox [: b1; b2; b3 :]; `expr e k :] ] -; - -value rec type_params sl k = - list - (fun (s, vari) k -> - let b = - match vari with - [ (True, False) -> [: `S LO "+" :] - | (False, True) -> [: `S LO "-" :] - | _ -> [: :] ] - in - HVbox [: b; `S LO "'"; `S LR s; k :]) - sl k -; - -value constrain (t1, t2) k = - HVbox [: `S LR "constraint"; `ctyp t1 [: `S LR "=" :]; `ctyp t2 k :] -; - -value type_list b tdl k = - HVbox - [: `HVbox [: :]; - listwbws - (fun b ((_, tn), tp, te, cl) k -> - let tn = var_escaped tn in - HVbox - [: `HVbox [: b; `S LR tn; type_params tp [: `S LR "=" :] :]; - `ctyp te [: :]; list constrain cl k :]) - b (S LR "and") tdl [: :]; - k :] -; - -value external_def s t pl k = - let ls = list (fun s k -> HVbox [: `S LR ("\"" ^ s ^ "\""); k :]) pl k in - HVbox - [: `HVbox [: `S LR "external"; `S LR (var_escaped s); `S LR ":" :]; - `ctyp t [: `S LR "="; ls :] :] -; - -value value_description s t k = - HVbox - [: `HVbox [: `S LR "value"; `S LR (var_escaped s); `S LR ":" :]; - `ctyp t k :] -; - -value typevar s k = HVbox [: `S LR ("'" ^ s); k :]; - -value rec mod_ident sl k = - match sl with - [ [] -> k - | [s] -> [: `S LR (var_escaped s); k :] - | [s :: sl] -> [: `S LR s; `S NO "."; mod_ident sl k :] ] -; - -value rec module_declaration b mt k = - match mt with - [ <:module_type< functor ( $i$ : $t$ ) -> $mt$ >> -> - module_declaration - [: `HVbox - [: b; - `HVbox - [: `S LO "("; `S LR i; `S LR ":"; - `module_type t [: `S RO ")" :] :] :] :] - mt k - | _ -> - HVbox - [: `HVbox [: :]; - `HVbox [: `HVbox [: b; `S LR ":" :]; `module_type mt [: :] :]; - k :] ] -and module_rec_declaration b (n,mt) k = - HVbox - [: `HVbox - [: b; `S LR n; `S LR ":"; `module_type mt [: :] :]; - k :] -and modtype_declaration s mt k = - HVbox - [: `HVbox [: :]; - `HVbox - [: `HVbox [: `S LR "module"; `S LR "type"; `S LR s; `S LR "=" :]; - `module_type mt [: :] :]; - k :] -and with_constraints b icl k = - HVbox [: `HVbox [: :]; listwbws with_constraint b (S LR "and") icl k :] -and with_constraint b wc k = - match wc with - [ <:with_constr< type $p$ $list:al$ = $e$ >> -> - let params = - match al with - [ [] -> [: :] - | [s] -> [: `S LO "'"; `S LR (fst s) :] - | sl -> [: `S LO "("; type_params sl [: `S RO ")" :] :] ] - in - HVbox - [: `HVbox - [: `HVbox b; `S LR "type"; params; - mod_ident p [: `S LR "=" :] :]; - `ctyp e k :] - | <:with_constr< module $sl$ = $me$ >> -> - HVbox - [: b; `S LR "module"; mod_ident sl [: `S LR "=" :]; - `module_expr me k :] ] -and module_binding b me k = - match me with - [ <:module_expr< functor ($s$ : $mt$) -> $mb$ >> -> - module_binding - [: `HVbox - [: b; - `HVbox - [: `HVbox [: `S LO "("; `S LR s; `S LR ":" :]; - `module_type mt [: `S RO ")" :] :] :] :] - mb k - | <:module_expr< ( $me$ : $mt$ ) >> -> - HVbox - [: `HVbox [: :]; - `HVbox - [: `HVbox - [: `HVbox [: b; `S LR ":" :]; - `module_type mt [: `S LR "=" :] :]; - `module_expr me [: :] :]; - k :] - | _ -> - HVbox - [: `HVbox [: :]; - `HVbox [: `HVbox [: b; `S LR "=" :]; `module_expr me [: :] :]; - k :] ] -and module_rec_binding b (n, mt,me) k = - HVbox - [: `HVbox [: :]; - `HVbox - [: `HVbox - [: `HVbox [: b; `S LR n; `S LR ":" :]; - `module_type mt [: `S LR "=" :] :]; - `module_expr me [: :] :]; - k :] -and class_declaration b ci k = - class_fun_binding - [: b; flag "virtual" ci.MLast.ciVir; `S LR ci.MLast.ciNam; - class_type_parameters ci.MLast.ciPrm :] - ci.MLast.ciExp k -and class_fun_binding b ce k = - match ce with - [ <:class_expr< fun $p$ -> $cfb$ >> -> - class_fun_binding [: b; `patt p [: :] :] cfb k - | ce -> HVbox [: `HVbox [: b; `S LR "=" :]; `class_expr ce k :] ] -and class_type_parameters (loc, tpl) = - match tpl with - [ [] -> [: :] - | tpl -> - [: `S LO "["; listws type_parameter (S RO ",") tpl [: `S RO "]" :] :] ] -and type_parameter tp k = HVbox [: `S LO "'"; `S LR (fst tp); k :] -and simple_expr e k = - match e with - [ <:expr< $lid:_$ >> -> expr e k - | _ -> HVbox [: `S LO "("; `expr e [: `S RO ")"; k :] :] ] -and class_self_patt_opt csp = - match csp with - [ Some p -> HVbox [: `S LO "("; `patt p [: `S RO ")" :] :] - | None -> HVbox [: :] ] -and label lab = S LR (var_escaped lab) -and cvalue b (lab, mf, e) k = - HVbox - [: `HVbox [: b; flag "mutable" mf; `label lab; `S LR "=" :]; `expr e k :] -and fun_binding b fb k = - match fb with - [ <:expr< fun $p$ -> $e$ >> -> fun_binding [: b; `simple_patt p [: :] :] e k - | e -> HVbox [: `HVbox [: b; `S LR "=" :]; `expr e k :] ] -and simple_patt p k = - match p with - [ <:patt< $lid:_$ >> | <:patt< ~ $_$ : $_$ >> | - <:patt< ? $_$ : ($_$ $opt:_$) >> -> patt p k - | _ -> HVbox [: `S LO "("; `patt p [: `S RO ")"; k :] :] ] -and class_signature cs k = - match cs with - [ <:class_type< $list:id$ >> -> clty_longident id k - | <:class_type< $list:id$ [ $list:tl$ ] >> -> - HVbox - [: `clty_longident id [: :]; `S LO "["; - listws ctyp (S RO ",") tl [: `S RO "]"; k :] :] - | <:class_type< object $opt:cst$ $list:csf$ end >> -> - let ep = snd (MLast.loc_of_class_type cs) in - class_self_type [: `S LR "object" :] cst - [: `HVbox - [: `HVbox [: :]; list class_sig_item csf [: :]; - `LocInfo (ep, ep) (HVbox [: :]) :]; - `HVbox [: `S LR "end"; k :] :] - | _ -> HVbox [: `not_impl "class_signature" cs; k :] ] -and class_self_type b cst k = - BEbox - [: `HVbox - [: b; - match cst with - [ None -> [: :] - | Some t -> [: `S LO "("; `ctyp t [: `S RO ")" :] :] ] :]; - k :] -and class_description b ci k = - HVbox - [: `HVbox - [: b; flag "virtual" ci.MLast.ciVir; `S LR ci.MLast.ciNam; - class_type_parameters ci.MLast.ciPrm; `S LR ":" :]; - `class_type ci.MLast.ciExp k :] -and class_type_declaration b ci k = - HVbox - [: `HVbox - [: b; flag "virtual" ci.MLast.ciVir; `S LR ci.MLast.ciNam; - class_type_parameters ci.MLast.ciPrm; `S LR "=" :]; - `class_signature ci.MLast.ciExp k :] -; - -pr_module_type.pr_levels := - [{pr_label = "top"; pr_box s x = HVbox x; - pr_rules = - extfun Extfun.empty with - [ <:module_type< functor ( $s$ : $mt1$ ) -> $mt2$ >> -> - fun curr next _ k -> - let head = - HVbox - [: `S LR "functor"; `S LO "("; `S LR s; `S LR ":"; - `module_type mt1 [: `S RO ")" :]; `S LR "->" :] - in - [: `head; `module_type mt2 k :] - | e -> fun curr next dg k -> [: `next e dg k :] ]}; - {pr_label = ""; pr_box s x = HVbox x; - pr_rules = - extfun Extfun.empty with - [ <:module_type< $mt$ with $list:icl$ >> -> - fun curr next _ k -> - [: curr mt "" [: :]; `with_constraints [: `S LR "with" :] icl k :] - | e -> fun curr next dg k -> [: `next e dg k :] ]}; - {pr_label = ""; pr_box s x = HVbox x; - pr_rules = - extfun Extfun.empty with - [ <:module_type< sig $list:s$ end >> as mt -> - fun curr next _ k -> - let ep = snd (MLast.loc_of_module_type mt) in - [: `BEbox - [: `S LR "sig"; - `HVbox - [: `HVbox [: :]; list sig_item s [: :]; - `LocInfo (ep, ep) (HVbox [: :]) :]; - `HVbox [: `S LR "end"; k :] :] :] - | e -> fun curr next dg k -> [: `next e dg k :] ]}; - {pr_label = ""; pr_box s x = HVbox x; - pr_rules = - extfun Extfun.empty with - [ <:module_type< $mt1$ $mt2$ >> -> - fun curr next _ k -> [: curr mt1 "" [: :]; `next mt2 "" k :] - | e -> fun curr next dg k -> [: `next e dg k :] ]}; - {pr_label = ""; pr_box s x = HVbox x; - pr_rules = - extfun Extfun.empty with - [ <:module_type< $mt1$ . $mt2$ >> -> - fun curr next _ k -> - [: curr mt1 "" [: `S NO "." :]; `next mt2 "" k :] - | e -> fun curr next dg k -> [: `next e dg k :] ]}; - {pr_label = ""; pr_box s x = HVbox x; - pr_rules = - extfun Extfun.empty with - [ <:module_type< $lid:s$ >> -> fun curr next _ k -> [: `S LR s; k :] - | <:module_type< $uid:s$ >> -> fun curr next _ k -> [: `S LR s; k :] - | <:module_type< ' $s$ >> -> - fun curr next _ k -> [: `S LR ("'" ^ s); k :] - | mt -> - fun curr next _ k -> - [: `S LO "("; `module_type mt [: `S RO ")"; k :] :] ]}]; - -pr_module_expr.pr_levels := - [{pr_label = "top"; pr_box s x = HVbox x; - pr_rules = - extfun Extfun.empty with - [ <:module_expr< struct $list:s$ end >> as me -> - fun curr next _ k -> - let ep = snd (MLast.loc_of_module_expr me) in - [: `HVbox [: :]; - `HVbox - [: `S LR "struct"; list str_item s [: :]; - `LocInfo (ep, ep) (HVbox [: :]) :]; - `HVbox [: `S LR "end"; k :] :] - | <:module_expr< functor ($s$ : $mt$) -> $me$ >> -> - fun curr next _ k -> - let head = - HVbox - [: `S LR "functor"; `S LO "("; `S LR s; `S LR ":"; - `module_type mt [: `S RO ")" :]; `S LR "->" :] - in - [: `head; curr me "" k :] - | e -> fun curr next dg k -> [: `next e dg k :] ]}; - {pr_label = ""; pr_box s x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:module_expr< $me1$ $me2$ >> -> - fun curr next _ k -> [: curr me1 "" [: :]; `next me2 "" k :] - | e -> fun curr next dg k -> [: `next e dg k :] ]}; - {pr_label = ""; pr_box s x = HVbox x; - pr_rules = - extfun Extfun.empty with - [ <:module_expr< $me1$ . $me2$ >> -> - fun curr next _ k -> - [: curr me1 "" [: `S NO "." :]; `next me2 "" k :] - | e -> fun curr next dg k -> [: `next e dg k :] ]}; - {pr_label = ""; pr_box s x = HVbox x; - pr_rules = - extfun Extfun.empty with - [ <:module_expr< $uid:s$ >> -> fun curr next _ k -> [: `S LR s; k :] - | <:module_expr< ( $me$ : $mt$ ) >> -> - fun curr next _ k -> - [: `S LO "("; `module_expr me [: `S LR ":" :]; - `module_type mt [: `S RO ")"; k :] :] - | <:module_expr< struct $list:_$ end >> | - <:module_expr< functor ($_$ : $_$) -> $_$ >> | - <:module_expr< $_$ $_$ >> | <:module_expr< $_$ . $_$ >> as me -> - fun curr next _ k -> - [: `S LO "("; `module_expr me [: `S RO ")"; k :] :] ]}]; - -pr_sig_item.pr_levels := - [{pr_label = "top"; - pr_box s x = LocInfo (MLast.loc_of_sig_item s) (HVbox x); - pr_rules = - extfun Extfun.empty with - [ <:sig_item< type $list:stl$ >> -> - fun curr next _ k -> [: `type_list [: `S LR "type" :] stl k :] - | <:sig_item< declare $list:s$ end >> -> - fun curr next _ k -> - if expand_declare.val then - if s = [] then [: `S LR "(* *)" :] - else [: `HVbox [: :]; list sig_item s [: :] :] - else - [: `BEbox - [: `S LR "declare"; - `HVbox [: `HVbox [: :]; list sig_item s [: :] :]; - `HVbox [: `S LR "end"; k :] :] :] - | <:sig_item< # $_$ $opt:_$ >> as si -> - fun curr next _ k -> [: `not_impl "sig_item1" si :] - | <:sig_item< exception $c$ of $list:tl$ >> -> - fun curr next _ k -> - [: `variant [: `S LR "exception" :] (loc, c, tl) k :] - | <:sig_item< value $s$ : $t$ >> -> - fun curr next _ k -> [: `value_description s t k :] - | <:sig_item< include $mt$ >> -> - fun curr next _ k -> [: `S LR "include"; `module_type mt k :] - | <:sig_item< external $s$ : $t$ = $list:pl$ >> -> - fun curr next _ k -> [: `external_def s t pl k :] - | <:sig_item< module $s$ : $mt$ >> -> - fun curr next _ k -> - [: `module_declaration [: `S LR "module"; `S LR s :] mt k :] - | <:sig_item< module rec $list:nmts$ >> -> - fun curr next _ k -> - [: `HVbox [: :]; - listwbws module_rec_declaration [: `S LR "module rec" :] (S LR "and") nmts - k :] - | <:sig_item< module type $s$ = $mt$ >> -> - fun curr next _ k -> [: `modtype_declaration s mt k :] - | <:sig_item< open $sl$ >> -> - fun curr next _ k -> [: `S LR "open"; mod_ident sl k :] - | <:sig_item< class $list:cd$ >> -> - fun curr next _ k -> - [: `HVbox [: :]; - listwbws class_description [: `S LR "class" :] (S LR "and") cd - k :] - | <:sig_item< class type $list:cd$ >> -> - fun curr next _ k -> - [: `HVbox [: :]; - listwbws class_type_declaration - [: `S LR "class"; `S LR "type" :] (S LR "and") cd k :] - | MLast.SgUse _ _ _ -> - fun curr next _ k -> [: :] ]}]; - -pr_str_item.pr_levels := - [{pr_label = "top"; - pr_box s x = LocInfo (MLast.loc_of_str_item s) (HVbox x); - pr_rules = - extfun Extfun.empty with - [ <:str_item< open $i$ >> -> - fun curr next _ k -> [: `S LR "open"; mod_ident i k :] - | <:str_item< $exp:e$ >> -> - fun curr next _ k -> [: `HVbox [: :]; `expr e k :] - | <:str_item< declare $list:s$ end >> -> - fun curr next _ k -> - if expand_declare.val then - if s = [] then [: `S LR "(* *)" :] - else [: `HVbox [: :]; list str_item s [: :] :] - else - [: `BEbox - [: `S LR "declare"; - `HVbox [: `HVbox [: :]; list str_item s [: :] :]; - `HVbox [: `S LR "end"; k :] :] :] - | <:str_item< # $s$ $opt:x$ >> -> - fun curr next _ k -> - let s = - "(* #" ^ s ^ " " ^ - (match x with - [ Some <:expr< $str:s$ >> -> "\"" ^ s ^ "\"" - | _ -> "?" ]) ^ - " *)" - in - [: `S LR s :] - | <:str_item< exception $c$ of $list:tl$ = $b$ >> -> - fun curr next _ k -> - match b with - [ [] -> [: `variant [: `S LR "exception" :] (loc, c, tl) k :] - | _ -> - [: `variant [: `S LR "exception" :] (loc, c, tl) - [: `S LR "=" :]; - mod_ident b k :] ] - | <:str_item< include $me$ >> -> - fun curr next _ k -> [: `S LR "include"; `module_expr me k :] - | <:str_item< type $list:tdl$ >> -> - fun curr next _ k -> [: `type_list [: `S LR "type" :] tdl k :] - | <:str_item< value $opt:rf$ $list:pel$ >> -> - fun curr next _ k -> - [: `bind_list [: `S LR "value"; flag "rec" rf :] pel k :] - | <:str_item< external $s$ : $t$ = $list:pl$ >> -> - fun curr next _ k -> [: `external_def s t pl k :] - | <:str_item< module $s$ = $me$ >> -> - fun curr next _ k -> - [: `module_binding [: `S LR "module"; `S LR s :] me k :] - | <:str_item< module rec $list:nmtmes$ >> -> - fun curr next _ k -> - [: `HVbox [: :]; - listwbws module_rec_binding [: `S LR "module rec" :] (S LR "and") nmtmes - k :] - | <:str_item< module type $s$ = $mt$ >> -> - fun curr next _ k -> - [: `HVbox [: :]; - `HVbox - [: `HVbox - [: `S LR "module"; `S LR "type"; `S LR s; - `S LR "=" :]; - `module_type mt [: :] :]; - k :] - | <:str_item< class $list:cd$ >> -> - fun curr next _ k -> - [: `HVbox [: :]; - listwbws class_declaration [: `S LR "class" :] (S LR "and") cd - k :] - | <:str_item< class type $list:cd$ >> -> - fun curr next _ k -> - [: `HVbox [: :]; - listwbws class_type_declaration - [: `S LR "class"; `S LR "type" :] (S LR "and") cd k :] - | MLast.StUse _ _ _ -> - fun curr next _ k -> [: :] ]}]; - -(* -EXTEND_PRINTER - pr_expr: - [ "top" (fun e x -> LocInfo (MLast.loc_of_expr e) (HOVbox x)) - [ <:expr< let $rec:r$ $p1$ = $e1$ in $e$ >> -> - let r = flag "rec" r in - [: `Vbox - [: `HVbox [: :]; - `let_binding [: `S LR "let"; r :] (p1, e1) - [: `S LR "in" :]; - `expr e k :] :] - | <:expr< let $rec:r$ $list:pel$ in $e$ >> -> - let r = flag "rec" r in - [: `Vbox - [: `HVbox [: :]; - listwbws (fun b (p, e) k -> let_binding b (p, e) k) - [: `S LR "let"; r :] (S LR "and") pel [: `S LR "in" :]; - `expr e k :] :] ] ] - ; -END; -*) - -pr_expr.pr_levels := - [{pr_label = "top"; pr_box e x = LocInfo (MLast.loc_of_expr e) (HOVbox x); - pr_rules = - extfun Extfun.empty with - [ <:expr< let $opt:r$ $p1$ = $e1$ in $e$ >> -> - fun curr next _ k -> - let r = flag "rec" r in - [: `Vbox - [: `HVbox [: :]; - `let_binding [: `S LR "let"; r :] (p1, e1) - [: `S LR "in" :]; - `expr e k :] :] - | <:expr< let $opt:r$ $list:pel$ in $e$ >> -> - fun curr next _ k -> - let r = flag "rec" r in - [: `Vbox - [: `HVbox [: :]; - listwbws (fun b (p, e) k -> let_binding b (p, e) k) - [: `S LR "let"; r :] (S LR "and") pel [: `S LR "in" :]; - `expr e k :] :] - | <:expr< let module $m$ = $mb$ in $e$ >> -> - fun curr next _ k -> - [: `HVbox - [: `HVbox [: :]; - `module_binding - [: `S LR "let"; `S LR "module"; `S LR m :] mb - [: `S LR "in" :]; - `expr e k :] :] - | <:expr< fun [ $list:pel$ ] >> -> - fun curr next _ k -> - match pel with - [ [] -> [: `S LR "fun"; `S LR "[]"; k :] - | [(p, None, e)] -> - if is_irrefut_patt p then - let (pl, e) = expr_fun_args e in - [: `BEbox - [: `HOVbox - [: `S LR "fun"; - list patt [p :: pl] [: `S LR "->" :] :]; - `expr e k :] :] - else - [: `HVbox [: `S LR "fun ["; `patt p [: `S LR "->" :] :]; - `expr e [: `S LR "]"; k :] :] - | _ -> - [: `Vbox - [: `HVbox [: :]; `S LR "fun"; - listwbws match_assoc [: `S LR "[" :] (S LR "|") pel - [: `S LR "]"; k :] :] :] ] - | <:expr< match $e$ with $p1$ -> $e1$ >> when is_irrefut_patt p1 -> - fun curr next _ k -> - [: `BEbox - [: `S LR "match"; `expr e [: :]; - `HVbox [: `S LR "with"; `patt p1 [: `S LR "->" :] :] :]; - `expr e1 k :] - | <:expr< match $e$ with [ ] >> -> - fun curr next _ k -> - [: `HVbox [: :]; - `BEbox - [: `S LR "match"; `expr e [: :]; `S LR "with"; `S LR "[]"; - k :] :] - | <:expr< match $e$ with [ $list:pel$ ] >> -> - fun curr next _ k -> - [: `HVbox [: :]; - `BEbox [: `S LR "match"; `expr e [: :]; `S LR "with" :]; - `match_assoc_list pel k :] - | <:expr< try $e$ with [ ] >> -> - fun curr next _ k -> - [: `HVbox [: :]; - `BEbox - [: `S LR "try"; `expr e [: :]; `S LR "with"; `S LR "[]"; - k :] :] - | <:expr< try $e$ with $p1$ -> $e1$ >> when is_irrefut_patt p1 -> - fun curr next _ k -> - [: `BEbox - [: `S LR "try"; `expr e [: :]; - `HVbox [: `S LR "with"; `patt p1 [: `S LR "->" :] :] :]; - `expr e1 k :] - | <:expr< try $e$ with [ $list:pel$ ] >> -> - fun curr next _ k -> - [: `HVbox [: :]; - `BEbox [: `S LR "try"; `expr e [: :]; `S LR "with" :]; - `match_assoc_list pel k :] - | <:expr< if $e1$ then $e2$ else $e3$ >> -> - fun curr next _ k -> - let (eel, e) = - elseif e3 where rec elseif e = - match e with - [ <:expr< if $e1$ then $e2$ else $e3$ >> -> - let (eel, e) = elseif e3 in - ([(e1, e2) :: eel], e) - | _ -> ([], e) ] - in - [: `HVbox - [: `HVbox [: :]; - `ifbox [: `S LR "if" :] [: `expr e1 [: :] :] - [: `S LR "then" :] e2 [: :]; - list - (fun (e1, e2) k -> - ifbox [: `HVbox [: `S LR "else"; `S LR "if" :] :] - [: `expr e1 [: :] :] [: `S LR "then" :] e2 k) - eel [: :]; - `ifbox [: `S LR "else" :] [: :] [: :] e k :] :] - | <:expr< do { $list:el$ } >> when old_sequences.val -> - fun curr next _ k -> - let (el, e) = - match List.rev el with - [ [e :: el] -> (List.rev el, e) - | [] -> ([], <:expr< () >>) ] - in - [: `HOVCbox - [: `HVbox [: :]; - `BEbox - [: `S LR "do"; - `HVbox - [: `HVbox [: :]; - list (fun e k -> expr e [: `S RO ";"; k :]) - el [: :] :]; - `S LR "return" :]; - `expr e k :] :] - | <:expr< do { $list:el$ } >> -> - fun curr next _ k -> [: `sequence [: :] [: :] [: :] el k :] - | <:expr< for $i$ = $e1$ $to:d$ $e2$ do { $list:el$ } >> - when old_sequences.val -> - fun curr next _ k -> - let d = if d then "to" else "downto" in - [: `BEbox - [: `HOVbox - [: `S LR "for"; `S LR i; `S LR "="; - `expr e1 [: `S LR d :]; - `expr e2 [: `S LR "do" :] :]; - `HVbox - [: `HVbox [: :]; - list (fun e k -> expr e [: `S RO ";"; k :]) el - [: :] :]; - `HVbox [: `S LR "done"; k :] :] :] - | <:expr< for $i$ = $e1$ $to:d$ $e2$ do { $list:el$ } >> -> - fun curr next _ k -> - let d = if d then "to" else "downto" in - [: `sequence - [: `HOVbox - [: `S LR "for"; `S LR i; `S LR "="; - `expr e1 [: `S LR d :]; `expr e2 [: :] :] :] - [: :] [: :] el k :] - | <:expr< while $e1$ do { $list:el$ } >> when old_sequences.val -> - fun curr next _ k -> - [: `BEbox - [: `BEbox [: `S LR "while"; `expr e1 [: :]; `S LR "do" :]; - `HVbox - [: `HVbox [: :]; - list (fun e k -> expr e [: `S RO ";"; k :]) el - [: :] :]; - `HVbox [: `S LR "done"; k :] :] :] - | <:expr< while $e1$ do { $list:el$ } >> -> - fun curr next _ k -> - [: `sequence [: `S LR "while"; `expr e1 [: :] :] [: :] [: :] el - k :] - | e -> fun curr next _ k -> [: `next e "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:expr< $x$ := $y$ >> -> - fun curr next _ k -> [: `next x "" [: `S LR ":=" :]; `expr y k :] - | e -> fun curr next _ k -> [: `next e "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox [: `HVbox [: :]; x :]; - pr_rules = - extfun Extfun.empty with - [ <:expr< $lid:"||"$ $x$ $y$ >> -> - fun curr next _ k -> [: `next x "" [: `S LR "||" :]; curr y "" k :] - | <:expr< $lid:"or"$ $x$ $y$ >> -> - fun curr next _ k -> [: `next x "" [: `S LR "||" :]; curr y "" k :] - | e -> fun curr next _ k -> [: `next e "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox [: `HVbox [: :]; x :]; - pr_rules = - extfun Extfun.empty with - [ <:expr< $lid:"&&"$ $x$ $y$ >> -> - fun curr next _ k -> [: `next x "" [: `S LR "&&" :]; curr y "" k :] - | <:expr< $lid:"&"$ $x$ $y$ >> -> - fun curr next _ k -> [: `next x "" [: `S LR "&&" :]; curr y "" k :] - | e -> fun curr next _ k -> [: `next e "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:expr< $lid:op$ $x$ $y$ >> as e -> - fun curr next _ k -> - match op with - [ "<" | ">" | "<=" | ">=" | ">=." | "=" | "<>" | "==" | "!=" -> - [: curr x "" [: `S LR op :]; `next y "" k :] - | _ -> [: `next e "" k :] ] - | e -> fun curr next _ k -> [: `next e "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:expr< $lid:op$ $x$ $y$ >> as e -> - fun curr next _ k -> - match op with - [ "^" | "@" -> [: `next x "" [: `S LR op :]; curr y "" k :] - | _ -> [: `next e "" k :] ] - | e -> fun curr next _ k -> [: `next e "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:expr< $lid:op$ $x$ $y$ >> as e -> - fun curr next _ k -> - match op with - [ "+" | "+." | "-" | "-." -> - [: curr x "" [: `S LR op :]; `next y "" k :] - | _ -> [: `next e "" k :] ] - | e -> fun curr next _ k -> [: `next e "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:expr< $lid:op$ $x$ $y$ >> as e -> - fun curr next _ k -> - match op with - [ "*" | "/" | "*." | "/." | "land" | "lor" | "lxor" | "mod" -> - [: curr x "" [: `S LR op :]; `next y "" k :] - | _ -> [: `next e "" k :] ] - | e -> fun curr next _ k -> [: `next e "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:expr< $lid:op$ $x$ $y$ >> as e -> - fun curr next _ k -> - match op with - [ "**" | "asr" | "lsl" | "lsr" -> - [: `next x "" [: `S LR op :]; curr y "" k :] - | _ -> [: `next e "" k :] ] - | e -> fun curr next _ k -> [: `next e "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:expr< $lid:"~-"$ $x$ >> -> - fun curr next _ k -> [: `S LR "-"; curr x "" k :] - | <:expr< $lid:"~-."$ $x$ >> -> - fun curr next _ k -> [: `S LR "-."; curr x "" k :] - | e -> fun curr next _ k -> [: `next e "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:expr< $int:x$ >> -> fun curr next _ k -> [: `S LR x; k :] - | MLast.ExInt32 _ x -> fun curr next _ k -> [: `S LR (x^"l"); k :] - | MLast.ExInt64 _ x -> fun curr next _ k -> [: `S LR (x^"L"); k :] - | MLast.ExNativeInt _ x -> fun curr next _ k -> [: `S LR (x^"n"); k :] - | e -> fun curr next _ k -> [: `next e "" k :] ]}; - {pr_label = "apply"; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:expr< [$_$ :: $_$] >> as e -> - fun curr next _ k -> [: `next e "" k :] - | <:expr< lazy ($x$) >> -> - fun curr next _ k -> [: `S LR "lazy"; `next x "" k :] - | <:expr< assert False >> -> - fun curr next _ k -> [: `S LR "assert"; `S LR "False"; k :] - | <:expr< assert ($e$) >> -> - fun curr next _ k -> [: `S LR "assert"; `next e "" k :] - | <:expr< $lid:n$ $x$ $y$ >> as e -> - fun curr next _ k -> - if is_infix n then [: `next e "" k :] - else [: curr <:expr< $lid:n$ $x$ >> "" [: :]; `next y "" k :] - | <:expr< $x$ $y$ >> -> - fun curr next _ k -> [: curr x "" [: :]; `next y "" k :] - | <:expr< new $list:sl$ >> -> - fun curr next _ k -> [: `S LR "new"; `class_longident sl k :] - | e -> fun curr next _ k -> [: `next e "" k :] ]}; - {pr_label = "dot"; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:expr< $x$ . ( $y$ ) >> -> - fun curr next _ k -> - [: curr x "" [: :]; `S NO ".("; `expr y [: `S RO ")"; k :] :] - | <:expr< $x$ . [ $y$ ] >> -> - fun curr next _ k -> - [: curr x "" [: :]; `S NO ".["; `expr y [: `S RO "]"; k :] :] - | <:expr< $e1$ . $e2$ >> -> - fun curr next _ k -> [: curr e1 "" [: :]; `S NO "."; curr e2 "" k :] - | <:expr< $e$ # $lab$ >> -> - fun curr next _ k -> [: curr e "" [: :]; `S NO "#"; `label lab; k :] - | e -> fun curr next _ k -> [: `next e "" k :] ]}; - {pr_label = "simple"; - pr_box e x = LocInfo (MLast.loc_of_expr e) (HOVbox x); - pr_rules = - extfun Extfun.empty with - [ ( <:expr< $int:x$ >> | <:expr< $flo:x$ >> ) -> - fun curr next _ k -> - if x.[0] = '-' then [: `S LO "("; `S LR x; `S RO ")"; k :] - else [: `S LR x; k :] - | MLast. ExInt32 _ x -> - fun curr next _ k -> - let x = x^"l" in - if x.[0] = '-' then [: `S LO "("; `S LR x; `S RO ")"; k :] - else [: `S LR x; k :] - | MLast.ExInt64 _ x -> - fun curr next _ k -> - let x = x^"L" in - if x.[0] = '-' then [: `S LO "("; `S LR x; `S RO ")"; k :] - else [: `S LR x; k :] - | MLast.ExNativeInt _ x -> - fun curr next _ k -> - let x = x^"n" in - if x.[0] = '-' then [: `S LO "("; `S LR x; `S RO ")"; k :] - else [: `S LR x; k :] - | <:expr< $str:s$ >> -> - fun curr next _ k -> [: `S LR ("\"" ^ s ^ "\""); k :] - | <:expr< $chr:c$ >> -> - fun curr next _ k -> [: `S LR ("'" ^ c ^ "'"); k :] - | <:expr< $uid:s$ >> -> fun curr next _ k -> [: `S LR s; k :] - | <:expr< $lid:s$ >> -> - fun curr next _ k -> [: `S LR (var_escaped s); k :] - | <:expr< ` $i$ >> -> fun curr next _ k -> [: `S LR ("`" ^ i); k :] - | <:expr< ~ $i$ >> -> - fun curr next _ k -> [: `S LR ("~" ^ i); k :] - | <:expr< ~ $i$ : $e$ >> -> - fun curr next _ k -> [: `S LO ("~" ^ i ^ ":"); curr e "" k :] - | <:expr< ? $i$ >> -> - fun curr next _ k -> [: `S LR ("?" ^ i); k :] - | <:expr< ? $i$ : $e$ >> -> - fun curr next _ k -> [: `S LO ("?" ^ i ^ ":"); curr e "" k :] - | <:expr< [$_$ :: $_$] >> as e -> - fun curr next _ k -> - let (el, c) = - make_list e where rec make_list e = - match e with - [ <:expr< [$e$ :: $y$] >> -> - let (el, c) = make_list y in - ([e :: el], c) - | <:expr< [] >> -> ([], None) - | x -> ([], Some e) ] - in - match c with - [ None -> - [: `S LO "["; listws expr (S RO ";") el [: `S RO "]"; k :] :] - | Some x -> - [: `S LO "["; listws expr (S RO ";") el [: `S LR "::" :]; - `expr x [: `S RO "]"; k :] :] ] - | <:expr< [| $list:el$ |] >> -> - fun curr next _ k -> - [: `S LR "[|"; listws expr (S RO ";") el [: `S LR "|]"; k :] :] - | <:expr< { $list:fel$ } >> -> - fun curr next _ k -> - [: `S LO "{"; - listws - (fun (lab, e) k -> - HVbox [: let_binding0 [: `patt lab [: :] :] e k :]) - (S RO ";") fel [: `S RO "}"; k :] :] - | <:expr< { ($e$) with $list:fel$ } >> -> - fun curr next _ k -> - [: `HVbox - [: `S LO "{"; `S LO "("; - `expr e [: `S RO ")"; `S LR "with" :] :]; - listws - (fun (lab, e) k -> - HVbox [: `patt lab [: `S LR "=" :]; `expr e k :]) - (S RO ";") fel [: `S RO "}"; k :] :] - | <:expr< ($e$ : $t$) >> -> - fun curr next _ k -> - [: `S LO "("; `expr e [: `S LR ":" :]; - `ctyp t [: `S RO ")"; k :] :] - | <:expr< ($e$ : $t1$ :> $t2$) >> -> - fun curr next _ k -> - [: `S LO "("; `expr e [: `S LR ":" :]; `ctyp t1 [: `S LR ":>" :]; - `ctyp t2 [: `S RO ")"; k :] :] - | <:expr< ($e$ :> $t2$) >> -> - fun curr next _ k -> - [: `S LO "("; `expr e [: `S LR ":>" :]; - `ctyp t2 [: `S RO ")"; k :] :] - | <:expr< {< >} >> -> fun curr next _ k -> [: `S LR "{< >}"; k :] - | <:expr< {< $list:fel$ >} >> -> - fun curr next _ k -> - [: `S LR "{<"; - listws field_expr (S RO ";") fel [: `S LR ">}"; k :] :] - | <:expr< ($list:el$) >> -> - fun curr next _ k -> - [: `S LO "("; listws expr (S RO ",") el [: `S RO ")"; k :] :] - | <:expr< $_$ $_$ >> | <:expr< $_$ . $_$ >> | <:expr< $_$ . ( $_$ ) >> | - <:expr< $_$ . [ $_$ ] >> | <:expr< $_$ := $_$ >> | - <:expr< $_$ # $_$ >> | - <:expr< fun [ $list:_$ ] >> | <:expr< match $_$ with [ $list:_$ ] >> | - <:expr< try $_$ with [ $list:_$ ] >> | - <:expr< if $_$ then $_$ else $_$ >> | <:expr< do { $list:_$ } >> | - <:expr< for $_$ = $_$ $to:_$ $_$ do { $list:_$ } >> | - <:expr< while $_$ do { $list:_$ } >> | - <:expr< let $opt:_$ $list:_$ in $_$ >> | - <:expr< let module $_$ = $_$ in $_$ >> | - <:expr< new $list:_$ >> as e -> - fun curr next _ k -> - [: `S LO "("; `expr e [: `HVbox [: `S RO ")"; k :] :] :] - | e -> fun curr next _ k -> [: `not_impl "expr" e :] ]}]; - -pr_patt.pr_levels := - [{pr_label = "top"; - pr_box p x = LocInfo (MLast.loc_of_patt p) (HOVbox [: `HVbox [: :]; x :]); - pr_rules = - extfun Extfun.empty with - [ <:patt< $x$ | $y$ >> -> - fun curr next _ k -> [: curr x "" [: `S LR "|" :]; `next y "" k :] - | p -> fun curr next _ k -> [: `next p "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox [: `HVbox [: :]; x :]; - pr_rules = - extfun Extfun.empty with - [ <:patt< $x$ .. $y$ >> -> - fun curr next _ k -> [: curr x "" [: `S NO ".." :]; `next y "" k :] - | p -> fun curr next _ k -> [: `next p "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:patt< [$_$ :: $_$] >> as p -> - fun curr next _ k -> [: `next p "" k :] - | <:patt< $x$ $y$ >> -> - fun curr next _ k -> [: curr x "" [: :]; `next y "" k :] - | p -> fun curr next _ k -> [: `next p "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:patt< $x$ . $y$ >> -> - fun curr next _ k -> [: curr x "" [: `S NO "." :]; `next y "" k :] - | p -> fun curr next _ k -> [: `next p "" k :] ]}; - {pr_label = "simple"; - pr_box p x = LocInfo (MLast.loc_of_patt p) (HOVbox x); - pr_rules = - extfun Extfun.empty with - [ <:patt< [$_$ :: $_$] >> as p -> - fun curr next _ k -> - let (pl, c) = - make_list p where rec make_list p = - match p with - [ <:patt< [$p$ :: $y$] >> -> - let (pl, c) = make_list y in - ([p :: pl], c) - | <:patt< [] >> -> ([], None) - | x -> ([], Some p) ] - in - [: `HOVCbox - [: `S LO "["; - let rec glop pl k = - match pl with - [ [] -> failwith "simple_patt" - | [p] -> - match c with - [ None -> [: `patt p k :] - | Some x -> - [: `patt p [: `S LR "::" :]; `patt x k :] ] - | [p :: pl] -> - [: `patt p [: `S RO ";" :]; glop pl k :] ] - in - glop pl [: `S RO "]"; k :] :] :] - | <:patt< [| $list:pl$ |] >> -> - fun curr next _ k -> - [: `S LR "[|"; listws patt (S RO ";") pl [: `S LR "|]"; k :] :] - | <:patt< { $list:fpl$ } >> -> - fun curr next _ k -> - [: `HVbox - [: `S LO "{"; - listws - (fun (lab, p) k -> - HVbox [: `patt lab [: `S LR "=" :]; `patt p k :]) - (S RO ";") fpl [: `S RO "}"; k :] :] :] - | <:patt< ($list:[p::pl]$) >> -> - fun curr next _ k -> - [: `HOVCbox - [: `S LO "("; - listws patt (S RO ",") [p :: pl] [: `S RO ")"; k :] :] :] - | <:patt< ($p$ : $ct$) >> -> - fun curr next _ k -> - [: `S LO "("; `patt p [: `S LR ":" :]; - `ctyp ct [: `S RO ")"; k :] :] - | <:patt< ($x$ as $y$) >> -> - fun curr next _ k -> - [: `S LO "("; `patt x [: `S LR "as" :]; - `patt y [: `S RO ")"; k :] :] - | ( <:patt< $int:s$ >> | <:patt< $flo:s$ >> ) -> - fun curr next _ k -> [: `S LR s; k :] - | MLast.PaInt32 _ s -> fun curr next _ k -> [: `S LR (s^"l"); k :] - | MLast.PaInt64 _ s -> fun curr next _ k -> [: `S LR (s^"L"); k :] - | MLast.PaNativeInt _ s -> fun curr next _ k -> [: `S LR (s^"n"); k :] - | <:patt< $str:s$ >> -> - fun curr next _ k -> [: `S LR ("\"" ^ s ^ "\""); k :] - | <:patt< $chr:c$ >> -> - fun curr next _ k -> [: `S LR ("'" ^ c ^ "'"); k :] - | <:patt< $lid:s$ >> -> - fun curr next _ k -> [: `S LR (var_escaped s); k :] - | <:patt< $uid:s$ >> -> fun curr next _ k -> [: `S LR s; k :] - | <:patt< ` $i$ >> -> fun curr next _ k -> [: `S LR ("`" ^ i); k :] - | <:patt< # $list:sl$ >> -> - fun curr next _ k -> [: `S LO "#"; mod_ident sl k :] - | <:patt< ~ $i$ >> -> - fun curr next _ k -> [: `S LR ("~" ^ i); k :] - | <:patt< ~ $i$ : $p$ >> -> - fun curr next _ k -> [: `S LO ("~" ^ i ^ ":"); curr p "" k :] - | <:patt< ? $i$ >> -> - fun curr next _ k -> [: `S LR ("?" ^ i); k :] - | <:patt< ? $i$ : ($p$ : $t$) >> -> - fun curr next _ k -> - [: `S LO ("?" ^ i ^ ":"); `S LO "("; `patt p [: `S LR ":" :]; - `ctyp t [: `S RO ")"; k :] :] - | <:patt< ? $i$ : ($p$) >> -> - fun curr next _ k -> - if i = "" then [: `S LO "?"; curr p "" k :] - else - [: `S LO ("?" ^ i ^ ":"); `S LO "("; - `patt p [: `S RO ")"; k :] :] - | <:patt< ? $i$ : ($p$ : $t$ = $e$) >> -> - fun curr next _ k -> - if i = "" then - [: `S LO "?"; `S LO "("; `patt p [: `S LR ":" :]; - `ctyp t [: `S LR "=" :]; `expr e [: `S RO ")"; k :] :] - else - [: `S LO ("?" ^ i ^ ":"); `S LO "("; `patt p [: `S LR ":" :]; - `ctyp t [: `S LR "=" :]; `expr e [: `S RO ")"; k :] :] - | <:patt< ? $i$ : ($p$ = $e$) >> -> - fun curr next _ k -> - if i = "" then - [: `S LO "?"; `S LO "("; `patt p [: `S LR "=" :]; - `expr e [: `S RO ")"; k :] :] - else - [: `S LO ("?" ^ i ^ ":"); `S LO "("; `patt p [: `S LR "=" :]; - `expr e [: `S RO ")"; k :] :] - | <:patt< _ >> -> fun curr next _ k -> [: `S LR "_"; k :] - | <:patt< $_$ $_$ >> | <:patt< $_$ .. $_$ >> | - <:patt< $_$ | $_$ >> as p -> - fun curr next _ k -> - [: `S LO "("; `patt p [: `HVbox [: `S RO ")"; k :] :] :] - | p -> fun curr next _ k -> [: `next p "" k :] ]}]; - -pr_ctyp.pr_levels := - [{pr_label = "top"; pr_box t x = LocInfo (MLast.loc_of_ctyp t) (HOVbox x); - pr_rules = - extfun Extfun.empty with - [ <:ctyp< $t1$ == $t2$ >> -> - fun curr next _ k -> - [: curr t1 "" [: `S LR "==" :]; `next t2 "" k :] - | t -> fun curr next _ k -> [: `next t "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:ctyp< $x$ as $y$ >> -> - fun curr next _ k -> [: curr x "" [: `S LR "as" :]; `next y "" k :] - | t -> fun curr next _ k -> [: `next t "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:ctyp< ! $list:pl$ . $t$ >> -> - fun curr next dg k -> - if pl = [] then [: `ctyp t k :] - else - [: `HVbox [: `S LR "!"; list typevar pl [: `S LR "." :] :]; - `ctyp t k :] - | t -> fun curr next _ k -> [: `next t "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:ctyp< $x$ -> $y$ >> -> - fun curr next _ k -> [: `next x "" [: `S LR "->" :]; curr y "" k :] - | t -> fun curr next _ k -> [: `next t "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:ctyp< $t1$ $t2$ >> -> - fun curr next _ k -> [: curr t1 "" [: :]; `next t2 "" k :] - | t -> fun curr next _ k -> [: `next t "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:ctyp< ? $lab$ : $t$ >> -> - fun curr next _ k -> - [: `S LO "?"; `S LR lab; `S RO ":"; `next t "" k :] - | <:ctyp< ~ $lab$ : $t$ >> -> - fun curr next _ k -> [: `S LO ("~" ^ lab ^ ":"); `next t "" k :] - | t -> fun curr next _ k -> [: `next t "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:ctyp< $t1$ . $t2$ >> -> - fun curr next _ k -> - [: curr t1 "" [: :]; `S NO "."; `next t2 "" k :] - | t -> fun curr next _ k -> [: `next t "" k :] ]}; - {pr_label = "simple"; - pr_box t x = LocInfo (MLast.loc_of_ctyp t) (HOVbox x); - pr_rules = - extfun Extfun.empty with - [ <:ctyp< ($list:tl$) >> -> - fun curr next _ k -> - [: `S LO "("; listws ctyp (S LR "*") tl [: `S RO ")"; k :] :] - | <:ctyp< '$s$ >> -> - fun curr next _ k -> [: `S LO "'"; `S LR (var_escaped s); k :] - | <:ctyp< $lid:s$ >> -> - fun curr next _ k -> [: `S LR (var_escaped s); k :] - | <:ctyp< $uid:s$ >> -> fun curr next _ k -> [: `S LR s; k :] - | <:ctyp< _ >> -> fun curr next _ k -> [: `S LR "_"; k :] - | <:ctyp< private { $list: ftl$ } >> as t -> - fun curr next _ k -> - let loc = MLast.loc_of_ctyp t in - [: `HVbox - [: `HVbox [:`S LR "private" :]; - `HVbox [: labels loc [:`S LR "{" :] - ftl [: `S LR "}" :] :]; - k :] :] - | <:ctyp< { $list: ftl$ } >> as t -> - fun curr next _ k -> - let loc = MLast.loc_of_ctyp t in - [: `HVbox - [: labels loc [: `S LR "{" :] ftl [: `S LR "}" :]; k :] :] - | <:ctyp< [ $list:ctl$ ] >> as t -> - fun curr next _ k -> - let loc = MLast.loc_of_ctyp t in - [: `Vbox - [: `HVbox [: :]; - variants loc [: `S LR "[" :] ctl [: `S LR "]" :]; k :] :] - | <:ctyp< private [ $list:ctl$ ] >> as t -> - fun curr next _ k -> - let loc = MLast.loc_of_ctyp t in - [: `Vbox - [: `HVbox [: `S LR "private" :]; - variants loc [: `S LR "[" :] ctl [: `S LR "]" :]; k :] :] - | <:ctyp< [ = $list:rfl$ ] >> -> - fun curr next _ k -> - [: `HVbox - [: `HVbox [: :]; - row_fields [: `S LR "[ =" :] rfl [: `S LR "]" :]; k :] :] - | <:ctyp< [ > $list:rfl$ ] >> -> - fun curr next _ k -> - [: `HVbox - [: `HVbox [: :]; - row_fields [: `S LR "[ >" :] rfl [: `S LR "]" :]; k :] :] - | <:ctyp< [ < $list:rfl$ > $list:sl$ ] >> -> - fun curr next _ k -> - let k1 = [: `S LR "]" :] in - let k1 = - match sl with - [ [] -> k1 - | l -> - [: `S LR ">"; - list (fun x k -> HVbox [: `S LR x; k :]) l k1 :] ] - in - [: `HVbox - [: `HVbox [: :]; row_fields [: `S LR "[ <" :] rfl k1; - k :] :] - | <:ctyp< # $list:id$ >> -> - fun curr next _ k -> [: `S LO "#"; `class_longident id k :] - | <:ctyp< < > >> -> fun curr next _ k -> [: `S LR "<>"; k :] - | <:ctyp< < $list:ml$ $opt:v$ > >> -> - fun curr next _ k -> - [: `S LR "<"; meth_list (ml, v) [: `S LR ">"; k :] :] - | <:ctyp< $_$ -> $_$ >> | <:ctyp< $_$ $_$ >> | <:ctyp< $_$ == $_$ >> | - <:ctyp< $_$ . $_$ >> | <:ctyp< $_$ as $_$ >> | - <:ctyp< ? $_$ : $_$ >> | <:ctyp< ~ $_$ : $_$ >> | - <:ctyp< ! $list:_$ . $_$ >> as t -> - fun curr next _ k -> - [: `S LO "("; `ctyp t [: `HVbox [: `S RO ")"; k :] :] :] - | t -> fun curr next _ k -> [: `next t "" k :] ]}]; - -pr_class_sig_item.pr_levels := - [{pr_label = "top"; - pr_box s x = LocInfo (MLast.loc_of_class_sig_item s) (HVbox x); - pr_rules = - extfun Extfun.empty with - [ <:class_sig_item< type $t1$ = $t2$ >> -> - fun curr next _ k -> - [: `S LR "type"; `ctyp t1 [: `S LR "=" :]; `ctyp t2 k :] - | <:class_sig_item< declare $list:s$ end >> -> - fun curr next _ k -> [: `HVbox [: :]; list class_sig_item s k :] - | <:class_sig_item< inherit $ce$ >> -> - fun curr next _ k -> [: `S LR "inherit"; `class_type ce k :] - | <:class_sig_item< method $lab$ : $t$ >> -> - fun curr next _ k -> - [: `HVbox - [: `S LR "method"; `label lab; `S LR ":" :]; - `ctyp t k :] - | <:class_sig_item< method private $lab$ : $t$ >> -> - fun curr next _ k -> - [: `HVbox - [: `S LR "method"; `S LR "private"; `label lab; - `S LR ":" :]; - `ctyp t k :] - | <:class_sig_item< value $opt:mf$ $lab$ : $t$ >> -> - fun curr next _ k -> - [: `HVbox - [: `S LR "value"; flag "mutable" mf; `label lab; - `S LR ":" :]; - `ctyp t k :] - | <:class_sig_item< method virtual $lab$ : $t$ >> -> - fun curr next _ k -> - [: `HVbox - [: `S LR "method"; `S LR "virtual"; `label lab; - `S LR ":" :]; - `ctyp t k :] - | <:class_sig_item< method virtual private $lab$ : $t$ >> -> - fun curr next _ k -> - [: `HVbox - [: `S LR "method"; `S LR "virtual"; `S LR "private"; - `label lab; `S LR ":" :]; - `ctyp t k :] - | csi -> fun curr next dg k -> [: `next csi "" k :] ]}]; - -pr_class_str_item.pr_levels := - [{pr_label = "top"; - pr_box s x = LocInfo (MLast.loc_of_class_str_item s) (HVbox x); - pr_rules = - extfun Extfun.empty with - [ MLast.CrDcl _ s -> - fun curr next _ k -> [: `HVbox [: :]; list class_str_item s [: :] :] - | MLast.CrInh _ ce pb -> - fun curr next _ k -> - [: `S LR "inherit"; `class_expr ce [: :]; - match pb with - [ Some i -> [: `S LR "as"; `S LR i :] - | _ -> [: :] ]; - k :] - | MLast.CrVal _ lab mf e -> - fun curr next _ k -> - [: `cvalue [: `S LR "value" :] (lab, mf, e) k :] - | MLast.CrVir _ lab pf t -> - fun curr next _ k -> - [: `S LR "method"; `S LR "virtual"; flag "private" pf; `label lab; - `S LR ":"; `ctyp t k :] - | MLast.CrMth _ lab pf fb None -> - fun curr next _ k -> - [: `fun_binding - [: `S LR "method"; flag "private" pf; `label lab :] fb k :] - | MLast.CrMth _ lab pf fb (Some t) -> - fun curr next dg k -> - [: `HOVbox - [: `S LR "method"; flag "private" pf; `label lab; `S LR ":"; - `ctyp t [: `S LR "=" :] :]; - `expr fb k :] - | MLast.CrCtr _ t1 t2 -> - fun curr next _ k -> - [: `HVbox [: `S LR "type"; `ctyp t1 [: `S LR "=" :] :]; - `ctyp t2 k :] - | MLast.CrIni _ se -> - fun curr next _ k -> [: `S LR "initializer"; `expr se k :] - | csi -> fun curr next dg k -> [: `next csi "" k :] ]}]; - -pr_class_type.pr_levels := - [{pr_label = "top"; pr_box s x = HVbox x; - pr_rules = - extfun Extfun.empty with - [ MLast.CtFun _ t ct -> - fun curr next _ k -> - [: `S LR "["; `ctyp t [: `S LR "]"; `S LR "->" :]; - `class_type ct k :] - | ct -> fun curr next _ k -> [: `class_signature ct k :] ]}]; - -pr_class_expr.pr_levels := - [{pr_label = "top"; pr_box s x = HVbox x; - pr_rules = - extfun Extfun.empty with - [ MLast.CeFun _ p ce -> - fun curr next _ k -> - [: `S LR "fun"; `simple_patt p [: `S LR "->" :]; - `class_expr ce k :] - | MLast.CeLet _ rf lb ce -> - fun curr next _ k -> - [: `Vbox - [: `HVbox [: :]; - `bind_list [: `S LR "let"; flag "rec" rf :] lb - [: `S LR "in" :]; - `class_expr ce k :] :] - | x -> fun curr next dg k -> [: `next x "" k :] ]}; - {pr_label = ""; pr_box s x = HVbox x; - pr_rules = - extfun Extfun.empty with - [ MLast.CeApp _ ce e -> - fun curr next _ k -> [: curr ce "" [: :]; `simple_expr e k :] - | x -> fun curr next dg k -> [: `next x "" k :] ]}; - {pr_label = ""; pr_box s x = HVbox x; - pr_rules = - extfun Extfun.empty with - [ MLast.CeCon _ ci [] -> - fun curr next _ k -> [: `class_longident ci k :] - | MLast.CeCon _ ci ctcl -> - fun curr next _ k -> - [: `class_longident ci [: :]; `S LO "["; - listws ctyp (S RO ",") ctcl [: `S RO "]"; k :] :] - | MLast.CeStr _ csp cf as ce -> - fun curr next _ k -> - let ep = snd (MLast.loc_of_class_expr ce) in - [: `BEbox - [: `HVbox [: `S LR "object"; `class_self_patt_opt csp :]; - `HVbox - [: `HVbox [: :]; list class_str_item cf [: :]; - `LocInfo (ep, ep) (HVbox [: :]) :]; - `HVbox [: `S LR "end"; k :] :] :] - | MLast.CeTyc _ ce ct -> - fun curr next _ k -> - [: `S LO "("; `class_expr ce [: `S LR ":" :]; - `class_type ct [: `S RO ")"; k :] :] - | MLast.CeFun _ _ _ as ce -> - fun curr next _ k -> - [: `S LO "("; `class_expr ce [: `S RO ")"; k :] :] - | ce -> fun curr next _ k -> [: `not_impl "class_expr" ce; k :] ]}]; - -value output_string_eval oc s = - loop 0 where rec loop i = - if i == String.length s then () - else if i == String.length s - 1 then output_char oc s.[i] - else - match (s.[i], s.[i + 1]) with - [ ('\\', 'n') -> do { output_char oc '\n'; loop (i + 2) } - | (c, _) -> do { output_char oc c; loop (i + 1) } ] -; - -value maxl = ref 78; -value sep = Pcaml.inter_phrases; -value ncip = ref True; - -value input_source ic len = - let buff = Buffer.create 20 in - try - let rec loop i = - if i >= len then Buffer.contents buff - else do { let c = input_char ic in Buffer.add_char buff c; loop (i + 1) } - in - loop 0 - with - [ End_of_file -> - let s = Buffer.contents buff in - if s = "" then - match sep.val with - [ Some s -> s - | None -> "\n" ] - else s ] -; - -value copy_source ic oc first bp ep = - match sep.val with - [ Some str -> - if first then () - else if ep == in_channel_length ic then output_string oc "\n" - else output_string_eval oc str - | None -> - do { - seek_in ic bp; - let s = input_source ic (ep - bp) in - output_string oc s - } ] -; - -value copy_to_end ic oc first bp = - let ilen = in_channel_length ic in - if bp < ilen then copy_source ic oc first bp ilen else output_string oc "\n" -; - -module Buff = - struct - value buff = ref (String.create 80); - value store len x = - do { - if len >= String.length buff.val then - buff.val := buff.val ^ String.create (String.length buff.val) - else (); - buff.val.[len] := x; - succ len - } - ; - value mstore len s = - add_rec len 0 where rec add_rec len i = - if i == String.length s then len - else add_rec (store len s.[i]) (succ i) - ; - value get len = String.sub buff.val 0 len; - end -; - -value extract_comment strm = - let rec find_comm nl_bef tab_bef = - parser - [ [: `'('; a = find_star nl_bef tab_bef :] -> a - | [: `' '; s :] -> find_comm nl_bef (tab_bef + 1) s - | [: `'\t'; s :] -> find_comm nl_bef (tab_bef + 8) s - | [: `'\n'; s :] -> find_comm (nl_bef + 1) 0 s - | [: `_; s :] -> find_comm 0 0 s - | [: :] -> ("", nl_bef, tab_bef) ] - and find_star nl_bef tab_bef = - parser - [ [: `'*'; a = insert (Buff.mstore 0 "(*") :] -> (a, nl_bef, tab_bef) - | [: a = find_comm 0 0 :] -> a ] - and insert len = - parser - [ [: `'*'; a = rparen (Buff.store len '*') :] -> a - | [: `'('; len = find_star2 (Buff.store len '('); s :] -> insert len s - | [: `'\t'; s :] -> insert (Buff.mstore len (String.make 8 ' ')) s - | [: `x; s :] -> insert (Buff.store len x) s - | [: :] -> "" ] - and rparen len = - parser - [ [: `')'; s :] -> while_space (Buff.store len ')') s - | [: a = insert len :] -> a ] - and while_space len = - parser - [ [: `' '; a = while_space (Buff.store len ' ') :] -> a - | [: `'\t'; a = while_space (Buff.mstore len (String.make 8 ' ')) :] -> a - | [: `'\n'; a = while_space (Buff.store len '\n') :] -> a - | [: `'('; a = find_star_again len :] -> a - | [: :] -> Buff.get len ] - and find_star_again len = - parser - [ [: `'*'; a = insert (Buff.mstore len "(*") :] -> a - | [: :] -> Buff.get len ] - and find_star2 len = - parser - [ [: `'*'; a = insert2 (Buff.store len '*') :] -> a - | [: :] -> len ] - and insert2 len = - parser - [ [: `'*'; a = rparen2 (Buff.store len '*') :] -> a - | [: `'('; len = find_star2 (Buff.store len '('); s :] -> insert2 len s - | [: `x; s :] -> insert2 (Buff.store len x) s - | [: :] -> 0 ] - and rparen2 len = - parser - [ [: `')' :] -> Buff.store len ')' - | [: a = insert2 len :] -> a ] - in - find_comm 0 0 strm -; - -value get_no_comment _ _ = ("", 0, 0, 0); - -value get_comment ic beg len = - do { - seek_in ic beg; - let strm = - Stream.from (fun i -> if i >= len then None else Some (input_char ic)) - in - let (s, nl_bef, tab_bef) = extract_comment strm in - (s, nl_bef, tab_bef, Stream.count strm) - } -; - -value apply_printer printer ast = - let oc = - match Pcaml.output_file.val with - [ Some f -> open_out_bin f - | None -> stdout ] - in - let cleanup () = - match Pcaml.output_file.val with - [ Some _ -> close_out oc - | None -> () ] - in - let pr_ch = output_char oc in - let pr_str = output_string oc in - let pr_nl () = output_char oc '\n' in - if Pcaml.input_file.val <> "-" && Pcaml.input_file.val <> "" then do { - let ic = open_in_bin Pcaml.input_file.val in - let getcom = - if not ncip.val && sep.val = None then get_comment ic - else get_no_comment - in - try - let (first, last_pos) = - List.fold_left - (fun (first, last_pos) (si, (bp, ep)) -> - do { - copy_source ic oc first last_pos bp; - flush oc; - print_pretty pr_ch pr_str pr_nl "" "" maxl.val getcom bp - (printer si [: :]); - flush oc; - (False, ep) - }) - (True, 0) ast - in - do { copy_to_end ic oc first last_pos; flush oc } - with x -> - do { close_in ic; cleanup (); raise x }; - close_in ic; - cleanup () - } - else do { - List.iter - (fun (si, _) -> - do { - print_pretty pr_ch pr_str pr_nl "" "" maxl.val get_no_comment 0 - (printer si [: :]); - match sep.val with - [ Some str -> output_string_eval oc str - | None -> output_char oc '\n' ]; - flush oc - }) - ast; - cleanup () - } -; - -Pcaml.print_interf.val := apply_printer sig_item; -Pcaml.print_implem.val := apply_printer str_item; - -Pcaml.add_option "-l" (Arg.Int (fun x -> maxl.val := x)) - " Maximum line length for pretty printing."; - -Pcaml.add_option "-sep_src" (Arg.Unit (fun () -> sep.val := None)) - "Read source file for text between phrases (default)."; - -Pcaml.add_option "-sep" (Arg.String (fun x -> sep.val := Some x)) - " Use this string between phrases instead of reading source."; - -Pcaml.add_option "-no_where" (Arg.Clear gen_where) - "Dont generate \"where\" statements"; - -Pcaml.add_option "-cip" (Arg.Clear ncip) "Add comments in phrases."; - -Pcaml.add_option "-ncip" (Arg.Set ncip) "No comments in phrases (default)."; - -Pcaml.add_option "-old_seq" (Arg.Set old_sequences) - "Pretty print with old syntax for sequences."; - -Pcaml.add_option "-exp_dcl" (Arg.Set expand_declare) - "Expand the \"declare\" items."; - -Pcaml.add_option "-tc" (Arg.Clear ncip) - "Deprecated since version 3.05; equivalent to -cip."; diff --git a/camlp4/etc/pr_rp.ml b/camlp4/etc/pr_rp.ml deleted file mode 100644 index 3487165e9f..0000000000 --- a/camlp4/etc/pr_rp.ml +++ /dev/null @@ -1,504 +0,0 @@ -(* camlp4r q_MLast.cmo ./pa_extfun.cmo *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1998 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -open Pcaml; -open Spretty; - -value loc = (0, 0); - -value expr e dg k = pr_expr.pr_fun "top" e dg k; -value patt e dg k = pr_patt.pr_fun "top" e dg k; - -(* Streams *) - -value stream e dg k = - let rec get = - fun - [ <:expr< Stream.iapp $x$ $y$ >> -> [(False, x) :: get y] - | <:expr< Stream.icons $x$ $y$ >> -> [(True, x) :: get y] - | <:expr< Stream.ising $x$ >> -> [(True, x)] - | <:expr< Stream.lapp (fun _ -> $x$) $y$ >> -> [(False, x) :: get y] - | <:expr< Stream.lcons (fun _ -> $x$) $y$ >> -> [(True, x) :: get y] - | <:expr< Stream.lsing (fun _ -> $x$) >> -> [(True, x)] - | <:expr< Stream.sempty >> -> [] - | <:expr< Stream.slazy (fun _ -> $x$) >> -> [(False, x)] - | <:expr< Stream.slazy $x$ >> -> [(False, <:expr< $x$ () >>)] - | e -> [(False, e)] ] - in - let elem e k = - match e with - [ (True, e) -> [: `HOVbox [: `S LO "`"; `expr e "" k :] :] - | (False, e) -> [: `expr e "" k :] ] - in - let rec glop e k = - match e with - [ [] -> k - | [e] -> [: elem e k :] - | [e :: el] -> [: elem e [: `S RO ";" :]; glop el k :] ] - in - HOVbox [: `S LR "[:"; glop (get e) [: `S LR ":]"; k :] :] -; - -(* Parsers *) - -type spc = - [ SPCterm of (MLast.patt * option MLast.expr) - | SPCnterm of MLast.patt and MLast.expr - | SPCsterm of MLast.patt ] -; - -exception NotImpl; - -value rec subst v e = - match e with - [ <:expr< $lid:x$ >> -> if x = "strm__" then <:expr< $lid:v$ >> else e - | <:expr< $uid:_$ >> -> e - | <:expr< $int:_$ >> -> e - | <:expr< $chr:_$ >> -> e - | <:expr< $str:_$ >> -> e - | <:expr< $e1$ . $lab$ >> -> <:expr< $subst v e1$ . $lab$ >> - | <:expr< $x$ $y$ >> -> <:expr< $subst v x$ $subst v y$ >> - | <:expr< let $lid:s1$ = $e1$ in $e2$ >> -> - if s1 = v then <:expr< let $lid:s1$ = $subst v e1$ in $e2$ >> - else <:expr< let $lid:s1$ = $subst v e1$ in $subst v e2$ >> - | <:expr< let _ = $e1$ in $e2$ >> -> - <:expr< let _ = $subst v e1$ in $subst v e2$ >> - | <:expr< ($list:el$) >> -> <:expr< ($list:List.map (subst v) el$) >> - | _ -> raise NotImpl ] -; - -value rec is_free v = - fun - [ <:expr< $lid:x$ >> -> x <> v - | <:expr< $uid:_$ >> -> True - | <:expr< $int:_$ >> -> True - | <:expr< $chr:_$ >> -> True - | <:expr< $str:_$ >> -> True - | <:expr< $e$ . $_$ >> -> is_free v e - | <:expr< $x$ $y$ >> -> is_free v x && is_free v y - | <:expr< let $lid:s1$ = $e1$ in $e2$ >> -> - is_free v e1 && (s1 = v || is_free v e2) - | <:expr< let _ = $e1$ in $e2$ >> -> is_free v e1 && is_free v e2 - | <:expr< ($list:el$) >> -> List.for_all (is_free v) el - | _ -> raise NotImpl ] -; - -value gensym = - let cnt = ref 0 in - fun () -> - do { incr cnt; "pr_rp_symb_" ^ string_of_int cnt.val } -; - -value free_var_in_expr c e = - let rec loop_alpha v = - let x = String.make 1 v in - if is_free x e then Some x - else if v = 'z' then None - else loop_alpha (Char.chr (Char.code v + 1)) - in - let rec loop_count cnt = - let x = String.make 1 c ^ string_of_int cnt in - if is_free x e then x else loop_count (succ cnt) - in - try - match loop_alpha c with - [ Some v -> v - | None -> loop_count 1 ] - with - [ NotImpl -> gensym () ] -; - -value parserify = - fun - [ <:expr< $e$ strm__ >> -> e - | e -> <:expr< fun strm__ -> $e$ >> ] -; - -value is_raise_failure = - fun - [ <:expr< raise Stream.Failure >> -> True - | _ -> False ] -; - -value is_raise_error = - fun - [ <:expr< raise (Stream.Error $_$) >> -> True - | _ -> False ] -; - -value semantic e = - try - if is_free "strm__" e then e - else - let v = free_var_in_expr 's' e in - <:expr< let $lid:v$ = strm__ in $subst v e$ >> - with - [ NotImpl -> e ] -; - -value rewrite_parser = - rewrite True where rec rewrite top ge = - match ge with - [ <:expr< let $p$ = try $e$ with [ Stream.Failure -> raise $exc$ ] in - $sp_kont$ >> -> - let f = parserify e in - <:expr< - match try Some ($f$ strm__) with [ Stream.Failure -> None ] with - [ Some $p$ -> $rewrite False sp_kont$ - | _ -> raise $exc$ ] - >> - | <:expr< let $p$ = Stream.count strm__ in $f$ >> -> - try - if is_free "strm__" f then ge - else - let v = free_var_in_expr 's' f in - <:expr< - let $lid:v$ = strm__ in - let $p$ = Stream.count strm__ in $subst v f$ - >> - with - [ NotImpl -> ge ] - | <:expr< let $p$ = strm__ in $e$ >> -> - <:expr< let $p$ = strm__ in $rewrite False e$ >> - | <:expr< let $p$ = $f$ strm__ in $sp_kont$ >> when top -> - <:expr< - match try Some ($f$ strm__) with [ Stream.Failure -> None ] with - [ Some $p$ -> $rewrite False sp_kont$ - | _ -> raise Stream.Failure ] - >> - | <:expr< let $p$ = $e$ in $sp_kont$ >> -> - if match e with - [ <:expr< match try Some $_$ with [ Stream.Failure -> None ] with - [ $list:_$ ] >> - | <:expr< match Stream.peek strm__ with [ $list:_$ ] >> - | <:expr< try $_$ with [ Stream.Failure -> $_$ ] >> - | <:expr< let $_$ = Stream.count strm__ in $_$ >> -> True - | _ -> False ] - then - let f = rewrite True <:expr< fun strm__ -> $e$ >> in - let exc = - if top then <:expr< Stream.Failure >> - else <:expr< Stream.Error "" >> - in - <:expr< - match try Some ($f$ strm__) with [ Stream.Failure -> None ] with - [ Some $p$ -> $rewrite False sp_kont$ - | _ -> raise $exc$ ] - >> - else semantic ge - | <:expr< match try Some $e$ with [ Stream.Failure -> None ] with - [ Some $p$ -> $sp_kont$ - | _ -> $p_kont$ ] >> -> - let f = parserify e in - if not top && is_raise_failure p_kont then semantic ge - else - let (p, f, sp_kont, p_kont) = - if top || is_raise_error p_kont then - (p, f, rewrite False sp_kont, rewrite top p_kont) - else - let f = - <:expr< - fun strm__ -> - match - try Some ($f$ strm__) with [ Stream.Failure -> None ] - with - [ Some $p$ -> $rewrite False sp_kont$ - | _ -> $rewrite top p_kont$ ] - >> - in - (<:patt< a >>, f, <:expr< a >>, - <:expr< raise (Stream.Error "") >>) - in - <:expr< - match try Some ($f$ strm__) with [ Stream.Failure -> None ] with - [ Some $p$ -> $sp_kont$ - | _ -> $p_kont$ ] - >> - | <:expr< match Stream.peek strm__ with [ $list:pel$ ] >> -> - let rec iter pel = - match pel with - [ [(<:patt< Some $p$ >>, eo, - <:expr< do { Stream.junk strm__; $sp_kont$ } >>); - (<:patt< _ >>, None, p_kont) :: _] -> - <:expr< - match Stream.peek strm__ with - [ Some $p$ $when:eo$ -> - do { Stream.junk strm__; $rewrite False sp_kont$ } - | _ -> $rewrite top p_kont$ ] - >> - | [(<:patt< Some $p$ >>, eo, - <:expr< do { Stream.junk strm__; $sp_kont$ } >>) :: pel] -> - let p_kont = iter pel in - <:expr< - match Stream.peek strm__ with - [ Some $p$ $when:eo$ -> - do { Stream.junk strm__; $rewrite False sp_kont$ } - | _ -> $p_kont$ ] - >> - | _ -> - <:expr< match Stream.peek strm__ with [ $list:pel$ ] >> ] - in - iter pel - | <:expr< try Some $e$ with [ Stream.Failure -> $p_kont$ ] >> -> - let f = parserify e in - let e = - <:expr< - match try Some ($f$ strm__) with [ Stream.Failure -> None ] with - [ Some a -> Some a - | _ -> $p_kont$ ] - >> - in - rewrite top e - | <:expr< try $e$ with [ Stream.Failure -> $p_kont$ ] >> -> - let f = parserify e in - let e = - <:expr< - match try Some ($f$ strm__) with [ Stream.Failure -> None ] with - [ Some a -> a - | _ -> $rewrite top p_kont$ ] - >> - in - rewrite top e - | <:expr< $f$ strm__ >> -> - if top then - <:expr< - match try Some ($f$ strm__) with [ Stream.Failure -> None ] with - [ Some a -> a - | _ -> raise Stream.Failure ] - >> - else - let v = free_var_in_expr 's' f in - <:expr< let $lid:v$ = strm__ in $f$ $lid:v$ >> - | e -> semantic e ] -; - -value parser_of_expr = - let rec parser_cases e = - match e with - [ <:expr< - match try Some ($f$ strm__) with [ Stream.Failure -> None ] with - [ Some $p$ -> $sp_kont$ - | _ -> $p_kont$ ] - >> -> - let spc = (SPCnterm p f, None) in - let (sp, epo, e) = kont sp_kont in - [([spc :: sp], epo, e) :: parser_cases p_kont] - | <:expr< - match Stream.peek strm__ with - [ Some $p$ $when:wo$ -> do { Stream.junk strm__; $sp_kont$ } - | _ -> $p_kont$ ] - >> -> - let spc = (SPCterm (p, wo), None) in - let (sp, epo, e) = kont sp_kont in - [([spc :: sp], epo, e) :: parser_cases p_kont] - | <:expr< let $p$ = strm__ in $sp_kont$ >> -> - let spc = (SPCsterm p, None) in - let (sp, epo, e) = kont sp_kont in - [([spc :: sp], epo, e)] - | <:expr< let $p$ = Stream.count strm__ in $e$ >> -> [([], Some p, e)] - | <:expr< raise Stream.Failure >> -> [] - | _ -> [([], None, e)] ] - and kont e = - match e with - [ <:expr< - match try Some ($f$ strm__) with [ Stream.Failure -> None ] with - [ Some $p$ -> $sp_kont$ - | _ -> raise (Stream.Error $err$) ] - >> -> - let err = - match err with - [ <:expr< "" >> -> None - | _ -> Some err ] - in - let spc = (SPCnterm p f, err) in - let (sp, epo, e) = kont sp_kont in - ([spc :: sp], epo, e) - | <:expr< - match Stream.peek strm__ with - [ Some $p$ $when:wo$ -> do { Stream.junk strm__; $sp_kont$ } - | _ -> raise (Stream.Error $err$) ] - >> -> - let err = - match err with - [ <:expr< "" >> -> None - | _ -> Some err ] - in - let spc = (SPCterm (p, wo), err) in - let (sp, epo, e) = kont sp_kont in - ([spc :: sp], epo, e) - | <:expr< let $p$ = strm__ in $sp_kont$ >> -> - let spc = (SPCsterm p, None) in - let (sp, epo, e) = kont sp_kont in - ([spc :: sp], epo, e) - | <:expr< let $p$ = Stream.count strm__ in $e$ >> -> ([], Some p, e) - | _ -> ([], None, e) ] - in - parser_cases -; - -value parser_cases b spel k = - let rec parser_cases b spel k = - match spel with - [ [] -> [: `HVbox [: b; k :] :] - | [(sp, epo, e)] -> [: `parser_case b sp epo e k :] - | [(sp, epo, e) :: spel] -> - [: `parser_case b sp epo e [: :]; - parser_cases [: `S LR "|" :] spel k :] ] - and parser_case b sp epo e k = - let epo = - match epo with - [ Some p -> [: `patt p "" [: `S LR "->" :] :] - | _ -> [: `S LR "->" :] ] - in - HVbox - [: b; - `HOVbox - [: `HOVbox - [: `S LR "[:"; - stream_patt [: :] sp [: `S LR ":]"; epo :] :]; - `expr e "" k :] :] - and stream_patt b sp k = - match sp with - [ [] -> [: `HVbox [: b; k :] :] - | [(spc, None)] -> [: `stream_patt_comp b spc k :] - | [(spc, Some e)] -> - [: `HVbox - [: `stream_patt_comp b spc [: :]; - `HVbox [: `S LR "?"; `expr e "" k :] :] :] - | [(spc, None) :: spcl] -> - [: `stream_patt_comp b spc [: `S RO ";" :]; - stream_patt [: :] spcl k :] - | [(spc, Some e) :: spcl] -> - [: `HVbox - [: `stream_patt_comp b spc [: :]; - `HVbox [: `S LR "?"; `expr e "" [: `S RO ";" :] :] :]; - stream_patt [: :] spcl k :] ] - and stream_patt_comp b spc k = - match spc with - [ SPCterm (p, w) -> - HVbox [: b; `S LO "`"; `patt p "" [: :]; `HVbox [: when_opt w k :] :] - | SPCnterm p e -> - HVbox [: b; `HVbox [: `patt p "" [: `S LR "=" :]; `expr e "" k :] :] - | SPCsterm p -> HVbox [: b; `patt p "" k :] ] - and when_opt wo k = - match wo with - [ Some e -> [: `S LR "when"; `expr e "" k :] - | _ -> k ] - in - parser_cases b spel k -; - -value parser_body e dg k = - let (bp, e) = - match e with - [ <:expr< let $bp$ = Stream.count strm__ in $e$ >> -> (Some bp, e) - | e -> (None, e) ] - in - let e = rewrite_parser e in - match parser_of_expr e with - [ [] -> - HVbox - [: `HVbox - [: `S LR "parser"; - match bp with - [ Some p -> [: `patt p "" [: :] :] - | _ -> [: :] ] :]; - `HVbox [: `S LR "[]"; k :] :] - | [spe] -> - HVbox - [: `HVbox - [: `S LR "parser"; - match bp with - [ Some p -> [: `patt p "" [: :] :] - | _ -> [: :] ] :]; - parser_cases [: :] [spe] k :] - | spel -> - Vbox - [: `HVbox [: :]; - `HVbox - [: `S LR "parser"; - match bp with - [ Some p -> [: `patt p "" [: :] :] - | _ -> [: :] ] :]; - parser_cases [: `S LR "[" :] spel [: `S LR "]"; k :] :] ] -; - -value pmatch e dg k = - let (me, e) = - match e with - [ <:expr< let (strm__ : Stream.t _) = $me$ in $e$ >> -> (me, e) - | <:expr< match $_$ strm__ with [ $list:_$ ] >> -> (<:expr< strm__ >>, e) - | _ -> failwith "Pr_rp.pmatch" ] - in - let (bp, e) = - match e with - [ <:expr< let $bp$ = Stream.count strm__ in $e$ >> -> (Some bp, e) - | e -> (None, e) ] - in - let e = rewrite_parser e in - let spel = parser_of_expr e in - Vbox - [: `HVbox [: :]; - `HVbox - [: `S LR "match"; `expr me "" [: `S LR "with" :]; `S LR "parser"; - match bp with - [ Some p -> [: `patt p "" [: :] :] - | _ -> [: :] ] :]; - parser_cases [: `S LR "[" :] spel [: `S LR "]"; k :] :] -; - -(* Printer extensions *) - -pr_expr_fun_args.val := - extfun pr_expr_fun_args.val with - [ <:expr< fun strm__ -> $_$ >> as ge -> ([], ge) - | <:expr< fun [(strm__ : $_$) -> $_$] >> as ge -> ([], ge) ]; - -let lev = find_pr_level "top" pr_expr.pr_levels in -lev.pr_rules := - extfun lev.pr_rules with - [ <:expr< let (strm__ : Stream.t _) = $_$ in $_$ >> as e -> - fun curr next _ k -> [: `pmatch e "" k :] - | <:expr< match $_$ strm__ with [ $list:_$ ] >> as e -> - fun curr next _ k -> [: `pmatch e "" k :] - | <:expr< fun strm__ -> $x$ >> -> - fun curr next _ k -> [: `parser_body x "" k :] - | <:expr< fun (strm__ : $_$) -> $x$ >> -> - fun curr next _ k -> [: `parser_body x "" k :] ]; - -let lev = find_pr_level "apply" pr_expr.pr_levels in -lev.pr_rules := - extfun lev.pr_rules with - [ <:expr< Stream.iapp $_$ $_$ >> | <:expr< Stream.icons $_$ $_$ >> | - <:expr< Stream.ising $_$ >> | <:expr< Stream.lapp (fun _ -> $_$) $_$ >> | - <:expr< Stream.lcons (fun _ -> $_$) $_$ >> | - <:expr< Stream.lsing (fun _ -> $_$) >> | <:expr< Stream.sempty >> | - <:expr< Stream.slazy $_$ >> as e -> - fun curr next _ k -> [: `next e "" k :] ]; - -let lev = find_pr_level "dot" pr_expr.pr_levels in -lev.pr_rules := - extfun lev.pr_rules with - [ <:expr< Stream.sempty >> as e -> - fun curr next _ k -> [: `next e "" k :] ]; - -let lev = find_pr_level "simple" pr_expr.pr_levels in -lev.pr_rules := - extfun lev.pr_rules with - [ <:expr< Stream.iapp $_$ $_$ >> | <:expr< Stream.icons $_$ $_$ >> | - <:expr< Stream.ising $_$ >> | <:expr< Stream.lapp (fun _ -> $_$) $_$ >> | - <:expr< Stream.lcons (fun _ -> $_$) $_$ >> | - <:expr< Stream.lsing (fun _ -> $_$) >> | <:expr< Stream.sempty >> | - <:expr< Stream.slazy $_$ >> as e -> - fun curr next _ k -> [: `stream e "" k :] ]; diff --git a/camlp4/etc/pr_rp_main.ml b/camlp4/etc/pr_rp_main.ml deleted file mode 100644 index 11ad11af77..0000000000 --- a/camlp4/etc/pr_rp_main.ml +++ /dev/null @@ -1,206 +0,0 @@ -(* camlp4r q_MLast.cmo ./pa_extfun.cmo *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1998 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -open Pcaml; -open Spretty; - -value loc = (0, 0); - -value expr e dg k = pr_expr.pr_fun "top" e dg k; -value patt e dg k = pr_patt.pr_fun "top" e dg k; - -(* Streams *) - -value stream e dg k = - let rec get = - fun - [ <:expr< Stream.iapp $x$ $y$ >> -> [(False, x) :: get y] - | <:expr< Stream.icons $x$ $y$ >> -> [(True, x) :: get y] - | <:expr< Stream.ising $x$ >> -> [(True, x)] - | <:expr< Stream.lapp (fun _ -> $x$) $y$ >> -> [(False, x) :: get y] - | <:expr< Stream.lcons (fun _ -> $x$) $y$ >> -> [(True, x) :: get y] - | <:expr< Stream.lsing (fun _ -> $x$) >> -> [(True, x)] - | <:expr< Stream.sempty >> -> [] - | <:expr< Stream.slazy (fun _ -> $x$) >> -> [(False, x)] - | <:expr< Stream.slazy $x$ >> -> [(False, <:expr< $x$ () >>)] - | e -> [(False, e)] ] - in - let elem e k = - match e with - [ (True, e) -> [: `HOVbox [: `S LO "`"; `expr e "" k :] :] - | (False, e) -> [: `expr e "" k :] ] - in - let rec glop e k = - match e with - [ [] -> k - | [e] -> [: elem e k :] - | [e :: el] -> [: elem e [: `S RO ";" :]; glop el k :] ] - in - HOVbox [: `S LR "[:"; glop (get e) [: `S LR ":]"; k :] :] -; - -(* Parsers *) - -open Parserify; - -value parser_cases b spel k = - let rec parser_cases b spel k = - match spel with - [ [] -> [: `HVbox [: b; k :] :] - | [(sp, epo, e)] -> [: `parser_case b sp epo e k :] - | [(sp, epo, e) :: spel] -> - [: `parser_case b sp epo e [: :]; - parser_cases [: `S LR "|" :] spel k :] ] - and parser_case b sp epo e k = - let epo = - match epo with - [ Some p -> [: `patt p "" [: `S LR "->" :] :] - | _ -> [: `S LR "->" :] ] - in - HVbox - [: b; - `HOVbox - [: `HOVbox - [: `S LR "[:"; - stream_patt [: :] sp [: `S LR ":]"; epo :] :]; - `expr e "" k :] :] - and stream_patt b sp k = - match sp with - [ [] -> [: `HVbox [: b; k :] :] - | [(spc, None)] -> [: `stream_patt_comp b spc k :] - | [(spc, Some e)] -> - [: `HVbox - [: `stream_patt_comp b spc [: :]; - `HVbox [: `S LR "?"; `expr e "" k :] :] :] - | [(spc, None) :: spcl] -> - [: `stream_patt_comp b spc [: `S RO ";" :]; - stream_patt [: :] spcl k :] - | [(spc, Some e) :: spcl] -> - [: `HVbox - [: `stream_patt_comp b spc [: :]; - `HVbox [: `S LR "?"; `expr e "" [: `S RO ";" :] :] :]; - stream_patt [: :] spcl k :] ] - and stream_patt_comp b spc k = - match spc with - [ SPCterm (p, w) -> - HVbox [: b; `S LO "`"; `patt p "" [: :]; `HVbox [: when_opt w k :] :] - | SPCnterm p e -> - HVbox [: b; `HVbox [: `patt p "" [: `S LR "=" :]; `expr e "" k :] :] - | SPCsterm p -> HVbox [: b; `patt p "" k :] ] - and when_opt wo k = - match wo with - [ Some e -> [: `S LR "when"; `expr e "" k :] - | _ -> k ] - in - parser_cases b spel k -; - -value parser_body e dg k = - let (bp, e) = - match e with - [ <:expr< let $bp$ = Stream.count strm__ in $e$ >> -> (Some bp, e) - | e -> (None, e) ] - in - match parser_of_expr e with - [ [] -> - HVbox - [: `HVbox - [: `S LR "parser"; - match bp with - [ Some p -> [: `patt p "" [: :] :] - | _ -> [: :] ] :]; - `HVbox [: `S LR "[]"; k :] :] - | [spe] -> - HVbox - [: `HVbox - [: `S LR "parser"; - match bp with - [ Some p -> [: `patt p "" [: :] :] - | _ -> [: :] ] :]; - parser_cases [: :] [spe] k :] - | spel -> - Vbox - [: `HVbox [: :]; - `HVbox - [: `S LR "parser"; - match bp with - [ Some p -> [: `patt p "" [: :] :] - | _ -> [: :] ] :]; - parser_cases [: `S LR "[" :] spel [: `S LR "]"; k :] :] ] -; - -value pmatch e dg k = - let (me, e) = - match e with - [ <:expr< let (strm__ : Stream.t _) = $me$ in $e$ >> -> (me, e) - | _ -> failwith "Pr_rp.pmatch" ] - in - let (bp, e) = - match e with - [ <:expr< let $bp$ = Stream.count strm__ in $e$ >> -> (Some bp, e) - | e -> (None, e) ] - in - let spel = parser_of_expr e in - Vbox - [: `HVbox [: :]; - `HVbox - [: `S LR "match"; `expr me "" [: `S LR "with" :]; `S LR "parser"; - match bp with - [ Some p -> [: `patt p "" [: :] :] - | _ -> [: :] ] :]; - parser_cases [: `S LR "[" :] spel [: `S LR "]"; k :] :] -; - -(* Printer extensions *) - -pr_expr_fun_args.val := - extfun pr_expr_fun_args.val with - [ <:expr< fun strm__ -> $_$ >> as ge -> ([], ge) - | <:expr< fun [(strm__ : $_$) -> $_$] >> as ge -> ([], ge) ]; - -let lev = find_pr_level "top" pr_expr.pr_levels in -lev.pr_rules := - extfun lev.pr_rules with - [ <:expr< let (strm__ : Stream.t _) = $_$ in $_$ >> as e -> - fun curr next _ k -> [: `pmatch e "" k :] - | <:expr< fun strm__ -> $x$ >> -> - fun curr next _ k -> [: `parser_body x "" k :] - | <:expr< fun (strm__ : $_$) -> $x$ >> -> - fun curr next _ k -> [: `parser_body x "" k :] ]; - -let lev = find_pr_level "apply" pr_expr.pr_levels in -lev.pr_rules := - extfun lev.pr_rules with - [ <:expr< Stream.iapp $_$ $_$ >> | <:expr< Stream.icons $_$ $_$ >> | - <:expr< Stream.ising $_$ >> | <:expr< Stream.lapp (fun _ -> $_$) $_$ >> | - <:expr< Stream.lcons (fun _ -> $_$) $_$ >> | - <:expr< Stream.lsing (fun _ -> $_$) >> | <:expr< Stream.sempty >> | - <:expr< Stream.slazy $_$ >> as e -> - fun curr next _ k -> [: `next e "" k :] ]; - -let lev = find_pr_level "dot" pr_expr.pr_levels in -lev.pr_rules := - extfun lev.pr_rules with - [ <:expr< Stream.sempty >> as e -> - fun curr next _ k -> [: `next e "" k :] ]; - -let lev = find_pr_level "simple" pr_expr.pr_levels in -lev.pr_rules := - extfun lev.pr_rules with - [ <:expr< Stream.iapp $_$ $_$ >> | <:expr< Stream.icons $_$ $_$ >> | - <:expr< Stream.ising $_$ >> | <:expr< Stream.lapp (fun _ -> $_$) $_$ >> | - <:expr< Stream.lcons (fun _ -> $_$) $_$ >> | - <:expr< Stream.lsing (fun _ -> $_$) >> | <:expr< Stream.sempty >> | - <:expr< Stream.slazy $_$ >> as e -> - fun curr next _ k -> [: `stream e "" k :] ]; diff --git a/camlp4/etc/pr_scheme.ml b/camlp4/etc/pr_scheme.ml deleted file mode 100644 index a7c2309488..0000000000 --- a/camlp4/etc/pr_scheme.ml +++ /dev/null @@ -1,813 +0,0 @@ -(* camlp4r q_MLast.cmo ./pa_extfun.cmo *) -(* $Id$ *) - -open Pcaml; -open Format; - -type printer_t 'a = - { pr_fun : mutable string -> next 'a; - pr_levels : mutable list (pr_level 'a) } -and pr_level 'a = - { pr_label : string; - pr_box : formatter -> (formatter -> unit) -> 'a -> unit; - pr_rules : mutable pr_rule 'a } -and pr_rule 'a = - Extfun.t 'a (formatter -> curr 'a -> next 'a -> string -> kont -> unit) -and curr 'a = formatter -> ('a * string * kont) -> unit -and next 'a = formatter -> ('a * string * kont) -> unit -and kont = formatter -> unit; - -value not_impl name x ppf k = - let desc = - if Obj.is_block (Obj.repr x) then - "tag = " ^ string_of_int (Obj.tag (Obj.repr x)) - else "int_val = " ^ string_of_int (Obj.magic x) - in - fprintf ppf "%t" name desc k -; - -value pr_fun name pr lab = - loop False pr.pr_levels where rec loop app = - fun - [ [] -> fun ppf (x, dg, k) -> failwith ("unable to print " ^ name) - | [lev :: levl] -> - if app || lev.pr_label = lab then - let next = loop True levl in - let rec curr ppf (x, dg, k) = - Extfun.apply lev.pr_rules x ppf curr next dg k - in - fun ppf ((x, _, _) as n) -> lev.pr_box ppf (fun ppf -> curr ppf n) x - else loop app levl ] -; - -value rec find_pr_level lab = - fun - [ [] -> failwith ("level " ^ lab ^ " not found") - | [lev :: levl] -> - if lev.pr_label = lab then lev else find_pr_level lab levl ] -; - -value pr_constr_decl = {pr_fun = fun []; pr_levels = []}; -value constr_decl ppf (x, k) = pr_constr_decl.pr_fun "top" ppf (x, "", k); -pr_constr_decl.pr_fun := pr_fun "constr_decl" pr_constr_decl; - -value pr_ctyp = {pr_fun = fun []; pr_levels = []}; -pr_ctyp.pr_fun := pr_fun "ctyp" pr_ctyp; -value ctyp ppf (x, k) = pr_ctyp.pr_fun "top" ppf (x, "", k); - -value pr_expr = {pr_fun = fun []; pr_levels = []}; -pr_expr.pr_fun := pr_fun "expr" pr_expr; -value expr ppf (x, k) = pr_expr.pr_fun "top" ppf (x, "", k); - -value pr_label_decl = {pr_fun = fun []; pr_levels = []}; -value label_decl ppf (x, k) = pr_label_decl.pr_fun "top" ppf (x, "", k); -pr_label_decl.pr_fun := pr_fun "label_decl" pr_label_decl; - -value pr_let_binding = {pr_fun = fun []; pr_levels = []}; -pr_let_binding.pr_fun := pr_fun "let_binding" pr_let_binding; -value let_binding ppf (x, k) = pr_let_binding.pr_fun "top" ppf (x, "", k); - -value pr_match_assoc = {pr_fun = fun []; pr_levels = []}; -pr_match_assoc.pr_fun := pr_fun "match_assoc" pr_match_assoc; -value match_assoc ppf (x, k) = pr_match_assoc.pr_fun "top" ppf (x, "", k); - -value pr_mod_ident = {pr_fun = fun []; pr_levels = []}; -pr_mod_ident.pr_fun := pr_fun "mod_ident" pr_mod_ident; -value mod_ident ppf (x, k) = pr_mod_ident.pr_fun "top" ppf (x, "", k); - -value pr_module_binding = {pr_fun = fun []; pr_levels = []}; -pr_module_binding.pr_fun := pr_fun "module_binding" pr_module_binding; -value module_binding ppf (x, k) = - pr_module_binding.pr_fun "top" ppf (x, "", k); - -value pr_module_expr = {pr_fun = fun []; pr_levels = []}; -pr_module_expr.pr_fun := pr_fun "module_expr" pr_module_expr; -value module_expr ppf (x, k) = pr_module_expr.pr_fun "top" ppf (x, "", k); - -value pr_module_type = {pr_fun = fun []; pr_levels = []}; -pr_module_type.pr_fun := pr_fun "module_type" pr_module_type; -value module_type ppf (x, k) = pr_module_type.pr_fun "top" ppf (x, "", k); - -value pr_patt = {pr_fun = fun []; pr_levels = []}; -pr_patt.pr_fun := pr_fun "patt" pr_patt; -value patt ppf (x, k) = pr_patt.pr_fun "top" ppf (x, "", k); - -value pr_sig_item = {pr_fun = fun []; pr_levels = []}; -pr_sig_item.pr_fun := pr_fun "sig_item" pr_sig_item; -value sig_item ppf (x, k) = pr_sig_item.pr_fun "top" ppf (x, "", k); - -value pr_str_item = {pr_fun = fun []; pr_levels = []}; -pr_str_item.pr_fun := pr_fun "str_item" pr_str_item; -value str_item ppf (x, k) = pr_str_item.pr_fun "top" ppf (x, "", k); - -value pr_type_decl = {pr_fun = fun []; pr_levels = []}; -value type_decl ppf (x, k) = pr_type_decl.pr_fun "top" ppf (x, "", k); -pr_type_decl.pr_fun := pr_fun "type_decl" pr_type_decl; - -value pr_type_params = {pr_fun = fun []; pr_levels = []}; -value type_params ppf (x, k) = pr_type_params.pr_fun "top" ppf (x, "", k); -pr_type_params.pr_fun := pr_fun "type_params" pr_type_params; - -value pr_with_constr = {pr_fun = fun []; pr_levels = []}; -value with_constr ppf (x, k) = pr_with_constr.pr_fun "top" ppf (x, "", k); -pr_with_constr.pr_fun := pr_fun "with_constr" pr_with_constr; - -(* general functions *) - -value nok ppf = (); -value ks s k ppf = fprintf ppf "%s%t" s k; - -value rec list f ppf (l, k) = - match l with - [ [] -> k ppf - | [x] -> f ppf (x, k) - | [x :: l] -> fprintf ppf "%a@ %a" f (x, nok) (list f) (l, k) ] -; - -value rec listwb b f ppf (l, k) = - match l with - [ [] -> k ppf - | [x] -> f ppf ((b, x), k) - | [x :: l] -> fprintf ppf "%a@ %a" f ((b, x), nok) (listwb "" f) (l, k) ] -; - -(* specific functions *) - -value rec is_irrefut_patt = - fun - [ <:patt< $lid:_$ >> -> True - | <:patt< () >> -> True - | <:patt< _ >> -> True - | <:patt< ($x$ as $y$) >> -> is_irrefut_patt x && is_irrefut_patt y - | <:patt< { $list:fpl$ } >> -> - List.for_all (fun (_, p) -> is_irrefut_patt p) fpl - | <:patt< ($p$ : $_$) >> -> is_irrefut_patt p - | <:patt< ($list:pl$) >> -> List.for_all is_irrefut_patt pl - | <:patt< ? $_$ : ( $p$ ) >> -> is_irrefut_patt p - | <:patt< ? $_$ : ($p$ = $_$) >> -> is_irrefut_patt p - | <:patt< ~ $_$ >> -> True - | <:patt< ~ $_$ : $p$ >> -> is_irrefut_patt p - | _ -> False ] -; - -value expr_fun_args ge = Extfun.apply pr_expr_fun_args.val ge; - -pr_expr_fun_args.val := - extfun Extfun.empty with - [ <:expr< fun [$p$ -> $e$] >> as ge -> - if is_irrefut_patt p then - let (pl, e) = expr_fun_args e in - ([p :: pl], e) - else ([], ge) - | ge -> ([], ge) ]; - -value sequence ppf (e, k) = - match e with - [ <:expr< do { $list:el$ } >> -> - fprintf ppf "@[%a@]" (list expr) (el, k) - | _ -> expr ppf (e, k) ] -; - -value string ppf (s, k) = fprintf ppf "\"%s\"%t" s k; - -value int_repr s = - if String.length s > 2 && s.[0] = '0' then - match s.[1] with - [ 'b' | 'o' | 'x' | 'B' | 'O' | 'X' -> - "#" ^ String.sub s 1 (String.length s - 1) - | _ -> s ] - else s -; - -value assoc_left_parsed_op_list = ["+"; "*"; "land"; "lor"; "lxor"]; -value assoc_right_parsed_op_list = ["and"; "or"; "^"; "@"]; -value and_by_couple_op_list = ["="; "<>"; "<"; ">"; "<="; ">="; "=="; "!="]; - -(* extensible pretty print functions *) - -pr_constr_decl.pr_levels := - [{pr_label = "top"; - pr_box ppf f x = fprintf ppf "@[%t@]" f; - pr_rules = - extfun Extfun.empty with - [ (loc, c, []) as x -> - fun ppf curr next dg k -> fprintf ppf "(@[%s%t@]" c (ks ")" k) - | (loc, c, tl) -> - fun ppf curr next dg k -> - fprintf ppf "(@[%s@ %a@]" c (list ctyp) (tl, ks ")" k) ]}]; - -pr_ctyp.pr_levels := - [{pr_label = "top"; - pr_box ppf f x = fprintf ppf "@[%t@]" f; - pr_rules = - extfun Extfun.empty with - [ <:ctyp< [ $list:cdl$ ] >> -> - fun ppf curr next dg k -> - fprintf ppf "(@[sum@ %a@]" (list constr_decl) (cdl, ks ")" k) - | <:ctyp< { $list:cdl$ } >> -> - fun ppf curr next dg k -> - fprintf ppf "{@[%a@]" (list label_decl) (cdl, ks "}" k) - | <:ctyp< ( $list:tl$ ) >> -> - fun ppf curr next dg k -> - fprintf ppf "(@[* @[%a@]@]" (list ctyp) (tl, ks ")" k) - | <:ctyp< $t1$ -> $t2$ >> -> - fun ppf curr next dg k -> - let tl = - loop t2 where rec loop = - fun - [ <:ctyp< $t1$ -> $t2$ >> -> [t1 :: loop t2] - | t -> [t] ] - in - fprintf ppf "(@[-> @[%a@]@]" (list ctyp) - ([t1 :: tl], ks ")" k) - | <:ctyp< $t1$ $t2$ >> -> - fun ppf curr next dg k -> - let (t, tl) = - loop [t2] t1 where rec loop tl = - fun - [ <:ctyp< $t1$ $t2$ >> -> loop [t2 :: tl] t1 - | t1 -> (t1, tl) ] - in - fprintf ppf "(@[%a@ %a@]" ctyp (t, nok) (list ctyp) (tl, ks ")" k) - | <:ctyp< $t1$ . $t2$ >> -> - fun ppf curr next dg k -> - fprintf ppf "%a.%a" ctyp (t1, nok) ctyp (t2, k) - | <:ctyp< $lid:s$ >> | <:ctyp< $uid:s$ >> -> - fun ppf curr next dg k -> fprintf ppf "%s%t" s k - | <:ctyp< ' $s$ >> -> - fun ppf curr next dg k -> fprintf ppf "'%s%t" s k - | <:ctyp< _ >> -> - fun ppf curr next dg k -> fprintf ppf "_%t" k - | x -> - fun ppf curr next dg k -> not_impl "ctyp" x ppf k ]}]; - -pr_expr.pr_levels := - [{pr_label = "top"; - pr_box ppf f x = fprintf ppf "@[%t@]" f; - pr_rules = - extfun Extfun.empty with - [ <:expr< fun [] >> -> - fun ppf curr next dg k -> - fprintf ppf "(lambda%t" (ks ")" k) - | <:expr< fun $lid:s$ -> $e$ >> -> - fun ppf curr next dg k -> - fprintf ppf "(lambda@ %s@;<1 1>%a" s expr (e, ks ")" k) - | <:expr< fun [ $list:pwel$ ] >> -> - fun ppf curr next dg k -> - fprintf ppf "(@[lambda_match@ %a@]" (list match_assoc) - (pwel, ks ")" k) - | <:expr< match $e$ with [ $list:pwel$ ] >> -> - fun ppf curr next dg k -> - fprintf ppf "(@[@[match@ %a@]@ %a@]" expr (e, nok) - (list match_assoc) (pwel, ks ")" k) - | <:expr< try $e$ with [ $list:pwel$ ] >> -> - fun ppf curr next dg k -> - fprintf ppf "(@[@[try@ %a@]@ %a@]" expr (e, nok) - (list match_assoc) (pwel, ks ")" k) - | <:expr< let $p1$ = $e1$ in $e2$ >> -> - fun ppf curr next dg k -> - let (pel, e) = - loop [(p1, e1)] e2 where rec loop pel = - fun - [ <:expr< let $p1$ = $e1$ in $e2$ >> -> - loop [(p1, e1) :: pel] e2 - | e -> (List.rev pel, e) ] - in - let b = - match pel with - [ [_] -> "let" - | _ -> "let*" ] - in - fprintf ppf "(@[@[%s (@[%a@]@]@;<1 2>%a@]" b - (listwb "" let_binding) (pel, ks ")" nok) - sequence (e, ks ")" k) - | <:expr< let $opt:rf$ $list:pel$ in $e$ >> -> - fun ppf curr next dg k -> - let b = if rf then "letrec" else "let" in - fprintf ppf "(@[%s@ (@[%a@]@ %a@]" b - (listwb "" let_binding) (pel, ks ")" nok) expr (e, ks ")" k) - | <:expr< if $e1$ then $e2$ else () >> -> - fun ppf curr next dg k -> - fprintf ppf "(if @[%a@;<1 0>%a@]" expr (e1, nok) - expr (e2, ks ")" k) - | <:expr< if $e1$ then $e2$ else $e3$ >> -> - fun ppf curr next dg k -> - fprintf ppf "(if @[%a@ %a@ %a@]" expr (e1, nok) - expr (e2, nok) expr (e3, ks ")" k) - | <:expr< do { $list:el$ } >> -> - fun ppf curr next dg k -> - fprintf ppf "(begin@;<1 1>@[%a@]" (list expr) (el, ks ")" k) - | <:expr< for $i$ = $e1$ to $e2$ do { $list:el$ } >> -> - fun ppf curr next dg k -> - fprintf ppf "(@[for %s@ %a@ %a %a@]" i expr (e1, nok) - expr (e2, nok) (list expr) (el, ks ")" k) - | <:expr< ($e$ : $t$) >> -> - fun ppf curr next dg k -> - fprintf ppf "(:@ %a@ %a" expr (e, nok) ctyp (t, ks ")" k) - | <:expr< ($list:el$) >> -> - fun ppf curr next dg k -> - fprintf ppf "(values @[%a@]" (list expr) (el, ks ")" k) - | <:expr< { $list:fel$ } >> -> - fun ppf curr next dg k -> - let record_binding ppf ((p, e), k) = - fprintf ppf "(@[%a@ %a@]" patt (p, nok) expr (e, ks ")" k) - in - fprintf ppf "{@[%a@]" (list record_binding) (fel, ks "}" k) - | <:expr< { ($e$) with $list:fel$ } >> -> - fun ppf curr next dg k -> - let record_binding ppf ((p, e), k) = - fprintf ppf "(@[%a@ %a@]" patt (p, nok) expr (e, ks ")" k) - in - fprintf ppf "{@[@[with@ %a@]@ @[%a@]@]" expr (e, nok) - (list record_binding) (fel, ks "}" k) - | <:expr< $e1$ := $e2$ >> -> - fun ppf curr next dg k -> - fprintf ppf "(:=@;<1 1>%a@;<1 1>%a" expr (e1, nok) - expr (e2, ks ")" k) - | <:expr< [$_$ :: $_$] >> as e -> - fun ppf curr next dg k -> - let (el, c) = - make_list e where rec make_list e = - match e with - [ <:expr< [$e$ :: $y$] >> -> - let (el, c) = make_list y in - ([e :: el], c) - | <:expr< [] >> -> ([], None) - | x -> ([], Some e) ] - in - match c with - [ None -> - fprintf ppf "[%a" (list expr) (el, ks "]" k) - | Some x -> - fprintf ppf "[%a@ %a" (list expr) (el, ks " ." nok) - expr (x, ks "]" k) ] - | <:expr< lazy ($x$) >> -> - fun ppf curr next dg k -> - fprintf ppf "(@[lazy@ %a@]" expr (x, ks ")" k) - | <:expr< $lid:s$ $e1$ $e2$ >> - when List.mem s assoc_right_parsed_op_list -> - fun ppf curr next dg k -> - let el = - loop [e1] e2 where rec loop el = - fun - [ <:expr< $lid:s1$ $e1$ $e2$ >> when s1 = s -> - loop [e1 :: el] e2 - | e -> List.rev [e :: el] ] - in - fprintf ppf "(@[%s %a@]" s (list expr) (el, ks ")" k) - | <:expr< $e1$ $e2$ >> -> - fun ppf curr next dg k -> - let (f, el) = - loop [e2] e1 where rec loop el = - fun - [ <:expr< $e1$ $e2$ >> -> loop [e2 :: el] e1 - | e1 -> (e1, el) ] - in - fprintf ppf "(@[%a@ %a@]" expr (f, nok) (list expr) (el, ks ")" k) - | <:expr< ~ $s$ : ($e$) >> -> - fun ppf curr next dg k -> - fprintf ppf "(~%s@ %a" s expr (e, ks ")" k) - | <:expr< $e1$ .[ $e2$ ] >> -> - fun ppf curr next dg k -> - fprintf ppf "%a.[%a" expr (e1, nok) expr (e2, ks "]" k) - | <:expr< $e1$ .( $e2$ ) >> -> - fun ppf curr next dg k -> - fprintf ppf "%a.(%a" expr (e1, nok) expr (e2, ks ")" k) - | <:expr< $e1$ . $e2$ >> -> - fun ppf curr next dg k -> - fprintf ppf "%a.%a" expr (e1, nok) expr (e2, k) - | <:expr< $int:s$ >> -> - fun ppf curr next dg k -> fprintf ppf "%s%t" (int_repr s) k - | <:expr< $lid:s$ >> | <:expr< $uid:s$ >> -> - fun ppf curr next dg k -> fprintf ppf "%s%t" s k - | <:expr< ` $s$ >> -> - fun ppf curr next dg k -> fprintf ppf "`%s%t" s k - | <:expr< $str:s$ >> -> - fun ppf curr next dg k -> fprintf ppf "\"%s\"%t" s k - | <:expr< $chr:s$ >> -> - fun ppf curr next dg k -> fprintf ppf "'%s'%t" s k - | x -> - fun ppf curr next dg k -> not_impl "expr" x ppf k ]}]; - -pr_label_decl.pr_levels := - [{pr_label = "top"; - pr_box ppf f x = fprintf ppf "@[%t@]" f; - pr_rules = - extfun Extfun.empty with - [ (loc, f, m, t) -> - fun ppf curr next dg k -> - fprintf ppf "(@[%s%t@ %a@]" f - (fun ppf -> if m then fprintf ppf "@ mutable" else ()) - ctyp (t, ks ")" k) ]}]; - -pr_let_binding.pr_levels := - [{pr_label = "top"; - pr_box ppf f x = fprintf ppf "@[%t@]" f; - pr_rules = - extfun Extfun.empty with - [ (b, (p, e)) -> - fun ppf curr next dg k -> - let (pl, e) = expr_fun_args e in - match pl with - [ [] -> - fprintf ppf "(@[%s%s%a@ %a@]" b - (if b = "" then "" else " ") patt (p, nok) - sequence (e, ks ")" k) - | _ -> - fprintf ppf "(@[%s%s(%a)@ %a@]" b - (if b = "" then "" else " ") (list patt) ([p :: pl], nok) - sequence (e, ks ")" k) ] ]}]; - -pr_match_assoc.pr_levels := - [{pr_label = "top"; - pr_box ppf f x = fprintf ppf "@[%t@]" f; - pr_rules = - extfun Extfun.empty with - [ (p, we, e) -> - fun ppf curr next dg k -> - fprintf ppf "(@[%t@ %a@]" - (fun ppf -> - match we with - [ Some e -> - fprintf ppf "(when@ %a@ %a" patt (p, nok) - expr (e, ks ")" nok) - | None -> patt ppf (p, nok) ]) - sequence (e, ks ")" k) ]}]; - -pr_mod_ident.pr_levels := - [{pr_label = "top"; - pr_box ppf f x = fprintf ppf "@[%t@]" f; - pr_rules = - extfun Extfun.empty with - [ [s] -> - fun ppf curr next dg k -> - fprintf ppf "%s%t" s k - | [s :: sl] -> - fun ppf curr next dg k -> - fprintf ppf "%s.%a" s curr (sl, "", k) - | x -> - fun ppf curr next dg k -> not_impl "mod_ident" x ppf k ]}]; - -pr_module_binding.pr_levels := - [{pr_label = "top"; - pr_box ppf f x = fprintf ppf "@[%t@]" f; - pr_rules = - extfun Extfun.empty with - [ (b, s, me) -> - fun ppf curr next dg k -> - fprintf ppf "%s@ %s@ %a" b s module_expr (me, k) ]}]; - -pr_module_expr.pr_levels := - [{pr_label = "top"; - pr_box ppf f x = fprintf ppf "@[%t@]" f; - pr_rules = - extfun Extfun.empty with - [ <:module_expr< functor ($i$ : $mt$) -> $me$ >> -> - fun ppf curr next dg k -> - fprintf ppf "(@[@[@[functor@ %s@]@ %a@]@ %a@]" - i module_type (mt, nok) module_expr (me, ks ")" k) - | <:module_expr< struct $list:sil$ end >> -> - fun ppf curr next dg k -> - fprintf ppf "(@[struct@ @[%a@]@]" (list str_item) - (sil, ks ")" k) - | <:module_expr< $me1$ $me2$ >> -> - fun ppf curr next dg k -> - fprintf ppf "(@[%a@ %a@]" module_expr (me1, nok) - module_expr (me2, ks ")" k) - | <:module_expr< $uid:s$ >> -> - fun ppf curr next dg k -> fprintf ppf "%s%t" s k - | x -> - fun ppf curr next dg k -> not_impl "module_expr" x ppf k ]}]; - -pr_module_type.pr_levels := - [{pr_label = "top"; - pr_box ppf f x = fprintf ppf "@[%t@]" f; - pr_rules = - extfun Extfun.empty with - [ <:module_type< functor ($i$ : $mt1$) -> $mt2$ >> -> - fun ppf curr next dg k -> - fprintf ppf "(@[@[@[functor@ %s@]@ %a@]@ %a@]" - i module_type (mt1, nok) module_type (mt2, ks ")" k) - | <:module_type< sig $list:sil$ end >> -> - fun ppf curr next dg k -> - fprintf ppf "(@[sig@ @[%a@]@]" (list sig_item) (sil, ks ")" k) - | <:module_type< $mt$ with $list:wcl$ >> -> - fun ppf curr next dg k -> - fprintf ppf "(@[with@;<1 2>@[%a@ (%a@]@]" module_type (mt, nok) - (list with_constr) (wcl, ks "))" k) - | <:module_type< $uid:s$ >> -> - fun ppf curr next dg k -> fprintf ppf "%s%t" s k - | x -> - fun ppf curr next dg k -> not_impl "module_type" x ppf k ]}]; - -pr_patt.pr_levels := - [{pr_label = "top"; - pr_box ppf f x = fprintf ppf "@[%t@]" f; - pr_rules = - extfun Extfun.empty with - [ <:patt< $p1$ | $p2$ >> -> - fun ppf curr next dg k -> - let (f, pl) = - loop [p2] p1 where rec loop pl = - fun - [ <:patt< $p1$ | $p2$ >> -> loop [p2 :: pl] p1 - | p1 -> (p1, pl) ] - in - fprintf ppf "(@[or@ %a@ %a@]" patt (f, nok) (list patt) - (pl, ks ")" k) - | <:patt< ($p1$ as $p2$) >> -> - fun ppf curr next dg k -> - fprintf ppf "(@[as@ %a@ %a@]" patt (p1, nok) patt (p2, ks ")" k) - | <:patt< $p1$ .. $p2$ >> -> - fun ppf curr next dg k -> - fprintf ppf "(@[range@ %a@ %a@]" patt (p1, nok) patt (p2, ks ")" k) - | <:patt< [$_$ :: $_$] >> as p -> - fun ppf curr next dg k -> - let (pl, c) = - make_list p where rec make_list p = - match p with - [ <:patt< [$p$ :: $y$] >> -> - let (pl, c) = make_list y in - ([p :: pl], c) - | <:patt< [] >> -> ([], None) - | x -> ([], Some p) ] - in - match c with - [ None -> - fprintf ppf "[%a" (list patt) (pl, ks "]" k) - | Some x -> - fprintf ppf "[%a@ %a" (list patt) (pl, ks " ." nok) - patt (x, ks "]" k) ] - | <:patt< $p1$ $p2$ >> -> - fun ppf curr next dg k -> - let pl = - loop [p2] p1 where rec loop pl = - fun - [ <:patt< $p1$ $p2$ >> -> loop [p2 :: pl] p1 - | p1 -> [p1 :: pl] ] - in - fprintf ppf "(@[%a@]" (list patt) (pl, ks ")" k) - | <:patt< ($p$ : $t$) >> -> - fun ppf curr next dg k -> - fprintf ppf "(:@ %a@ %a" patt (p, nok) ctyp (t, ks ")" k) - | <:patt< ($list:pl$) >> -> - fun ppf curr next dg k -> - fprintf ppf "(values @[%a@]" (list patt) (pl, ks ")" k) - | <:patt< { $list:fpl$ } >> -> - fun ppf curr next dg k -> - let record_binding ppf ((p1, p2), k) = - fprintf ppf "(@[%a@ %a@]" patt (p1, nok) patt (p2, ks ")" k) - in - fprintf ppf "(@[{}@ %a@]" (list record_binding) (fpl, ks ")" k) - | <:patt< ? $x$ >> -> - fun ppf curr next dg k -> fprintf ppf "?%s%t" x k - | <:patt< ? ($lid:x$ = $e$) >> -> - fun ppf curr next dg k -> fprintf ppf "(?%s@ %a" x expr (e, ks ")" k) - | <:patt< $p1$ . $p2$ >> -> - fun ppf curr next dg k -> - fprintf ppf "%a.%a" patt (p1, nok) patt (p2, k) - | <:patt< $lid:s$ >> | <:patt< $uid:s$ >> -> - fun ppf curr next dg k -> fprintf ppf "%s%t" s k - | <:patt< $str:s$ >> -> - fun ppf curr next dg k -> fprintf ppf "\"%s\"%t" s k - | <:patt< $chr:s$ >> -> - fun ppf curr next dg k -> fprintf ppf "'%s'%t" s k - | <:patt< $int:s$ >> -> - fun ppf curr next dg k -> fprintf ppf "%s%t" (int_repr s) k - | <:patt< $flo:s$ >> -> - fun ppf curr next dg k -> fprintf ppf "%s%t" s k - | <:patt< _ >> -> - fun ppf curr next dg k -> fprintf ppf "_%t" k - | x -> - fun ppf curr next dg k -> not_impl "patt" x ppf k ]}]; - -pr_sig_item.pr_levels := - [{pr_label = "top"; - pr_box ppf f x = fprintf ppf "@[%t@]" f; - pr_rules = - extfun Extfun.empty with - [ <:sig_item< type $list:tdl$ >> -> - fun ppf curr next dg k -> - match tdl with - [ [td] -> fprintf ppf "(%a" type_decl (("type", td), ks ")" k) - | tdl -> - fprintf ppf "(@[type@ %a@]" (listwb "" type_decl) - (tdl, ks ")" k) ] - | <:sig_item< exception $c$ of $list:tl$ >> -> - fun ppf curr next dg k -> - match tl with - [ [] -> fprintf ppf "(@[exception@ %s%t@]" c (ks ")" k) - | tl -> - fprintf ppf "(@[@[exception@ %s@]@ %a@]" c - (list ctyp) (tl, ks ")" k) ] - | <:sig_item< value $i$ : $t$ >> -> - fun ppf curr next dg k -> - fprintf ppf "(@[@[value %s@]@ %a@]" i ctyp (t, ks ")" k) - | <:sig_item< external $i$ : $t$ = $list:pd$ >> -> - fun ppf curr next dg k -> - fprintf ppf "(@[@[external@ %s@]@ %a@ %a@]" i ctyp (t, nok) - (list string) (pd, ks ")" k) - | <:sig_item< module $s$ : $mt$ >> -> - fun ppf curr next dg k -> - fprintf ppf "(@[@[module@ %s@]@ %a@]" s - module_type (mt, ks ")" k) - | <:sig_item< module type $s$ = $mt$ >> -> - fun ppf curr next dg k -> - fprintf ppf "(@[@[moduletype@ %s@]@ %a@]" s - module_type (mt, ks ")" k) - | <:sig_item< declare $list:s$ end >> -> - fun ppf curr next dg k -> - if s = [] then fprintf ppf "; ..." - else fprintf ppf "%a" (list sig_item) (s, k) - | MLast.SgUse _ _ _ -> - fun ppf curr next dg k -> () - | x -> - fun ppf curr next dg k -> not_impl "sig_item" x ppf k ]}]; - -pr_str_item.pr_levels := - [{pr_label = "top"; - pr_box ppf f x = fprintf ppf "@[%t@]" f; - pr_rules = - extfun Extfun.empty with - [ <:str_item< open $i$ >> -> - fun ppf curr next dg k -> - fprintf ppf "(open@ %a" mod_ident (i, ks ")" k) - | <:str_item< type $list:tdl$ >> -> - fun ppf curr next dg k -> - match tdl with - [ [td] -> fprintf ppf "(%a" type_decl (("type", td), ks ")" k) - | tdl -> - fprintf ppf "(@[type@ %a@]" (listwb "" type_decl) - (tdl, ks ")" k) ] - | <:str_item< exception $c$ of $list:tl$ >> -> - fun ppf curr next dg k -> - match tl with - [ [] -> fprintf ppf "(@[exception@ %s%t@]" c (ks ")" k) - | tl -> - fprintf ppf "(@[@[exception@ %s@]@ %a@]" c - (list ctyp) (tl, ks ")" k) ] - | <:str_item< value $opt:rf$ $list:pel$ >> -> - fun ppf curr next dg k -> - let b = if rf then "definerec" else "define" in - match pel with - [ [(p, e)] -> - fprintf ppf "%a" let_binding ((b, (p, e)), k) - | pel -> - fprintf ppf "(@[%s*@ %a@]" b (listwb "" let_binding) - (pel, ks ")" k) ] - | <:str_item< module $s$ = $me$ >> -> - fun ppf curr next dg k -> - fprintf ppf "(%a" module_binding (("module", s, me), ks ")" k) - | <:str_item< module type $s$ = $mt$ >> -> - fun ppf curr next dg k -> - fprintf ppf "(@[@[moduletype@ %s@]@ %a@]" s - module_type (mt, ks ")" k) - | <:str_item< external $i$ : $t$ = $list:pd$ >> -> - fun ppf curr next dg k -> - fprintf ppf "(@[external@ %s@ %a@ %a@]" i ctyp (t, nok) - (list string) (pd, ks ")" k) - | <:str_item< $exp:e$ >> -> - fun ppf curr next dg k -> - fprintf ppf "%a" expr (e, k) - | <:str_item< # $s$ $opt:x$ >> -> - fun ppf curr next dg k -> - match x with - [ Some e -> fprintf ppf "; # (%s %a" s expr (e, ks ")" k) - | None -> fprintf ppf "; # (%s%t" s (ks ")" k) ] - | <:str_item< declare $list:s$ end >> -> - fun ppf curr next dg k -> - if s = [] then fprintf ppf "; ..." - else fprintf ppf "%a" (list str_item) (s, k) - | MLast.StUse _ _ _ -> - fun ppf curr next dg k -> () - | x -> - fun ppf curr next dg k -> not_impl "str_item" x ppf k ]}]; - -pr_type_decl.pr_levels := - [{pr_label = "top"; - pr_box ppf f x = fprintf ppf "@[%t@]" f; - pr_rules = - extfun Extfun.empty with - [ (b, ((_, tn), tp, te, cl)) -> - fun ppf curr next dg k -> - fprintf ppf "%t%t@;<1 1>%a" - (fun ppf -> - if b <> "" then fprintf ppf "%s@ " b - else ()) - (fun ppf -> - match tp with - [ [] -> fprintf ppf "%s" tn - | tp -> fprintf ppf "(%s%a)" tn type_params (tp, nok) ]) - ctyp (te, k) ]}]; - -pr_type_params.pr_levels := - [{pr_label = "top"; - pr_box ppf f x = fprintf ppf "@[%t@]" f; - pr_rules = - extfun Extfun.empty with - [ [(s, vari) :: tpl] -> - fun ppf curr next dg k -> - fprintf ppf "@ '%s%a" s type_params (tpl, k) - | [] -> - fun ppf curr next dg k -> () ]}]; - -pr_with_constr.pr_levels := - [{pr_label = "top"; - pr_box ppf f x = fprintf ppf "@[%t@]" f; - pr_rules = - extfun Extfun.empty with - [ MLast.WcTyp _ m tp te -> - fun ppf curr next dg k -> - fprintf ppf "(type@ %t@;<1 1>%a" - (fun ppf -> - match tp with - [ [] -> fprintf ppf "%a" mod_ident (m, nok) - | tp -> - fprintf ppf "(%a@ %a)" mod_ident (m, nok) - type_params (tp, nok) ]) - ctyp (te, ks ")" k) - | x -> - fun ppf curr next dg k -> not_impl "with_constr" x ppf k ]}]; - -(* main *) - -value output_string_eval ppf s = - loop 0 where rec loop i = - if i == String.length s then () - else if i == String.length s - 1 then pp_print_char ppf s.[i] - else - match (s.[i], s.[i + 1]) with - [ ('\\', 'n') -> do { pp_print_char ppf '\n'; loop (i + 2) } - | (c, _) -> do { pp_print_char ppf c; loop (i + 1) } ] -; - -value sep = Pcaml.inter_phrases; - -value input_source ic len = - let buff = Buffer.create 20 in - try - let rec loop i = - if i >= len then Buffer.contents buff - else do { let c = input_char ic in Buffer.add_char buff c; loop (i + 1) } - in - loop 0 - with - [ End_of_file -> - let s = Buffer.contents buff in - if s = "" then - match sep.val with - [ Some s -> s - | None -> "\n" ] - else s ] -; - -value copy_source ppf (ic, first, bp, ep) = - match sep.val with - [ Some str -> - if first then () - else if ep == in_channel_length ic then pp_print_string ppf "\n" - else output_string_eval ppf str - | None -> - do { - seek_in ic bp; - let s = input_source ic (ep - bp) in pp_print_string ppf s - } ] -; - -value copy_to_end ppf (ic, first, bp) = - let ilen = in_channel_length ic in - if bp < ilen then copy_source ppf (ic, first, bp, ilen) - else pp_print_string ppf "\n" -; - -value apply_printer printer ast = - let ppf = std_formatter in - if Pcaml.input_file.val <> "-" && Pcaml.input_file.val <> "" then do { - let ic = open_in_bin Pcaml.input_file.val in - try - let (first, last_pos) = - List.fold_left - (fun (first, last_pos) (si, (bp, ep)) -> - do { - fprintf ppf "@[%a@]@?" copy_source (ic, first, last_pos, bp); - fprintf ppf "@[%a@]@?" printer (si, nok); - (False, ep) - }) - (True, 0) ast - in - fprintf ppf "@[%a@]@?" copy_to_end (ic, first, last_pos) - with x -> - do { fprintf ppf "@."; close_in ic; raise x }; - close_in ic; - } - else failwith "not implemented" -; - -Pcaml.print_interf.val := apply_printer sig_item; -Pcaml.print_implem.val := apply_printer str_item; - -Pcaml.add_option "-l" (Arg.Int (fun x -> set_margin x)) - " Maximum line length for pretty printing."; - -Pcaml.add_option "-sep" (Arg.String (fun x -> sep.val := Some x)) - " Use this string between phrases instead of reading source."; diff --git a/camlp4/etc/pr_schp_main.ml b/camlp4/etc/pr_schp_main.ml deleted file mode 100644 index c535111499..0000000000 --- a/camlp4/etc/pr_schp_main.ml +++ /dev/null @@ -1,119 +0,0 @@ -(* camlp4r q_MLast.cmo ./pa_extfun.cmo *) -(* $Id$ *) - -open Format; -open Pcaml; -open Parserify; - -value nok = Pr_scheme.nok; -value ks = Pr_scheme.ks; -value patt = Pr_scheme.patt; -value expr = Pr_scheme.expr; -value find_pr_level = Pr_scheme.find_pr_level; -value pr_expr = Pr_scheme.pr_expr; -type printer_t 'a = Pr_scheme.printer_t 'a == - { pr_fun : mutable string -> Pr_scheme.next 'a; - pr_levels : mutable list (pr_level 'a) } -and pr_level 'a = Pr_scheme.pr_level 'a == - { pr_label : string; - pr_box : formatter -> (formatter -> unit) -> 'a -> unit; - pr_rules : mutable Pr_scheme.pr_rule 'a } -; - -(* extensions for rebuilding syntax of parsers *) - -value parser_cases ppf (spel, k) = - let rec parser_cases ppf (spel, k) = - match spel with - [ [] -> fprintf ppf "[: `HVbox [: b; k :] :]" - | [(sp, epo, e)] -> parser_case ppf (sp, epo, e, k) - | [(sp, epo, e) :: spel] -> - fprintf ppf "%a@ %a" parser_case (sp, epo, e, nok) - parser_cases (spel, k) ] - and parser_case ppf (sp, epo, e, k) = - fprintf ppf "(@[@[(%a)%t@]@ %a@]" stream_patt (sp, nok) - (fun ppf -> - match epo with - [ Some p -> fprintf ppf "@ %a" patt (p, nok) - | None -> () ]) - expr (e, ks ")" k) - and stream_patt ppf (sp, k) = - match sp with - [ [] -> k ppf - | [(spc, None)] -> fprintf ppf "%a" stream_patt_comp (spc, k) - | [(spc, Some e)] -> - fprintf ppf "(@[? %a@ %a@]" stream_patt_comp (spc, nok) - expr (e, ks ")" k) - | [(spc, None) :: spcl] -> - fprintf ppf "%a@ %a" stream_patt_comp (spc, nok) stream_patt (spcl, k) - | [(spc, Some e) :: spcl] -> - fprintf ppf "(@[? %a@ %a@]@ %a" stream_patt_comp (spc, nok) - expr (e, ks ")" nok) stream_patt (spcl, k) ] - and stream_patt_comp ppf (spc, k) = - match spc with - [ SPCterm (p, w) -> - match w with - [ Some e -> - fprintf ppf "(` %a@ %a" patt (p, nok) expr (e, ks ")" k) - | None -> fprintf ppf "(` %a" patt (p, ks ")" k) ] - | SPCnterm p e -> - fprintf ppf "(@[%a %a@]" patt (p, nok) expr (e, ks ")" k) - | SPCsterm p -> fprintf ppf "%a" patt (p, k) ] - in - parser_cases ppf (spel, k) -; - -value parser_body ppf (e, k) = - let (bp, e) = - match e with - [ <:expr< let $bp$ = Stream.count strm__ in $e$ >> -> (Some bp, e) - | e -> (None, e) ] - in - match parser_of_expr e with - [ [] -> - fprintf ppf "(parser%t%t" - (fun ppf -> - match bp with - [ Some p -> fprintf ppf "@ %a" patt (p, nok) - | _ -> ()]) - (ks ")" k) - | spel -> - fprintf ppf "(@[@[parser%t@]@ @[%a@]@]" - (fun ppf -> - match bp with - [ Some p -> fprintf ppf "@ %a" patt (p, nok) - | _ -> ()]) - parser_cases (spel, ks ")" k) ] -; - -value pmatch ppf (e, k) = - let (me, e) = - match e with - [ <:expr< let (strm__ : Stream.t _) = $me$ in $e$ >> -> (me, e) - | _ -> failwith "Pr_schp_main.pmatch" ] - in - let (bp, e) = - match e with - [ <:expr< let $bp$ = Stream.count strm__ in $e$ >> -> (Some bp, e) - | e -> (None, e) ] - in - let spel = parser_of_expr e in - fprintf ppf "(@[@[match_with_parser@ %a@]%t@ @[%a@]@]" expr (me, nok) - (fun ppf -> - match bp with - [ Some p -> fprintf ppf "@ %a" patt (p, nok) - | _ -> () ]) - parser_cases (spel, ks ")" k) -; - -pr_expr_fun_args.val := - extfun pr_expr_fun_args.val with - [ <:expr< fun [(strm__ : $_$) -> $_$] >> as ge -> ([], ge) ]; - -let lev = find_pr_level "top" pr_expr.pr_levels in -lev.pr_rules := - extfun lev.pr_rules with - [ <:expr< fun (strm__ : $_$) -> $x$ >> -> - fun ppf curr next dg k -> fprintf ppf "%a" parser_body (x, k) - | <:expr< let (strm__ : Stream.t _) = $_$ in $_$ >> as e -> - fun ppf curr next dg k -> fprintf ppf "%a" pmatch (e, k) ]; diff --git a/camlp4/etc/q_phony.ml b/camlp4/etc/q_phony.ml deleted file mode 100644 index 841e2bec90..0000000000 --- a/camlp4/etc/q_phony.ml +++ /dev/null @@ -1,49 +0,0 @@ -(* camlp4r pa_extend.cmo q_MLast.cmo *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2001 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -open Pcaml; - -value t = ref ""; - -Quotation.add "" - (Quotation.ExAst - (fun s -> - let t = - if t.val = "" then "<<" ^ s ^ ">>" - else "<:" ^ t.val ^ "<" ^ s ^ ">>" - in - let loc = (0, 0) in - <:expr< $uid:t$ >>, - fun s -> - let t = - if t.val = "" then "<<" ^ s ^ ">>" - else "<:" ^ t.val ^ "<" ^ s ^ ">>" - in - let loc = (0, 0) in - <:patt< $uid:t$ >>)) -; - -Quotation.default.val := ""; -Quotation.translate.val := fun s -> do { t.val := s; "" }; - -if Pcaml.syntax_name.val <> "Scheme" then - EXTEND - expr: LEVEL "top" - [ [ "IFDEF"; c = UIDENT; "THEN"; e1 = expr; "ELSE"; e2 = expr; "END" -> - <:expr< if DEF $uid:c$ then $e1$ else $e2$ >> - | "IFNDEF"; c = UIDENT; "THEN"; e1 = expr; "ELSE"; e2 = expr; "END" -> - <:expr< if NDEF $uid:c$ then $e1$ else $e2$ >> ] ] - ; - END -else (); diff --git a/camlp4/lib/.cvsignore b/camlp4/lib/.cvsignore deleted file mode 100644 index c77a681dd6..0000000000 --- a/camlp4/lib/.cvsignore +++ /dev/null @@ -1,3 +0,0 @@ -*.cm[oiax] -*.cmxa -*.lib diff --git a/camlp4/lib/.depend b/camlp4/lib/.depend deleted file mode 100644 index 0d5adc691f..0000000000 --- a/camlp4/lib/.depend +++ /dev/null @@ -1,20 +0,0 @@ -extfold.cmi: gramext.cmi -gramext.cmi: token.cmi -grammar.cmi: gramext.cmi token.cmi -plexer.cmi: token.cmi -extfold.cmo: gramext.cmi grammar.cmi extfold.cmi -extfold.cmx: gramext.cmx grammar.cmx extfold.cmi -extfun.cmo: extfun.cmi -extfun.cmx: extfun.cmi -fstream.cmo: fstream.cmi -fstream.cmx: fstream.cmi -gramext.cmo: token.cmi gramext.cmi -gramext.cmx: token.cmx gramext.cmi -grammar.cmo: gramext.cmi stdpp.cmi token.cmi grammar.cmi -grammar.cmx: gramext.cmx stdpp.cmx token.cmx grammar.cmi -plexer.cmo: stdpp.cmi token.cmi plexer.cmi -plexer.cmx: stdpp.cmx token.cmx plexer.cmi -stdpp.cmo: stdpp.cmi -stdpp.cmx: stdpp.cmi -token.cmo: token.cmi -token.cmx: token.cmi diff --git a/camlp4/lib/Makefile b/camlp4/lib/Makefile deleted file mode 100644 index ece72d1519..0000000000 --- a/camlp4/lib/Makefile +++ /dev/null @@ -1,48 +0,0 @@ -# $Id$ - -include ../config/Makefile - -INCLUDES= -OCAMLCFLAGS=-warn-error A $(INCLUDES) -OBJS=stdpp.cmo token.cmo plexer.cmo gramext.cmo grammar.cmo extfold.cmo extfun.cmo fstream.cmo -SHELL=/bin/sh -TARGET=gramlib.cma - -all: $(TARGET) -opt: $(TARGET:.cma=.cmxa) - -$(TARGET): $(OBJS) - $(OCAMLC) $(OBJS) -a -o $(TARGET) - -$(TARGET:.cma=.cmxa): $(OBJS:.cmo=.cmx) - $(OCAMLOPT) $(OBJS:.cmo=.cmx) -a -o $(TARGET:.cma=.cmxa) - -clean:: - rm -f *.cm[ioax] *.cmxa *.pp[io] *.$(O) *.$(A) *.bak .*.bak $(TARGET) - -depend: - cp .depend .depend.bak - > .depend - @for i in *.mli *.ml; do \ - ../tools/apply.sh pr_depend.cmo -- $(INCLUDES) $$i >> .depend; \ - done - -promote: - cp $(OBJS) $(OBJS:.cmo=.cmi) ../boot/. - -compare: - @for j in $(OBJS) $(OBJS:.cmo=.cmi); do \ - if cmp $$j ../boot/$$j; then :; else exit 1; fi; \ - done - -install: - -$(MKDIR) "$(LIBDIR)/camlp4" - cp $(TARGET) *.mli "$(LIBDIR)/camlp4/." - cp *.cmi "$(LIBDIR)/camlp4/." - if test -f $(TARGET:.cma=.cmxa); then $(MAKE) installopt LIBDIR="$(LIBDIR)"; fi - -installopt: - cp $(TARGET:.cma=.cmxa) *.cmx "$(LIBDIR)/camlp4/." - tar cf - $(TARGET:.cma=.$(A)) | (cd "$(LIBDIR)/camlp4/."; tar xf -) - -include .depend diff --git a/camlp4/lib/Makefile.Mac b/camlp4/lib/Makefile.Mac deleted file mode 100644 index 90034c5c74..0000000000 --- a/camlp4/lib/Makefile.Mac +++ /dev/null @@ -1,46 +0,0 @@ -####################################################################### -# # -# Camlp4 # -# # -# Damien Doligez, projet Para, INRIA Rocquencourt # -# # -# Copyright 1999 Institut National de Recherche en Informatique et # -# en Automatique. Distributed only by permission. # -# # -####################################################################### - -# $Id$ - -INCLUDES = -OCAMLCFLAGS = {INCLUDES} -OBJS = stdpp.cmo token.cmo plexer.cmo gramext.cmo grammar.cmo extfun.cmo fstream.cmo -INTF = stdpp.cmi token.cmi plexer.cmi gramext.cmi grammar.cmi extfun.cmi fstream.cmi -TARGETS = gramlib.cma - -all Ä {TARGETS} - -{TARGETS} Ä {OBJS} - {OCAMLC} {OBJS} -a -o {TARGETS} - -steal Ä - -compare_stolen Ä - -clean ÄÄ - delete -i {TARGETS} - -{dependrule} - -promote Ä - duplicate -y {OBJS} {INTF} ::boot: - -compare Ä - for i in {OBJS} {INTF} - equal -s ::boot:{i} || exit 1 - end - -install Ä - (newfolder "{P4LIBDIR}" || set status 0) ³ dev:null - duplicate -y {TARGETS} Å.mli Å.cmi "{P4LIBDIR}" - -{defrules} diff --git a/camlp4/lib/Makefile.Mac.depend b/camlp4/lib/Makefile.Mac.depend deleted file mode 100644 index 8d12e3e08a..0000000000 --- a/camlp4/lib/Makefile.Mac.depend +++ /dev/null @@ -1,13 +0,0 @@ -gramext.cmoÄ token.cmi gramext.cmi -gramext.cmxÄ token.cmx gramext.cmi -gramext.cmiÄ token.cmi -grammar.cmoÄ gramext.cmi stdpp.cmi token.cmi grammar.cmi -grammar.cmxÄ gramext.cmx stdpp.cmx token.cmx grammar.cmi -grammar.cmiÄ gramext.cmi token.cmi -plexer.cmoÄ stdpp.cmi token.cmi plexer.cmi -plexer.cmxÄ stdpp.cmx token.cmx plexer.cmi -plexer.cmiÄ token.cmi -stdpp.cmoÄ stdpp.cmi -stdpp.cmxÄ stdpp.cmi -token.cmoÄ token.cmi -token.cmxÄ token.cmi diff --git a/camlp4/lib/extfold.ml b/camlp4/lib/extfold.ml deleted file mode 100644 index b612d15248..0000000000 --- a/camlp4/lib/extfold.ml +++ /dev/null @@ -1,91 +0,0 @@ -(* camlp4r *) -(* $Id$ *) - -type t 'te 'a 'b = - Gramext.g_entry 'te -> list (Gramext.g_symbol 'te) -> - (Stream.t 'te -> 'a) -> Stream.t 'te -> 'b -; - -type tsep 'te 'a 'b = - Gramext.g_entry 'te -> list (Gramext.g_symbol 'te) -> - (Stream.t 'te -> 'a) -> (Stream.t 'te -> unit) -> Stream.t 'te -> 'b -; - -value gen_fold0 final f e entry symbl psymb = - let rec fold accu = - parser - [ [: a = psymb; s :] -> fold (f a accu) s - | [: :] -> accu ] - in - parser [: a = fold e :] -> final a -; - -value gen_fold1 final 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) :] -> final a -; - -value gen_fold0sep final f e entry symbl psymb psep = - let failed = - fun - [ [symb; sep] -> Grammar.symb_failed_txt entry sep symb - | _ -> "failed" ] - in - let rec kont accu = - parser - [ [: v = psep; a = psymb ? failed symbl; s :] -> kont (f a accu) s - | [: :] -> accu ] - in - parser - [ [: a = psymb; s :] -> final (kont (f a e) s) - | [: :] -> e ] -; - -value gen_fold1sep final f e entry symbl psymb psep = - let failed = - fun - [ [symb; sep] -> Grammar.symb_failed_txt entry sep symb - | _ -> "failed" ] - in - let parse_top = - fun - [ [symb; _] -> Grammar.parse_top_symb entry symb - | _ -> raise Stream.Failure ] - in - let rec kont accu = - parser - [ [: v = 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 :] -> final (kont (f a e) s) -; - -value sfold0 f e = gen_fold0 (fun x -> x) f e; -value sfold1 f e = gen_fold1 (fun x -> x) f e; -value sfold0sep f e = gen_fold0sep (fun x -> x) f e; -value sfold1sep f e = gen_fold1sep (fun x -> x) f e; - -value cons x y = [x :: y]; -value nil = []; - -value slist0 entry = gen_fold0 List.rev cons nil entry; -value slist1 entry = gen_fold1 List.rev cons nil entry; -value slist0sep entry = gen_fold0sep List.rev cons nil entry; -value slist1sep entry = gen_fold1sep List.rev cons nil entry; - -value sopt entry symbl psymb = - parser - [ [: a = psymb :] -> Some a - | [: :] -> None ] -; diff --git a/camlp4/lib/extfold.mli b/camlp4/lib/extfold.mli deleted file mode 100644 index 639631e27d..0000000000 --- a/camlp4/lib/extfold.mli +++ /dev/null @@ -1,24 +0,0 @@ -(* camlp4r *) -(* $Id$ *) - -type t 'te 'a 'b = - Gramext.g_entry 'te -> list (Gramext.g_symbol 'te) -> - (Stream.t 'te -> 'a) -> Stream.t 'te -> 'b -; - -type tsep 'te 'a 'b = - Gramext.g_entry 'te -> list (Gramext.g_symbol 'te) -> - (Stream.t 'te -> 'a) -> (Stream.t 'te -> unit) -> Stream.t 'te -> 'b -; - -value sfold0 : ('a -> 'b -> 'b) -> 'b -> t _ 'a 'b; -value sfold1 : ('a -> 'b -> 'b) -> 'b -> t _ 'a 'b; -value sfold0sep : ('a -> 'b -> 'b) -> 'b -> tsep _ 'a 'b; -value sfold1sep : ('a -> 'b -> 'b) -> 'b -> tsep _ 'a 'b; - -value slist0 : t _ 'a (list 'a); -value slist1 : t _ 'a (list 'a); -value slist0sep : tsep _ 'a (list 'a); -value slist1sep : tsep _ 'a (list 'a); - -value sopt : t _ 'a (option 'a); diff --git a/camlp4/lib/extfun.ml b/camlp4/lib/extfun.ml deleted file mode 100644 index 866ea221c1..0000000000 --- a/camlp4/lib/extfun.ml +++ /dev/null @@ -1,109 +0,0 @@ -(* camlp4r *) -(* $Id$ *) -(* Copyright 2001 INRIA *) - -(* Extensible Functions *) - -type t 'a 'b = list (matching 'a 'b) -and matching 'a 'b = { patt : patt; has_when : bool; expr : expr 'a 'b } -and patt = - [ Eapp of list patt - | Eacc of list patt - | Econ of string - | Estr of string - | Eint of string - | Etup of list patt - | Evar of unit ] -and expr 'a 'b = 'a -> option 'b -; - -exception Failure; - -value empty = []; - -(*** Apply ***) - -value rec apply_matchings a = - fun - [ [m :: ml] -> - match m.expr a with - [ None -> apply_matchings a ml - | x -> x ] - | [] -> None ] -; - -value apply ef a = - match apply_matchings a ef with - [ Some x -> x - | None -> raise Failure ] -; - -(*** Trace ***) - -value rec list_iter_sep f s = - fun - [ [] -> () - | [x] -> f x - | [x :: l] -> do { f x; s (); list_iter_sep f s l } ] -; - -value rec print_patt = - fun - [ Eapp pl -> list_iter_sep print_patt2 (fun () -> print_string " ") pl - | p -> print_patt2 p ] -and print_patt2 = - fun - [ Eacc pl -> list_iter_sep print_patt1 (fun () -> print_string ".") pl - | p -> print_patt1 p ] -and print_patt1 = - fun - [ Econ s -> print_string s - | Estr s -> do { print_string "\""; print_string s; print_string "\"" } - | Eint s -> print_string s - | Evar () -> print_string "_" - | Etup pl -> - do { - print_string "("; - list_iter_sep print_patt (fun () -> print_string ", ") pl; - print_string ")" - } - | Eapp _ | Eacc _ as p -> - do { print_string "("; print_patt p; print_string ")" } ] -; - -value print ef = - List.iter - (fun m -> - do { - print_patt m.patt; - if m.has_when then print_string " when ..." else (); - print_newline () - }) - ef -; - -(*** Extension ***) - -value insert_matching matchings (patt, has_when, expr) = - let m1 = {patt = patt; has_when = has_when; expr = expr} in - let rec loop = - fun - [ [m :: ml] as gml -> - if m1.has_when && not m.has_when then [m1 :: gml] - else if not m1.has_when && m.has_when then [m :: loop ml] - else - let c = compare m1.patt m.patt in - if c < 0 then [m1 :: gml] - else if c > 0 then [m :: loop ml] - else if m.has_when then [m1 :: gml] - else [m1 :: ml] - | [] -> [m1] ] - in - loop matchings -; - -(* available extension function *) - -value extend ef matchings_def = - List.fold_left insert_matching ef matchings_def -; diff --git a/camlp4/lib/extfun.mli b/camlp4/lib/extfun.mli deleted file mode 100644 index 01b3cbd76b..0000000000 --- a/camlp4/lib/extfun.mli +++ /dev/null @@ -1,36 +0,0 @@ -(* camlp4r *) -(* $Id$ *) - -(** Extensible functions. - - This module implements pattern matching extensible functions. - To extend, use syntax [pa_extfun.cmo]: - - [extfun e with [ pattern_matching ]] *) - -type t 'a 'b = 'x; - (** The type of the extensible functions of type ['a -> 'b] *) -value empty : t 'a 'b; - (** Empty extensible function *) -value apply : t 'a 'b -> 'a -> 'b; - (** Apply an extensible function *) -exception Failure; - (** Match failure while applying an extensible function *) -value print : t 'a 'b -> unit; - (** Print patterns in the order they are recorded *) - -(**/**) - -type matching 'a 'b = { patt : patt; has_when : bool; expr : expr 'a 'b } -and patt = - [ Eapp of list patt - | Eacc of list patt - | Econ of string - | Estr of string - | Eint of string - | Etup of list patt - | Evar of unit ] -and expr 'a 'b = 'a -> option 'b -; - -value extend : t 'a 'b -> list (patt * bool * expr 'a 'b) -> t 'a 'b; diff --git a/camlp4/lib/fstream.ml b/camlp4/lib/fstream.ml deleted file mode 100644 index 14ab3a3d1c..0000000000 --- a/camlp4/lib/fstream.ml +++ /dev/null @@ -1,77 +0,0 @@ -(* camlp4r *) -(* $Id$ *) -(* Copyright 2001 INRIA *) - -type t 'a = { count : int; data : Lazy.t (data 'a) } -and data 'a = - [ Nil - | Cons of 'a and t 'a - | App of t 'a and t 'a ] -; - -value from f = - loop 0 where rec loop i = - {count = 0; - data = - lazy - (match f i with - [ Some x -> Cons x (loop (i + 1)) - | None -> Nil ])} -; - -value rec next s = - let count = s.count + 1 in - match Lazy.force s.data with - [ Nil -> None - | Cons a s -> Some (a, {count = count; data = s.data}) - | App s1 s2 -> - match next s1 with - [ Some (a, s1) -> Some (a, {count = count; data = lazy (App s1 s2)}) - | None -> - match next s2 with - [ Some (a, s2) -> Some (a, {count = count; data = s2.data}) - | None -> None ] ] ] -; - -value empty s = - match next s with - [ Some _ -> None - | None -> Some ((), s) ] -; - -value nil = {count = 0; data = lazy Nil}; -value cons a s = Cons a s; -value app s1 s2 = App s1 s2; -value flazy f = {count = 0; data = Lazy.lazy_from_fun f}; - -value of_list l = - List.fold_right (fun x s -> flazy (fun () -> cons x s)) l nil -; - -value of_string s = - from (fun c -> if c < String.length s then Some s.[c] else None) -; - -value of_channel ic = - from (fun _ -> try Some (input_char ic) with [ End_of_file -> None ]) -; - -value iter f = - do_rec where rec do_rec strm = - match next strm with - [ Some (a, strm) -> - let _ = f a in - do_rec strm - | None -> () ] -; - -value count s = s.count; - -value count_unfrozen s = - loop 0 s where rec loop cnt s = - if Lazy.lazy_is_val s.data then - match Lazy.force s.data with - [ Cons _ s -> loop (cnt + 1) s - | _ -> cnt ] - else cnt -; diff --git a/camlp4/lib/fstream.mli b/camlp4/lib/fstream.mli deleted file mode 100644 index 12926d99ff..0000000000 --- a/camlp4/lib/fstream.mli +++ /dev/null @@ -1,60 +0,0 @@ -(* camlp4r *) -(* $Id$ *) - -(* Module [Fstream]: functional streams *) - -(* This module implement functional streams. - To be used with syntax [pa_fstream.cmo]. The syntax is: -- stream: [fstream [: ... :]] -- parser: [parser [ [: ... :] -> ... | ... ]] - - Functional parsers are of type: [Fstream.t 'a -> option ('a * Fstream.t 'a)] - - They have limited backtrack, i.e if a rule fails, the next rule is tested - with the initial stream; limited because when in case of a rule with two - consecutive symbols [a] and [b], if [b] fails, the rule fails: there is - no try with the next rule of [a]. -*) - -type t 'a = 'x; - (* The type of 'a functional streams *) -value from : (int -> option 'a) -> t 'a; - (* [Fstream.from f] returns a stream built from the function [f]. - To create a new stream element, the function [f] is called with - the current stream count. The user function [f] must return either - [Some ] for a value or [None] to specify the end of the - stream. *) - -value of_list : list 'a -> t 'a; - (* Return the stream holding the elements of the list in the same - order. *) -value of_string : string -> t char; - (* Return the stream of the characters of the string parameter. *) -value of_channel : in_channel -> t char; - (* Return the stream of the characters read from the input channel. *) - -value iter : ('a -> unit) -> t 'a -> unit; - (* [Fstream.iter f s] scans the whole stream s, applying function [f] - in turn to each stream element encountered. *) - -value next : t 'a -> option ('a * t 'a); - (* Return [Some (a, s)] where [a] is the first element of the stream - and [s] the remaining stream, or [None] if the stream is empty. *) -value empty : t 'a -> option (unit * t 'a); - (* Return [Some ((), s)] if the stream is empty where [s] is itself, - else [None] *) -value count : t 'a -> int; - (* Return the current count of the stream elements, i.e. the number - of the stream elements discarded. *) -value count_unfrozen : t 'a -> int; - (* Return the number of unfrozen elements in the beginning of the - stream; useful to determine the position of a parsing error (longuest - path). *) - -(*--*) - -value nil : t 'a; -type data 'a = 'x; -value cons : 'a -> t 'a -> data 'a; -value app : t 'a -> t 'a -> data 'a; -value flazy : (unit -> data 'a) -> t 'a; diff --git a/camlp4/lib/gramext.ml b/camlp4/lib/gramext.ml deleted file mode 100644 index 980f0918d8..0000000000 --- a/camlp4/lib/gramext.ml +++ /dev/null @@ -1,565 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -open Printf; - -type grammar 'te = - { gtokens : Hashtbl.t Token.pattern (ref int); - glexer : mutable Token.glexer 'te } -; - -type g_entry 'te = - { egram : grammar 'te; - ename : string; - estart : mutable int -> Stream.t 'te -> Obj.t; - econtinue : mutable int -> int -> Obj.t -> Stream.t 'te -> Obj.t; - edesc : mutable g_desc 'te } -and g_desc 'te = - [ Dlevels of list (g_level 'te) - | Dparser of Stream.t 'te -> Obj.t ] -and g_level 'te = - { assoc : g_assoc; - lname : option string; - lsuffix : g_tree 'te; - lprefix : g_tree 'te } -and g_assoc = - [ NonA - | RightA - | LeftA ] -and g_symbol 'te = - [ Smeta of string and list (g_symbol 'te) and Obj.t - | Snterm of g_entry 'te - | Snterml of g_entry 'te and string - | Slist0 of g_symbol 'te - | Slist0sep of g_symbol 'te and g_symbol 'te - | Slist1 of g_symbol 'te - | Slist1sep of g_symbol 'te and g_symbol 'te - | Sopt of g_symbol 'te - | Sself - | Snext - | Stoken of Token.pattern - | Stree of g_tree 'te ] -and g_action = Obj.t -and g_tree 'te = - [ Node of g_node 'te - | LocAct of g_action and list g_action - | DeadEnd ] -and g_node 'te = - { node : g_symbol 'te; son : g_tree 'te; brother : g_tree 'te } -; - -type position = - [ First - | Last - | Before of string - | After of string - | Level of string ] -; - -value warning_verbose = ref True; - -value rec derive_eps = - fun - [ Slist0 _ -> True - | Slist0sep _ _ -> True - | Sopt _ -> True - | Stree t -> tree_derive_eps t - | Smeta _ _ _ | Slist1 _ | Slist1sep _ _ | Snterm _ | Snterml _ _ | Snext | - Sself | Stoken _ -> - 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 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) -> eq_symbol s1 s2 - | (Slist0sep s1 sep1, Slist0sep s2 sep2) -> - eq_symbol s1 s2 && eq_symbol sep1 sep2 - | (Slist1 s1, Slist1 s2) -> eq_symbol s1 s2 - | (Slist1sep s1 sep1, Slist1sep s2 sep2) -> - eq_symbol s1 s2 && eq_symbol sep1 sep2 - | (Sopt s1, Sopt s2) -> eq_symbol s1 s2 - | (Stree _, Stree _) -> False - | _ -> s1 = s2 ] -; - -value is_before s1 s2 = - match (s1, s2) with - [ (Stoken ("ANY", _), _) -> False - | (_, Stoken ("ANY", _)) -> True - | (Stoken (_, s), Stoken (_, "")) when s <> "" -> True - | (Stoken _, Stoken _) -> False - | (Stoken _, _) -> True - | _ -> False ] -; - -value insert_tree entry_name 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 -> - do { - if warning_verbose.val then do { - eprintf " Grammar extension: "; - if entry_name <> "" then eprintf "in [%s], " entry_name - else (); - eprintf "some rule has been masked\n"; - flush stderr - } - else (); - 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 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 ] - and insert_new = - fun - [ [s :: sl] -> Node {node = s; son = insert_new sl; brother = DeadEnd} - | [] -> LocAct action [] ] - in - insert gsymbols tree -; - -value srules rl = - let t = - List.fold_left - (fun tree (symbols, action) -> insert_tree "" symbols action tree) - DeadEnd rl - in - Stree t -; - -external action : 'a -> g_action = "%identity"; - -value is_level_labelled n lev = - match lev.lname with - [ Some n1 -> n = n1 - | None -> False ] -; - -value insert_level entry_name e1 symbols action slev = - match e1 with - [ True -> - {assoc = slev.assoc; lname = slev.lname; - lsuffix = insert_tree entry_name symbols action slev.lsuffix; - lprefix = slev.lprefix} - | False -> - {assoc = slev.assoc; lname = slev.lname; lsuffix = slev.lsuffix; - lprefix = insert_tree entry_name symbols action slev.lprefix} ] -; - -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 lev n lname assoc = - let a = - match assoc with - [ None -> lev.assoc - | Some a -> - do { - if a <> lev.assoc && warning_verbose.val then do { - eprintf " Changing associativity of level \"%s\"\n" n; - flush stderr - } - else (); - a - } ] - in - do { - match lname with - [ Some n -> - if lname <> lev.lname && warning_verbose.val then do { - eprintf " Level label \"%s\" ignored\n" n; flush stderr - } - else () - | None -> () ]; - {assoc = a; lname = lev.lname; lsuffix = lev.lsuffix; - lprefix = lev.lprefix} - } -; - -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 stderr; - failwith "Grammar.extend" - } - | [lev :: levs] -> - if is_level_labelled n lev then ([], change_lev 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 stderr; - failwith "Grammar.extend" - } - | [lev :: levs] -> - if 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 stderr; - failwith "Grammar.extend" - } - | [lev :: levs] -> - if 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 lev "", 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 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 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 -> check_gram entry s - | Slist1 s -> check_gram entry s - | Sopt s -> check_gram entry s - | Stree t -> tree_check_gram entry t - | Snext | Sself | Stoken _ -> () ] -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 change_to_self entry = - fun - [ Snterm e when e == entry -> Sself - | x -> x ] -; - -value get_initial entry = - 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 -> insert s - | Slist1 s -> insert s - | Slist0sep s t -> do { insert s; insert t } - | Slist1sep s t -> do { insert s; insert t } - | Sopt s -> insert s - | Stree t -> tinsert t - | Stoken ("ANY", _) -> () - | Stoken tok -> - do { - gram.glexer.Token.tok_using tok; - let r = - try Hashtbl.find gram.gtokens tok with - [ Not_found -> - let r = ref 0 in - do { Hashtbl.add gram.gtokens tok r; r } ] - in - incr r - } - | Snterm _ | Snterml _ _ | Snext | Sself -> () ] - 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 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 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 entry symbols in - insert_tokens entry.egram symbols; - insert_level entry.ename e1 symbols action lev - }) - lev level - in - ([lev :: levs], empty_lev)) - ([], make_lev) rules - in - levs1 @ List.rev levs @ levs2 -; - -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) -> eq_symbols s1 s2 - | (Slist0sep s1 sep1, Slist0sep s2 sep2) -> - eq_symbols s1 s2 && eq_symbols sep1 sep2 - | (Slist1 s1, Slist1 s2) -> eq_symbols s1 s2 - | (Slist1sep s1 sep1, Slist1sep s2 sep2) -> - eq_symbols s1 s2 && eq_symbols sep1 sep2 - | (Sopt s1, Sopt s2) -> eq_symbols s1 s2 - | (Stree t1, Stree t2) -> eq_trees t1 t2 - | _ -> 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 -; - -(* [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 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 ] - | ([s :: sl], _) -> 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 - [ Stoken tok -> - let r = Hashtbl.find gram.gtokens tok in - do { - decr r; - if r.val == 0 then do { - Hashtbl.remove gram.gtokens tok; gram.glexer.Token.tok_removing tok - } - else () - } - | Smeta _ sl _ -> List.iter (decr_keyw_use gram) sl - | Slist0 s -> decr_keyw_use gram s - | Slist1 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 } - | Sopt s -> decr_keyw_use gram s - | Stree t -> decr_keyw_use_in_tree gram t - | Sself | Snext | Snterm _ | Snterml _ _ -> () ] -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 Not_found ] -; - -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 Not_found ] -; - -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 ] -; diff --git a/camlp4/lib/gramext.mli b/camlp4/lib/gramext.mli deleted file mode 100644 index bd0fed514b..0000000000 --- a/camlp4/lib/gramext.mli +++ /dev/null @@ -1,81 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -type grammar 'te = - { gtokens : Hashtbl.t Token.pattern (ref int); - glexer : mutable Token.glexer 'te } -; - -type g_entry 'te = - { egram : grammar 'te; - ename : string; - estart : mutable int -> Stream.t 'te -> Obj.t; - econtinue : mutable int -> int -> Obj.t -> Stream.t 'te -> Obj.t; - edesc : mutable g_desc 'te } -and g_desc 'te = - [ Dlevels of list (g_level 'te) - | Dparser of Stream.t 'te -> Obj.t ] -and g_level 'te = - { assoc : g_assoc; - lname : option string; - lsuffix : g_tree 'te; - lprefix : g_tree 'te } -and g_assoc = - [ NonA - | RightA - | LeftA ] -and g_symbol 'te = - [ Smeta of string and list (g_symbol 'te) and Obj.t - | Snterm of g_entry 'te - | Snterml of g_entry 'te and string - | Slist0 of g_symbol 'te - | Slist0sep of g_symbol 'te and g_symbol 'te - | Slist1 of g_symbol 'te - | Slist1sep of g_symbol 'te and g_symbol 'te - | Sopt of g_symbol 'te - | Sself - | Snext - | Stoken of Token.pattern - | Stree of g_tree 'te ] -and g_action = Obj.t -and g_tree 'te = - [ Node of g_node 'te - | LocAct of g_action and list g_action - | DeadEnd ] -and g_node 'te = - { node : g_symbol 'te; son : g_tree 'te; brother : g_tree 'te } -; - -type position = - [ First - | Last - | Before of string - | After of string - | Level of string ] -; - -value levels_of_rules : - g_entry 'te -> option position -> - list - (option string * option g_assoc * - list (list (g_symbol 'te) * g_action)) -> - list (g_level 'te); -value srules : list (list (g_symbol 'te) * g_action) -> g_symbol 'te; -external action : 'a -> g_action = "%identity"; - -value delete_rule_in_level_list : - g_entry 'te -> list (g_symbol 'te) -> list (g_level 'te) -> - list (g_level 'te); - -value warning_verbose : ref bool; diff --git a/camlp4/lib/grammar.ml b/camlp4/lib/grammar.ml deleted file mode 100644 index b8c22d5073..0000000000 --- a/camlp4/lib/grammar.ml +++ /dev/null @@ -1,1064 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -open Stdpp; -open Gramext; -open Format; - -value rec flatten_tree = - fun - [ DeadEnd -> [] - | LocAct _ _ -> [[]] - | Node {node = n; brother = b; son = s} -> - List.map (fun l -> [n :: l]) (flatten_tree s) @ flatten_tree b ] -; - -value print_str ppf s = fprintf ppf "\"%s\"" (String.escaped s); - -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 - | Stoken (con, prm) when con <> "" && prm <> "" -> - fprintf ppf "%s@ %a" con print_str prm - | Snterml e l -> fprintf ppf "%s@ LEVEL@ %a" e.ename print_str l - | Snterm _ | Snext | Sself | Stoken _ | Stree _ 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 ("", s) -> print_str ppf s - | Stoken (con, "") -> pp_print_string ppf con - | Stree t -> print_level ppf pp_print_space (flatten_tree t) - | Smeta _ _ _ | Snterml _ _ | Slist0 _ | Slist0sep _ _ | Slist1 _ | - Slist1sep _ _ | Sopt _ | Stoken _ as s -> - fprintf ppf "(%a)" print_symbol s ] -and print_rule ppf symbols = - do { - fprintf ppf "@["; - let _ = - List.fold_left - (fun sep symbol -> - do { - fprintf ppf "%t%a" sep print_symbol symbol; - fun ppf -> fprintf ppf ";@ " - }) - (fun ppf -> ()) symbols - in - fprintf ppf "@]" - } -and print_level ppf pp_print_space rules = - do { - fprintf ppf "@[[ "; - 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 ppf -> ()) rules - in - fprintf ppf " ]@]" - } -; - -value print_levels ppf elev = - let _ = - List.fold_left - (fun sep lev -> - let rules = - List.map (fun t -> [Sself :: t]) (flatten_tree lev.lsuffix) @ - flatten_tree lev.lprefix - in - do { - fprintf ppf "%t@[" sep; - match lev.lname with - [ Some n -> fprintf ppf "%a@;<1 2>" print_str 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 ppf -> ()) elev - in - () -; - -value print_entry ppf e = - do { - fprintf ppf "@[[ "; - match e.edesc with - [ Dlevels elev -> print_levels ppf elev - | Dparser _ -> fprintf ppf "" ]; - fprintf ppf " ]@]" - } -; - -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 -> do_symbol s - | Slist0sep s1 s2 | Slist1sep s1 s2 -> do { do_symbol s1; do_symbol s2 } - | Stree t -> do_tree t - | Sself | Snext | Stoken _ -> () ] - 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 -> 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 _ -> accu ] - in - do_entry init e -; - -type g = Gramext.grammar Token.t; - -external grammar_obj : g -> grammar Token.t = "%identity"; - -value floc = ref (fun _ -> failwith "internal error when computing location"); -value loc_of_token_interval bp ep = - if bp == ep then - if bp == 0 then (0, 1) - else - let a = snd (floc.val (bp - 1)) in - (a, a + 1) - else - let (bp1, bp2) = floc.val bp in - let (ep1, ep2) = floc.val (pred ep) in - (if bp1 < ep1 then bp1 else ep1, if bp2 > ep2 then bp2 else ep2) -; - -value rec name_of_symbol entry = - fun - [ Snterm e -> "[" ^ e.ename ^ "]" - | Snterml e l -> "[" ^ e.ename ^ " level " ^ l ^ "]" - | Sself | Snext -> "[" ^ entry.ename ^ "]" - | Stoken tok -> entry.egram.glexer.Token.tok_text tok - | _ -> "???" ] -; - -value rec get_token_list entry tokl last_tok tree = - match tree with - [ Node {node = (Stoken tok as s); 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 rec name_of_symbol_failed entry = - fun - [ Slist0 s -> name_of_symbol_failed entry s - | Slist0sep s _ -> name_of_symbol_failed entry s - | Slist1 s -> name_of_symbol_failed entry s - | Slist1sep s _ -> name_of_symbol_failed entry s - | Sopt 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 tok -> get_token_list entry [] tok 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, last_tok, son) -> - List.fold_left - (fun s tok -> - (if s = "" then "" else s ^ " ") ^ - entry.egram.glexer.Token.tok_text tok) - "" tokl ] - | DeadEnd | LocAct _ _ -> "???" ] -; - -value search_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 _ | Stoken _ | Stree _ - 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 ] - | Stree t -> - match search_tree t with - [ Some t -> Some (Stree t) - | None -> None ] - | _ -> None ] - in - search_levels levels - | Dparser _ -> tree ] -; - -value error_verbose = ref False; - -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 Obj.magic 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 Obj.magic 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" ] - | Sopt _ | Stree _ -> txt ^ " expected" - | _ -> txt ^ " expected after " ^ name_of_symbol entry prev_symb ] - in - do { - if error_verbose.val then do { - let tree = search_tree_in_entry prev_symb tree entry.edesc in - let ppf = err_formatter in - fprintf ppf "@[@,"; - fprintf ppf "----------------------------------@,"; - fprintf ppf "Parse error in entry [%s], rule:@;<0 2>" entry.ename; - fprintf ppf "@["; - print_level ppf pp_force_newline (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 -; - -external app : Obj.t -> 'a = "%identity"; - -value is_level_labelled n lev = - match lev.lname with - [ Some n1 -> n = n1 - | None -> False ] -; - -value level_number entry lab = - let rec lookup levn = - fun - [ [] -> failwith ("unknown level " ^ lab) - | [lev :: levs] -> - if 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 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 entry_of_symb entry = - fun - [ Sself | Snext -> entry - | Snterm e -> e - | Snterml e _ -> e - | _ -> 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 skip_if_empty bp p strm = - if Stream.count strm == bp then Gramext.action (fun a -> p strm) - else raise Stream.Failure -; - -value continue entry bp a s son p1 = - parser - [: a = (entry_of_symb entry s).econtinue 0 bp a; - act = p1 ? tree_failed entry a s son :] -> - Gramext.action (fun _ -> app act a) -; - -value do_recover parser_of_tree entry nlevn alevn bp a s son = - parser - [ [: a = parser_of_tree entry nlevn alevn (top_tree entry son) :] -> a - | [: a = skip_if_empty bp (parser []) :] -> a - | [: a = - continue entry bp a s son - (parser_of_tree entry nlevn alevn son) :] -> - a ] -; - -value strict_parsing = ref False; - -value recover parser_of_tree entry nlevn alevn bp a s son strm = - if strict_parsing.val then raise (Stream.Error (tree_failed entry a s son)) - else do_recover parser_of_tree entry nlevn alevn bp a s son strm -; - -value token_count = ref 0; - -value peek_nth n strm = - let list = Stream.npeek n strm in - do { - token_count.val := Stream.count strm + n; - let rec loop list n = - match (list, n) with - [ ([x :: _], 1) -> Some x - | ([_ :: l], n) -> loop l (n - 1) - | ([], _) -> None ] - in - loop list n - } -; - -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 :] -> app 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 :] -> app act a - | [: a = p2 :] -> a ] - | Node {node = s; son = son; brother = DeadEnd} -> - let tokl = - match s with - [ Stoken tok -> get_token_list entry [] tok 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 - parser bp [: a = ps; act = p1 bp a :] -> app 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 (Stoken last_tok) son in - parser_of_token_list entry.egram p1 tokl ] - | Node {node = s; son = son; brother = bro} -> - let tokl = - match s with - [ Stoken tok -> get_token_list entry [] tok 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 - parser bp - [ [: a = ps; act = p1 bp a :] -> app 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 (Stoken last_tok) son in - let p1 = parser_of_token_list entry.egram 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 bp a = - parser - [ [: a = p1 :] -> a - | [: a = recover parser_of_tree entry nlevn alevn bp a s son :] -> a - | [: :] -> raise (Stream.Error (tree_failed entry a s son)) ] -and parser_of_token_list gram p1 tokl = - loop 1 tokl where rec loop n = - fun - [ [tok :: tokl] -> - let tematch = gram.glexer.Token.tok_match tok in - match tokl with - [ [] -> - let ps strm = - match peek_nth n strm with - [ Some tok -> - let r = tematch tok in - do { for i = 1 to n do { Stream.junk strm }; Obj.repr r } - | None -> raise Stream.Failure ] - in - parser bp [: a = ps; act = p1 bp a :] -> app act a - | _ -> - let ps strm = - match peek_nth n strm with - [ Some tok -> tematch tok - | None -> raise Stream.Failure ] - in - let p1 = loop (n + 1) tokl in - parser - [: a = ps; s :] -> - let act = p1 s in - app act a ] - | [] -> invalid_arg "parser_of_token_list" ] -and parser_of_symbol entry nlevn = - fun - [ Smeta _ symbl act -> - let act = Obj.magic act entry symbl in - Obj.magic - (List.fold_left - (fun act symb -> Obj.magic act (parser_of_symbol entry nlevn symb)) - act symbl) - | 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 [] :] -> Obj.repr (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 ? symb_failed entry v sep symb; s :] -> - kont [a :: al] s - | [: :] -> al ] - in - parser - [ [: a = ps; s :] -> Obj.repr (List.rev (kont [a] s)) - | [: :] -> Obj.repr [] ] - | 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 :] -> Obj.repr (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 (symb_failed entry v sep symb)) ]; - s :] -> - kont [a :: al] s - | [: :] -> al ] - in - parser [: a = ps; s :] -> Obj.repr (List.rev (kont [a] s)) - | Sopt s -> - let ps = parser_of_symbol entry nlevn s in - parser - [ [: a = ps :] -> Obj.repr (Some a) - | [: :] -> Obj.repr None ] - | Stree t -> - let pt = parser_of_tree entry 1 0 t in - parser bp - [: a = pt :] ep -> - let loc = loc_of_token_interval bp ep in - app a 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 - | Stoken tok -> - let f = entry.egram.glexer.Token.tok_match tok in - fun strm -> - match Stream.peek strm with - [ Some tok -> - let r = f tok in - do { Stream.junk strm; Obj.repr r } - | None -> raise Stream.Failure ] ] -and parse_top_symb entry symb = - parser_of_symbol entry 0 (top_symb entry symb) -; - -value symb_failed_txt e s1 s2 = symb_failed e 0 s1 s2; - -value rec continue_parser_of_levels entry clevn = - fun - [ [] -> fun levn bp a -> 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 - [ [: a = p1 levn bp a :] -> a - | [: act = p2 :] ep -> - let a = app act a (loc_of_token_interval bp ep) in - entry.econtinue levn bp a strm ] ] ] -; - -value rec start_parser_of_levels entry clevn = - fun - [ [] -> fun levn -> 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 -> - match strm with parser bp - [ [: act = p2 :] ep -> - let a = app act (loc_of_token_interval bp ep) in - entry.econtinue levn bp a strm ] - | _ -> - fun levn strm -> - if levn > clevn then p1 levn strm - else - match strm with parser bp - [ [: act = p2 :] ep -> - let a = app act (loc_of_token_interval bp ep) in - entry.econtinue levn bp a strm - | [: a = p1 levn :] -> a ] ] ] ] -; - -value continue_parser_of_entry entry = - 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 p -> fun levn bp a -> parser [] ] -; - -value empty_entry ename levn strm = - raise (Stream.Error ("entry [" ^ ename ^ "] is empty")) -; - -value start_parser_of_entry entry = - match entry.edesc with - [ Dlevels [] -> empty_entry entry.ename - | Dlevels elev -> start_parser_of_levels entry 0 elev - | Dparser p -> fun levn strm -> p strm ] -; - -value parse_parsable entry efun (cs, (ts, fun_loc)) = - let restore = - let old_floc = floc.val in - let old_tc = token_count.val in - fun () -> do { floc.val := old_floc; token_count.val := old_tc } - in - let get_loc () = - try - let cnt = Stream.count ts in - let loc = fun_loc cnt in - if token_count.val - 1 <= cnt then loc - else (fst loc, snd (fun_loc (token_count.val - 1))) - with _ -> - (Stream.count cs, Stream.count cs + 1) - in - do { - floc.val := fun_loc; - token_count.val := 0; - try - let r = efun ts in - do { restore (); r } - with - [ Stream.Failure -> - let loc = get_loc () in - do { - restore (); - raise_with_loc loc - (Stream.Error ("illegal begin of " ^ entry.ename)) - } - | Stream.Error _ as exc -> - let loc = get_loc () in - do { restore (); raise_with_loc loc exc } - | exc -> - let loc = (Stream.count cs, Stream.count cs + 1) in - do { restore (); raise_with_loc loc exc } ] - } -; - -value wrap_parse entry efun cs = - let parsable = (cs, entry.egram.glexer.Token.tok_func cs) in - parse_parsable entry efun parsable -; - -value create_toktab () = Hashtbl.create 301; -value gcreate glexer = {gtokens = create_toktab (); glexer = glexer}; - -value tematch tparse tok = - match tparse tok with - [ Some p -> fun x -> p [: `x :] - | None -> Token.default_match tok ] -; -value glexer_of_lexer lexer = - {Token.tok_func = lexer.Token.func; Token.tok_using = lexer.Token.using; - Token.tok_removing = lexer.Token.removing; - Token.tok_match = tematch lexer.Token.tparse; - Token.tok_text = lexer.Token.text; Token.tok_comm = None} -; -value create lexer = gcreate (glexer_of_lexer lexer); - -(* Extend syntax *) - -value extend_entry entry position rules = - try - let elev = Gramext.levels_of_rules entry position rules in - do { - entry.edesc := Dlevels elev; - entry.estart := - fun lev strm -> - let f = start_parser_of_entry entry in - do { entry.estart := f; f lev strm }; - entry.econtinue := - fun lev bp a strm -> - let f = continue_parser_of_entry entry in - do { entry.econtinue := f; f lev bp a strm } - } - with - [ Token.Error s -> - do { - Printf.eprintf "Lexer initialization error:\n- %s\n" s; - flush stderr; - failwith "Grammar.extend" - } ] -; - -value extend entry_rules_list = - let gram = ref None in - List.iter - (fun (entry, position, rules) -> - do { - match gram.val with - [ Some g -> - if g != entry.egram then do { - Printf.eprintf "Error: entries with different grammars\n"; - flush stderr; - failwith "Grammar.extend" - } - else () - | None -> gram.val := Some entry.egram ]; - extend_entry entry position rules - }) - entry_rules_list -; - -(* Deleting a rule *) - -value delete_rule entry sl = - match entry.edesc with - [ Dlevels levs -> - let levs = Gramext.delete_rule_in_level_list entry sl levs in - do { - entry.edesc := Dlevels levs; - entry.estart := - fun lev strm -> - let f = start_parser_of_entry entry in - do { entry.estart := f; f lev strm }; - entry.econtinue := - fun lev bp a strm -> - let f = continue_parser_of_entry entry in - do { entry.econtinue := f; f lev bp a strm } - } - | Dparser _ -> () ] -; - -(* Unsafe *) - -value clear_entry e = - do { - e.estart := fun _ -> parser []; - e.econtinue := fun _ _ _ -> parser []; - match e.edesc with - [ Dlevels _ -> e.edesc := Dlevels [] - | Dparser _ -> () ] - } -; - -value gram_reinit g glexer = - do { Hashtbl.clear g.gtokens; g.glexer := glexer } -; - -value reinit_gram g lexer = gram_reinit g (glexer_of_lexer lexer); - -module Unsafe = - struct - value gram_reinit = gram_reinit; - value clear_entry = clear_entry; - value reinit_gram = reinit_gram; - end -; - -value find_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 find_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 _ -> None ] - and find_symbol_list = - fun - [ [s :: sl] -> - match find_symbol s with - [ None -> find_symbol_list sl - | x -> x ] - | [] -> None ] - and find_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 ] -; - -value of_entry e = e.egram; - -module Entry = - struct - type te = Token.t; - type e 'a = g_entry te; - value create g n = - {egram = g; ename = n; estart = empty_entry n; - econtinue _ _ _ = parser []; edesc = Dlevels []} - ; - value parse (entry : e 'a) cs : 'a = - Obj.magic (wrap_parse entry (entry.estart 0) cs) - ; - value parse_token (entry : e 'a) ts : 'a = Obj.magic (entry.estart 0 ts); - value name e = e.ename; - value of_parser g n (p : Stream.t te -> 'a) : e 'a = - {egram = g; ename = n; estart _ = Obj.magic p; - econtinue _ _ _ = parser []; edesc = Dparser (Obj.magic p)} - ; - external obj : e 'a -> Gramext.g_entry te = "%identity"; - value print e = printf "%a@." print_entry (obj e); - value find e s = find_entry (obj e) s; - end -; - -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 - } -; - -value glexer g = g.glexer; - -value warning_verbose = Gramext.warning_verbose; - -(* Functorial interface *) - -module type GLexerType = sig type te = 'x; value lexer : Token.glexer te; end; - -module type S = - sig - type te = 'x; - type parsable = 'x; - value parsable : Stream.t char -> parsable; - value tokens : string -> list (string * int); - value glexer : Token.glexer te; - module Entry : - sig - type e 'a = 'x; - value create : string -> e 'a; - value parse : e 'a -> parsable -> 'a; - value parse_token : e 'a -> Stream.t te -> 'a; - value name : e 'a -> string; - value of_parser : string -> (Stream.t te -> 'a) -> e 'a; - value print : e 'a -> unit; - external obj : e 'a -> Gramext.g_entry te = "%identity"; - end - ; - module Unsafe : - sig - value gram_reinit : Token.glexer te -> unit; - value clear_entry : Entry.e 'a -> unit; - value reinit_gram : Token.lexer -> unit; - end - ; - value extend : - Entry.e 'a -> option Gramext.position -> - list - (option string * option Gramext.g_assoc * - list (list (Gramext.g_symbol te) * Gramext.g_action)) -> - unit; - value delete_rule : Entry.e 'a -> list (Gramext.g_symbol te) -> unit; - end -; - -module type ReinitType = sig value reinit_gram : g -> Token.lexer -> unit; end -; - -module GGMake (R : ReinitType) (L : GLexerType) = - struct - type te = L.te; - type parsable = (Stream.t char * (Stream.t te * Token.location_function)); - value gram = gcreate L.lexer; - value parsable cs = (cs, L.lexer.Token.tok_func cs); - value tokens = tokens gram; - value glexer = glexer gram; - module Entry = - struct - type e 'a = g_entry te; - value create n = - {egram = gram; ename = n; estart = empty_entry n; - econtinue _ _ _ = parser []; edesc = Dlevels []} - ; - external obj : e 'a -> Gramext.g_entry te = "%identity"; - value parse (e : e 'a) p : 'a = - Obj.magic (parse_parsable e (e.estart 0) p) - ; - value parse_token (e : e 'a) ts : 'a = Obj.magic (e.estart 0 ts); - value name e = e.ename; - value of_parser n (p : Stream.t te -> 'a) : e 'a = - {egram = gram; ename = n; estart _ = Obj.magic p; - econtinue _ _ _ = parser []; edesc = Dparser (Obj.magic p)} - ; - value print e = printf "%a@." print_entry (obj e); - end - ; - module Unsafe = - struct - value gram_reinit = gram_reinit gram; - value clear_entry = Unsafe.clear_entry; - value reinit_gram = R.reinit_gram (Obj.magic gram); - end - ; - value extend = extend_entry; - value delete_rule e r = delete_rule (Entry.obj e) r; - end -; - -module GMake (L : GLexerType) = - GGMake - (struct - value reinit_gram _ _ = - failwith "call of deprecated reinit_gram in grammar built by GMake" - ; - end) - L -; - -module type LexerType = sig value lexer : Token.lexer; end; - -module Make (L : LexerType) = - GGMake (struct value reinit_gram = reinit_gram; end) - (struct type te = Token.t; value lexer = glexer_of_lexer L.lexer; end) -; diff --git a/camlp4/lib/grammar.mli b/camlp4/lib/grammar.mli deleted file mode 100644 index fe8345fb36..0000000000 --- a/camlp4/lib/grammar.mli +++ /dev/null @@ -1,209 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(** Extensible grammars. - - This module implements the Camlp4 extensible grammars system. - Grammars entries can be extended using the [EXTEND] statement, - added by loading the Camlp4 [pa_extend.cmo] file. *) - -type g = 'x; - (** The type for grammars, holding entries. *) -value gcreate : Token.glexer Token.t -> g; - (** Create a new grammar, without keywords, using the lexer given - as parameter. *) -value tokens : g -> string -> list (string * int); - (** Given a grammar and a token pattern constructor, returns the list of - the corresponding values currently used in all entries of this grammar. - The integer is the number of times this pattern value is used. - - Examples: -- If the associated lexer uses ("", xxx) to represent a keyword - (what is represented by then simple string xxx in an [EXTEND] - statement rule), the call [Grammar.token g ""] returns the keywords - list. -- The call [Grammar.token g "IDENT"] returns the list of all usages - of the pattern "IDENT" in the [EXTEND] statements. *) -value glexer : g -> Token.glexer Token.t; - (** Return the lexer used by the grammar *) - -module Entry : - sig - type e 'a = 'x; - value create : g -> string -> e 'a; - value parse : e 'a -> Stream.t char -> 'a; - value parse_token : e 'a -> Stream.t Token.t -> 'a; - value name : e 'a -> string; - value of_parser : g -> string -> (Stream.t Token.t -> 'a) -> e 'a; - value print : e 'a -> unit; - value find : e 'a -> string -> e Obj.t; - external obj : e 'a -> Gramext.g_entry Token.t = "%identity"; - end -; - (** Module to handle entries. -- [Entry.e] is the type for entries returning values of type ['a]. -- [Entry.create g n] creates a new entry named [n] in the grammar [g]. -- [Entry.parse e] returns the stream parser of the entry [e]. -- [Entry.parse_token e] returns the token parser of the entry [e]. -- [Entry.name e] returns the name of the entry [e]. -- [Entry.of_parser g n p] makes an entry from a token stream parser. -- [Entry.print e] displays the entry [e] using [Format]. -- [Entry.find e s] finds the entry named [s] in [e]'s rules. -- [Entry.obj e] converts an entry into a [Gramext.g_entry] allowing -- to see what it holds ([Gramext] is visible, but not documented). *) - -value of_entry : Entry.e 'a -> g; - (** Return the grammar associated with an entry. *) - -(** {6 Clearing grammars and entries} *) - -module Unsafe : - sig - value gram_reinit : g -> Token.glexer Token.t -> unit; - value clear_entry : Entry.e 'a -> unit; - (**/**) - (* deprecated since version 3.05; use rather function [gram_reinit] *) - value reinit_gram : g -> Token.lexer -> unit; - end -; - (** Module for clearing grammars and entries. To be manipulated with - care, because: 1) reinitializing a grammar destroys all tokens - and there may have problems with the associated lexer if it has - a notion of keywords; 2) clearing an entry does not destroy the - tokens used only by itself. -- [Unsafe.reinit_gram g lex] removes the tokens of the grammar -- and sets [lex] as a new lexer for [g]. Warning: the lexer -- itself is not reinitialized. -- [Unsafe.clear_entry e] removes all rules of the entry [e]. *) - -(** {6 Functorial interface} *) - - (** Alternative for grammars use. Grammars are no more Ocaml values: - there is no type for them. Modules generated preserve the - rule "an entry cannot call an entry of another grammar" by - normal OCaml typing. *) - -module type GLexerType = - sig - type te = 'x; - value lexer : Token.glexer te; - end; - (** The input signature for the functor [Grammar.GMake]: [te] is the - type of the tokens. *) - -module type S = - sig - type te = 'x; - type parsable = 'x; - value parsable : Stream.t char -> parsable; - value tokens : string -> list (string * int); - value glexer : Token.glexer te; - module Entry : - sig - type e 'a = 'y; - value create : string -> e 'a; - value parse : e 'a -> parsable -> 'a; - value parse_token : e 'a -> Stream.t te -> 'a; - value name : e 'a -> string; - value of_parser : string -> (Stream.t te -> 'a) -> e 'a; - value print : e 'a -> unit; - external obj : e 'a -> Gramext.g_entry te = "%identity"; - end - ; - module Unsafe : - sig - value gram_reinit : Token.glexer te -> unit; - value clear_entry : Entry.e 'a -> unit; - (**/**) - (* deprecated since version 3.05; use rather [gram_reinit] *) - (* warning: [reinit_gram] fails if used with GMake *) - value reinit_gram : Token.lexer -> unit; - end - ; - value extend : - Entry.e 'a -> option Gramext.position -> - list - (option string * option Gramext.g_assoc * - list (list (Gramext.g_symbol te) * Gramext.g_action)) -> - unit; - value delete_rule : Entry.e 'a -> list (Gramext.g_symbol te) -> unit; - end -; - (** Signature type of the functor [Grammar.GMake]. The types and - functions are almost the same than in generic interface, but: -- Grammars are not values. Functions holding a grammar as parameter - do not have this parameter yet. -- The type [parsable] is used in function [parse] instead of - the char stream, avoiding the possible loss of tokens. -- The type of tokens (expressions and patterns) can be any - type (instead of (string * string)); the module parameter - must specify a way to show them as (string * string) *) - -module GMake (L : GLexerType) : S with type te = L.te; - -(** {6 Miscellaneous} *) - -value error_verbose : ref bool; - (** Flag for displaying more information in case of parsing error; - default = [False] *) - -value warning_verbose : ref bool; - (** Flag for displaying warnings while extension; default = [True] *) - -value strict_parsing : ref bool; - (** Flag to apply strict parsing, without trying to recover errors; - default = [False] *) - -value print_entry : Format.formatter -> Gramext.g_entry 'te -> unit; - (** General printer for all kinds of entries (obj entries) *) - -value iter_entry : - (Gramext.g_entry 'te -> unit) -> Gramext.g_entry 'te -> unit; - (** [Grammar.iter_entry f e] applies [f] to the entry [e] and - transitively all entries called by [e]. The order in which - the entries are passed to [f] is the order they appear in - each entry. Each entry is passed only once. *) - -value fold_entry : - (Gramext.g_entry 'te -> 'a -> 'a) -> Gramext.g_entry 'te -> 'a -> 'a; - (** [Grammar.fold_entry f e init] computes [(f eN .. (f e2 (f e1 init)))], - where [e1 .. eN] are [e] and transitively all entries called by [e]. - The order in which the entries are passed to [f] is the order they - appear in each entry. Each entry is passed only once. *) - -(**/**) - -(*** deprecated since version 3.05; use rather the functor GMake *) -module type LexerType = sig value lexer : Token.lexer; end; -module Make (L : LexerType) : S with type te = Token.t; -(*** deprecated since version 3.05; use rather the function gcreate *) -value create : Token.lexer -> g; - -(*** For system use *) - -value loc_of_token_interval : int -> int -> (int * int); -value extend : - list - (Gramext.g_entry 'te * option Gramext.position * - list - (option string * option Gramext.g_assoc * - list (list (Gramext.g_symbol 'te) * Gramext.g_action))) -> - unit; -value delete_rule : Entry.e 'a -> list (Gramext.g_symbol Token.t) -> unit; - -value parse_top_symb : - Gramext.g_entry 'te -> Gramext.g_symbol 'te -> Stream.t 'te -> Obj.t; -value symb_failed_txt : - Gramext.g_entry 'te -> Gramext.g_symbol 'te -> Gramext.g_symbol 'te -> - string; diff --git a/camlp4/lib/plexer.ml b/camlp4/lib/plexer.ml deleted file mode 100644 index 329380b267..0000000000 --- a/camlp4/lib/plexer.ml +++ /dev/null @@ -1,1006 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -open Stdpp; -open Token; - -value no_quotations = ref False; - -(* The string buffering machinery *) - -value buff = ref (String.create 80); -value store len x = - do { - if len >= String.length buff.val then - buff.val := buff.val ^ String.create (String.length buff.val) - else (); - buff.val.[len] := x; - succ len - } -; -value mstore len s = - add_rec len 0 where rec add_rec len i = - if i == String.length s then len else add_rec (store len s.[i]) (succ i) -; -value get_buff len = String.sub buff.val 0 len; - -(* The lexer *) - -value stream_peek_nth n strm = - loop n (Stream.npeek n strm) where rec loop n = - fun - [ [] -> None - | [x] -> if n == 1 then Some x else None - | [_ :: l] -> loop (n - 1) l ] -; - -value rec ident len = - parser - [ [: `('A'..'Z' | 'a'..'z' | '\192'..'\214' | '\216'..'\246' | - '\248'..'\255' | '0'..'9' | '_' | ''' as - c) - ; - s :] -> - ident (store len c) s - | [: :] -> len ] -and ident2 len = - parser - [ [: `('!' | '?' | '~' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' | - '%' | '.' | ':' | '<' | '>' | '|' | '$' as - c) - ; - s :] -> - ident2 (store len c) s - | [: :] -> len ] -and ident3 len = - parser - [ [: `('0'..'9' | 'A'..'Z' | 'a'..'z' | '\192'..'\214' | '\216'..'\246' | - '\248'..'\255' | '_' | '!' | '%' | '&' | '*' | '+' | '-' | '.' | - '/' | ':' | '<' | '=' | '>' | '?' | '@' | '^' | '|' | '~' | ''' | - '$' as - c) - ; - s :] -> - ident3 (store len c) s - | [: :] -> len ] -and base_number len = - parser - [ [: `'o' | 'O'; s :] -> digits octal (store len 'o') s - | [: `'x' | 'X'; s :] -> digits hexa (store len 'x') s - | [: `'b' | 'B'; s :] -> digits binary (store len 'b') s - | [: a = number len :] -> a ] -and digits kind len = - parser - [ [: d = kind; s :] -> digits_under kind (store len d) s - | [: :] -> raise (Stream.Error "ill-formed integer constant") ] -and digits_under kind len = - parser - [ [: d = kind; s :] -> digits_under kind (store len d) s - | [: `'_'; s :] -> digits_under kind len s - | [: :] -> ("INT", get_buff len) ] -and octal = parser [ [: `('0'..'7' as d) :] -> d ] -and hexa = parser [ [: `('0'..'9' | 'a'..'f' | 'A'..'F' as d) :] -> d ] -and binary = parser [ [: `('0'..'1' as d) :] -> d ] -and number len = - parser - [ [: `('0'..'9' as c); s :] -> number (store len c) s - | [: `'_'; s :] -> number len s - | [: `'.'; s :] -> decimal_part (store len '.') s - | [: `'e' | 'E'; s :] -> exponent_part (store len 'E') s - | [: `'l' :] -> ("INT32", get_buff len) - | [: `'L' :] -> ("INT64", get_buff len) - | [: `'n' :] -> ("NATIVEINT", get_buff len) - | [: :] -> ("INT", get_buff len) ] -and decimal_part len = - parser - [ [: `('0'..'9' as c); s :] -> decimal_part (store len c) s - | [: `'_'; s :] -> decimal_part len s - | [: `'e' | 'E'; s :] -> exponent_part (store len 'E') s - | [: :] -> ("FLOAT", get_buff len) ] -and exponent_part len = - parser - [ [: `('+' | '-' as c); s :] -> end_exponent_part (store len c) s - | [: a = end_exponent_part len :] -> a ] -and end_exponent_part len = - parser - [ [: `('0'..'9' as c); s :] -> end_exponent_part_under (store len c) s - | [: :] -> raise (Stream.Error "ill-formed floating-point constant") ] -and end_exponent_part_under len = - parser - [ [: `('0'..'9' as c); s :] -> end_exponent_part_under (store len c) s - | [: `'_'; s :] -> end_exponent_part_under len s - | [: :] -> ("FLOAT", get_buff len) ] -; - -value error_on_unknown_keywords = ref False; -value err loc msg = raise_with_loc loc (Token.Error msg); - -(* -value next_token_fun dfa find_kwd = - let keyword_or_error loc s = - try (("", find_kwd s), loc) with - [ Not_found -> - if error_on_unknown_keywords.val then err loc ("illegal token: " ^ s) - else (("", s), loc) ] - in - let rec next_token = - parser bp - [ [: `' ' | '\010' | '\013' | '\t' | '\026' | '\012'; s :] -> - next_token s - | [: `'('; s :] -> left_paren bp s - | [: `'#'; s :] -> do { spaces_tabs s; linenum bp s } - | [: `('A'..'Z' | '\192'..'\214' | '\216'..'\222' as c); s :] -> - let id = get_buff (ident (store 0 c) s) in - let loc = (bp, Stream.count s) in - (try ("", find_kwd id) with [ Not_found -> ("UIDENT", id) ], loc) - | [: `('a'..'z' | '\223'..'\246' | '\248'..'\255' | '_' as c); s :] -> - let id = get_buff (ident (store 0 c) s) in - let loc = (bp, Stream.count s) in - (try ("", find_kwd id) with [ Not_found -> ("LIDENT", id) ], loc) - | [: `('1'..'9' as c); s :] -> - let tok = number (store 0 c) s in - let loc = (bp, Stream.count s) in - (tok, loc) - | [: `'0'; s :] -> - let tok = base_number (store 0 '0') s in - let loc = (bp, Stream.count s) in - (tok, loc) - | [: `'''; s :] -> - match Stream.npeek 3 s with - [ [_; '''; _] | ['\\'; _; _] | ['\x0D'; '\x0A'; '''] -> - let tok = ("CHAR", get_buff (char bp 0 s)) in - let loc = (bp, Stream.count s) in - (tok, loc) - | _ -> keyword_or_error (bp, Stream.count s) "'" ] - | [: `'"'; s :] -> - let tok = ("STRING", get_buff (string bp 0 s)) in - let loc = (bp, Stream.count s) in - (tok, loc) - | [: `'$'; s :] -> - let tok = dollar bp 0 s in - let loc = (bp, Stream.count s) in - (tok, loc) - | [: `('!' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' | '%' as c); - s :] -> - let id = get_buff (ident2 (store 0 c) s) in - keyword_or_error (bp, Stream.count s) id - | [: `('~' as c); - a = - parser - [ [: `('a'..'z' as c); len = ident (store 0 c) :] ep -> - (("TILDEIDENT", get_buff len), (bp, ep)) - | [: s :] -> - let id = get_buff (ident2 (store 0 c) s) in - keyword_or_error (bp, Stream.count s) id ] :] -> - a - | [: `('?' as c); - a = - parser - [ [: `('a'..'z' as c); len = ident (store 0 c) :] ep -> - (("QUESTIONIDENT", get_buff len), (bp, ep)) - | [: s :] -> - let id = get_buff (ident2 (store 0 c) s) in - keyword_or_error (bp, Stream.count s) id ] :] -> - a - | [: `'<'; s :] -> less bp s - | [: `(':' as c1); - len = - parser - [ [: `(']' | ':' | '=' | '>' as c2) :] -> store (store 0 c1) c2 - | [: :] -> store 0 c1 ] :] ep -> - let id = get_buff len in - keyword_or_error (bp, ep) id - | [: `('>' | '|' as c1); - len = - parser - [ [: `(']' | '}' as c2) :] -> store (store 0 c1) c2 - | [: a = ident2 (store 0 c1) :] -> a ] :] ep -> - let id = get_buff len in - keyword_or_error (bp, ep) id - | [: `('[' | '{' as c1); s :] -> - let len = - match Stream.npeek 2 s with - [ ['<'; '<' | ':'] -> store 0 c1 - | _ -> - match s with parser - [ [: `('|' | '<' | ':' as c2) :] -> store (store 0 c1) c2 - | [: :] -> store 0 c1 ] ] - in - let ep = Stream.count s in - let id = get_buff len in - keyword_or_error (bp, ep) id - | [: `'.'; - id = - parser - [ [: `'.' :] -> ".." - | [: :] -> if ssd && after_space then " ." else "." ] :] ep -> - keyword_or_error (bp, ep) id - | [: `';'; - id = - parser - [ [: `';' :] -> ";;" - | [: :] -> ";" ] :] ep -> - keyword_or_error (bp, ep) id - | [: `'\\'; s :] ep -> (("LIDENT", get_buff (ident3 0 s)), (bp, ep)) - | [: `c :] ep -> keyword_or_error (bp, ep) (String.make 1 c) - | [: _ = Stream.empty :] -> (("EOI", ""), (bp, succ bp)) ] - and less bp strm = - if no_quotations.val then - match strm with parser - [ [: len = ident2 (store 0 '<') :] ep -> - let id = get_buff len in - keyword_or_error (bp, ep) id ] - else - match strm with parser - [ [: `'<'; len = quotation bp 0 :] ep -> - (("QUOTATION", ":" ^ get_buff len), (bp, ep)) - | [: `':'; i = parser [: len = ident 0 :] -> get_buff len; - `'<' ? "character '<' expected"; len = quotation bp 0 :] ep -> - (("QUOTATION", i ^ ":" ^ get_buff len), (bp, ep)) - | [: len = ident2 (store 0 '<') :] ep -> - let id = get_buff len in - keyword_or_error (bp, ep) id ] - and string bp len = - parser - [ [: `'"' :] -> len - | [: `'\\'; `c; s :] -> string bp (store (store len '\\') c) s - | [: `c; s :] -> string bp (store len c) s - | [: :] ep -> err (bp, ep) "string not terminated" ] - and char bp len = - parser - [ [: `'''; s :] -> if len = 0 then char bp (store len ''') s else len - | [: `'\\'; `c; s :] -> char bp (store (store len '\\') c) s - | [: `c; s :] -> char bp (store len c) s - | [: :] ep -> err (bp, ep) "char not terminated" ] - and dollar bp len = - parser - [ [: `'$' :] -> ("ANTIQUOT", ":" ^ get_buff len) - | [: `('a'..'z' | 'A'..'Z' as c); s :] -> antiquot bp (store len c) s - | [: `('0'..'9' as c); s :] -> maybe_locate bp (store len c) s - | [: `':'; s :] -> - let k = get_buff len in - ("ANTIQUOT", k ^ ":" ^ locate_or_antiquot_rest bp 0 s) - | [: `'\\'; `c; s :] -> - ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s) - | [: s :] -> - if dfa then - match s with parser - [ [: `c :] -> - ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s) - | [: :] ep -> err (bp, ep) "antiquotation not terminated" ] - else ("", get_buff (ident2 (store 0 '$') s)) ] - and maybe_locate bp len = - parser - [ [: `'$' :] -> ("ANTIQUOT", ":" ^ get_buff len) - | [: `('0'..'9' as c); s :] -> maybe_locate bp (store len c) s - | [: `':'; s :] -> - ("LOCATE", get_buff len ^ ":" ^ locate_or_antiquot_rest bp 0 s) - | [: `'\\'; `c; s :] -> - ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s) - | [: `c; s :] -> - ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s) - | [: :] ep -> err (bp, ep) "antiquotation not terminated" ] - and antiquot bp len = - parser - [ [: `'$' :] -> ("ANTIQUOT", ":" ^ get_buff len) - | [: `('a'..'z' | 'A'..'Z' | '0'..'9' as c); s :] -> - antiquot bp (store len c) s - | [: `':'; s :] -> - let k = get_buff len in - ("ANTIQUOT", k ^ ":" ^ locate_or_antiquot_rest bp 0 s) - | [: `'\\'; `c; s :] -> - ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s) - | [: `c; s :] -> - ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s) - | [: :] ep -> err (bp, ep) "antiquotation not terminated" ] - and locate_or_antiquot_rest bp len = - parser - [ [: `'$' :] -> get_buff len - | [: `'\\'; `c; s :] -> locate_or_antiquot_rest bp (store len c) s - | [: `c; s :] -> locate_or_antiquot_rest bp (store len c) s - | [: :] ep -> err (bp, ep) "antiquotation not terminated" ] - and quotation bp len = - parser - [ [: `'>'; s :] -> maybe_end_quotation bp len s - | [: `'<'; s :] -> - quotation bp (maybe_nested_quotation bp (store len '<') s) s - | [: `'\\'; - len = - parser - [ [: `('>' | '<' | '\\' as c) :] -> store len c - | [: :] -> store len '\\' ]; - s :] -> - quotation bp len s - | [: `c; s :] -> quotation bp (store len c) s - | [: :] ep -> err (bp, ep) "quotation not terminated" ] - and maybe_nested_quotation bp len = - parser - [ [: `'<'; s :] -> mstore (quotation bp (store len '<') s) ">>" - | [: `':'; len = ident (store len ':'); - a = - parser - [ [: `'<'; s :] -> mstore (quotation bp (store len '<') s) ">>" - | [: :] -> len ] :] -> - a - | [: :] -> len ] - and maybe_end_quotation bp len = - parser - [ [: `'>' :] -> len - | [: a = quotation bp (store len '>') :] -> a ] - and left_paren bp = - parser - [ [: `'*'; _ = comment bp; a = next_token True :] -> a - | [: :] ep -> keyword_or_error (bp, ep) "(" ] - and comment bp = - parser - [ [: `'('; s :] -> left_paren_in_comment bp s - | [: `'*'; s :] -> star_in_comment bp s - | [: `'"'; _ = string bp 0; s :] -> comment bp s - | [: `'''; s :] -> quote_in_comment bp s - | [: `c; s :] -> comment bp s - | [: :] ep -> err (bp, ep) "comment not terminated" ] - and quote_in_comment bp = - parser - [ [: `'''; s :] -> comment bp s - | [: `'\013'; s :] -> quote_cr_in_comment bp s - | [: `'\\'; s :] -> quote_antislash_in_comment bp s - | [: `'('; s :] -> quote_left_paren_in_comment bp s - | [: `'*'; s :] -> quote_star_in_comment bp s - | [: `'"'; s :] -> quote_doublequote_in_comment bp s - | [: `_; s :] -> quote_any_in_comment bp s - | [: s :] -> comment bp s ] - and quote_any_in_comment bp = - parser - [ [: `'''; s :] -> comment bp s - | [: s :] -> comment bp s ] - and quote_cr_in_comment bp = - parser - [ [: `'\010'; s :] -> quote_any_in_comment bp s - | [: s :] -> quote_any_in_comment bp s ] - and quote_left_paren_in_comment bp = - parser - [ [: `'''; s :] -> comment bp s - | [: s :] -> left_paren_in_comment bp s ] - and quote_star_in_comment bp = - parser - [ [: `'''; s :] -> comment bp s - | [: s :] -> star_in_comment bp s ] - and quote_doublequote_in_comment bp = - parser - [ [: `'''; s :] -> comment bp s - | [: _ = string bp 0; s :] -> comment bp s ] - and quote_antislash_in_comment bp = - parser - [ [: `'''; s :] -> quote_antislash_quote_in_comment bp s - | [: `('\\' | '"' | 'n' | 't' | 'b' | 'r'); s :] -> - quote_any_in_comment bp s - | [: `('0'..'9'); s :] -> quote_antislash_digit_in_comment bp s - | [: `'x'; s :] -> quote_antislash_x_in_comment bp s - | [: s :] -> comment bp s ] - and quote_antislash_quote_in_comment bp = - parser - [ [: `'''; s :] -> comment bp s - | [: s :] -> quote_in_comment bp s ] - and quote_antislash_digit_in_comment bp = - parser - [ [: `('0'..'9'); s :] -> quote_antislash_digit2_in_comment bp s - | [: s :] -> comment bp s ] - and quote_antislash_digit2_in_comment bp = - parser - [ [: `('0'..'9'); s :] -> quote_any_in_comment bp s - | [: s :] -> comment bp s ] - and quote_antislash_x_in_comment bp = - parser - [ [: _ = hexa; s :] -> quote_antislash_x_digit_in_comment bp s - | [: s :] -> comment bp s ] - and quote_antislash_x_digit_in_comment bp = - parser - [ [: _ = hexa; s :] -> quote_any_in_comment bp s - | [: s :] -> comment bp s ] - and left_paren_in_comment bp = - parser - [ [: `'*'; s :] -> do { comment bp s; comment bp s } - | [: a = comment bp :] -> a ] - and star_in_comment bp = - parser - [ [: `')' :] -> () - | [: a = comment bp :] -> a ] - and linedir n s = - match stream_peek_nth n s with - [ Some (' ' | '\t') -> linedir (n + 1) s - | Some ('0'..'9') -> linedir_digits (n + 1) s - | _ -> False ] - and linedir_digits n s = - match stream_peek_nth n s with - [ Some ('0'..'9') -> linedir_digits (n + 1) s - | _ -> linedir_quote n s ] - and linedir_quote n s = - match stream_peek_nth n s with - [ Some (' ' | '\t') -> linedir_quote (n + 1) s - | Some '"' -> True - | _ -> False ] - and any_to_nl = - parser - [ [: `'\013' | '\010' :] ep -> bolpos.val := ep - | [: `_; s :] -> any_to_nl s - | [: :] -> () ] - in - fun cstrm -> - try - let glex = glexr.val in - let comm_bp = Stream.count cstrm in - let r = next_token False cstrm in - do { - match glex.tok_comm with - [ Some list -> - if fst (snd r) > comm_bp then - let comm_loc = (comm_bp, fst (snd r)) in - glex.tok_comm := Some [comm_loc :: list] - else () - | None -> () ]; - r - } - with - [ Stream.Error str -> - err (Stream.count cstrm, Stream.count cstrm + 1) str ] -; -*) - -value next_token_fun dfa ssd find_kwd bolpos glexr = - let keyword_or_error loc s = - try (("", find_kwd s), loc) with - [ Not_found -> - if error_on_unknown_keywords.val then err loc ("illegal token: " ^ s) - else (("", s), loc) ] in - let error_if_keyword ( ((_,id), loc) as a) = - try do { - ignore(find_kwd id); - err loc ("illegal use of a keyword as a label: " ^ id) } - with [ Not_found -> a ] - in - let rec next_token after_space = - parser bp - [ [: `'\010' | '\013'; s :] ep -> - do { bolpos.val := ep; next_token True s } - | [: `' ' | '\t' | '\026' | '\012'; s :] -> next_token True s - | [: `'#' when bp = bolpos.val; s :] -> - if linedir 1 s then do { any_to_nl s; next_token True s } - else keyword_or_error (bp, bp + 1) "#" - | [: `'('; s :] -> left_paren bp s - | [: `('A'..'Z' | '\192'..'\214' | '\216'..'\222' as c); s :] -> - let id = get_buff (ident (store 0 c) s) in - let loc = (bp, Stream.count s) in - (try ("", find_kwd id) with [ Not_found -> ("UIDENT", id) ], loc) - | [: `('a'..'z' | '\223'..'\246' | '\248'..'\255' | '_' as c); s :] -> - let id = get_buff (ident (store 0 c) s) in - let loc = (bp, Stream.count s) in - (try ("", find_kwd id) with [ Not_found -> ("LIDENT", id) ], loc) - | [: `('1'..'9' as c); s :] -> - let tok = number (store 0 c) s in - let loc = (bp, Stream.count s) in - (tok, loc) - | [: `'0'; s :] -> - let tok = base_number (store 0 '0') s in - let loc = (bp, Stream.count s) in - (tok, loc) - | [: `'''; s :] -> - match Stream.npeek 2 s with - [ [_; '''] | ['\\'; _] -> - let tok = ("CHAR", get_buff (char bp 0 s)) in - let loc = (bp, Stream.count s) in - (tok, loc) - | _ -> keyword_or_error (bp, Stream.count s) "'" ] - | [: `'"'; s :] -> - let tok = ("STRING", get_buff (string bp 0 s)) in - let loc = (bp, Stream.count s) in - (tok, loc) - | [: `'$'; s :] -> - let tok = dollar bp 0 s in - let loc = (bp, Stream.count s) in - (tok, loc) - | [: `('!' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' | '%' as c); - s :] -> - let id = get_buff (ident2 (store 0 c) s) in - keyword_or_error (bp, Stream.count s) id - | [: `('~' as c); - a = - parser - [ [: `('a'..'z' as c); len = ident (store 0 c); s :] ep -> - let id = get_buff len in - match s with parser - [ [: `':' :] eb -> error_if_keyword (("LABEL", id), (bp,ep)) - | [: :] -> error_if_keyword (("TILDEIDENT", id), (bp, ep)) ] - | [: s :] -> - let id = get_buff (ident2 (store 0 c) s) in - keyword_or_error (bp, Stream.count s) id ] :] -> - a - - | [: `('?' as c); - a = - parser - [ [: `('a'..'z' as c); len = ident (store 0 c); s :] ep -> - let id = get_buff len in - match s with parser - [ [: `':' :] eb -> error_if_keyword (("OPTLABEL", id), (bp,ep)) - | [: :] -> error_if_keyword (("QUESTIONIDENT", id), (bp, ep)) ] - | [: s :] -> - let id = get_buff (ident2 (store 0 c) s) in - keyword_or_error (bp, Stream.count s) id ] :] -> - a - | [: `'<'; s :] -> less bp s - | [: `(':' as c1); - len = - parser - [ [: `(']' | ':' | '=' | '>' as c2) :] -> store (store 0 c1) c2 - | [: :] -> store 0 c1 ] :] ep -> - let id = get_buff len in - keyword_or_error (bp, ep) id - | [: `('>' | '|' as c1); - len = - parser - [ [: `(']' | '}' as c2) :] -> store (store 0 c1) c2 - | [: a = ident2 (store 0 c1) :] -> a ] :] ep -> - let id = get_buff len in - keyword_or_error (bp, ep) id - | [: `('[' | '{' as c1); s :] -> - let len = - match Stream.npeek 2 s with - [ ['<'; '<' | ':'] -> store 0 c1 - | _ -> - match s with parser - [ [: `('|' | '<' | ':' as c2) :] -> store (store 0 c1) c2 - | [: :] -> store 0 c1 ] ] - in - let ep = Stream.count s in - let id = get_buff len in - keyword_or_error (bp, ep) id - | [: `'.'; - id = - parser - [ [: `'.' :] -> ".." - | [: :] -> if ssd && after_space then " ." else "." ] :] ep -> - keyword_or_error (bp, ep) id - | [: `';'; - id = - parser - [ [: `';' :] -> ";;" - | [: :] -> ";" ] :] ep -> - keyword_or_error (bp, ep) id - | [: `'\\'; s :] ep -> (("LIDENT", get_buff (ident3 0 s)), (bp, ep)) - | [: `c :] ep -> keyword_or_error (bp, ep) (String.make 1 c) - | [: _ = Stream.empty :] -> (("EOI", ""), (bp, succ bp)) ] - and less bp strm = - if no_quotations.val then - match strm with parser - [ [: len = ident2 (store 0 '<') :] ep -> - let id = get_buff len in - keyword_or_error (bp, ep) id ] - else - match strm with parser - [ [: `'<'; len = quotation bp 0 :] ep -> - (("QUOTATION", ":" ^ get_buff len), (bp, ep)) - | [: `':'; i = parser [: len = ident 0 :] -> get_buff len; - `'<' ? "character '<' expected"; len = quotation bp 0 :] ep -> - (("QUOTATION", i ^ ":" ^ get_buff len), (bp, ep)) - | [: len = ident2 (store 0 '<') :] ep -> - let id = get_buff len in - keyword_or_error (bp, ep) id ] - and string bp len = - parser - [ [: `'"' :] -> len - | [: `'\\'; `c; s :] ep -> string bp (store (store len '\\') c) s - | [: `c; s :] -> string bp (store len c) s - | [: :] ep -> err (bp, ep) "string not terminated" ] - and char bp len = - parser - [ [: `'''; s :] -> if len = 0 then char bp (store len ''') s else len - | [: `'\\'; `c; s :] -> char bp (store (store len '\\') c) s - | [: `c; s :] -> char bp (store len c) s - | [: :] ep -> err (bp, ep) "char not terminated" ] - and dollar bp len = - parser - [ [: `'$' :] -> ("ANTIQUOT", ":" ^ get_buff len) - | [: `('a'..'z' | 'A'..'Z' as c); s :] -> antiquot bp (store len c) s - | [: `('0'..'9' as c); s :] -> maybe_locate bp (store len c) s - | [: `':'; s :] -> - let k = get_buff len in - ("ANTIQUOT", k ^ ":" ^ locate_or_antiquot_rest bp 0 s) - | [: `'\\'; `c; s :] -> - ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s) - | [: s :] -> - if dfa then - match s with parser - [ [: `c :] -> - ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s) - | [: :] ep -> err (bp, ep) "antiquotation not terminated" ] - else ("", get_buff (ident2 (store 0 '$') s)) ] - and maybe_locate bp len = - parser - [ [: `'$' :] -> ("ANTIQUOT", ":" ^ get_buff len) - | [: `('0'..'9' as c); s :] -> maybe_locate bp (store len c) s - | [: `':'; s :] -> - ("LOCATE", get_buff len ^ ":" ^ locate_or_antiquot_rest bp 0 s) - | [: `'\\'; `c; s :] -> - ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s) - | [: `c; s :] -> - ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s) - | [: :] ep -> err (bp, ep) "antiquotation not terminated" ] - and antiquot bp len = - parser - [ [: `'$' :] -> ("ANTIQUOT", ":" ^ get_buff len) - | [: `('a'..'z' | 'A'..'Z' | '0'..'9' as c); s :] -> - antiquot bp (store len c) s - | [: `':'; s :] -> - let k = get_buff len in - ("ANTIQUOT", k ^ ":" ^ locate_or_antiquot_rest bp 0 s) - | [: `'\\'; `c; s :] -> - ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s) - | [: `c; s :] -> - ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s) - | [: :] ep -> err (bp, ep) "antiquotation not terminated" ] - and locate_or_antiquot_rest bp len = - parser - [ [: `'$' :] -> get_buff len - | [: `'\\'; `c; s :] -> locate_or_antiquot_rest bp (store len c) s - | [: `c; s :] -> locate_or_antiquot_rest bp (store len c) s - | [: :] ep -> err (bp, ep) "antiquotation not terminated" ] - and quotation bp len = - parser - [ [: `'>'; s :] -> maybe_end_quotation bp len s - | [: `'<'; s :] -> - quotation bp (maybe_nested_quotation bp (store len '<') s) s - | [: `'\\'; - len = - parser - [ [: `('>' | '<' | '\\' as c) :] -> store len c - | [: :] -> store len '\\' ]; - s :] -> - quotation bp len s - | [: `c; s :] -> quotation bp (store len c) s - | [: :] ep -> err (bp, ep) "quotation not terminated" ] - and maybe_nested_quotation bp len = - parser - [ [: `'<'; s :] -> mstore (quotation bp (store len '<') s) ">>" - | [: `':'; len = ident (store len ':'); - a = - parser - [ [: `'<'; s :] -> mstore (quotation bp (store len '<') s) ">>" - | [: :] -> len ] :] -> - a - | [: :] -> len ] - and maybe_end_quotation bp len = - parser - [ [: `'>' :] -> len - | [: a = quotation bp (store len '>') :] -> a ] - and left_paren bp = - parser - [ [: `'*'; _ = comment bp; a = next_token True :] -> a - | [: :] ep -> keyword_or_error (bp, ep) "(" ] - and comment bp = - parser - [ [: `'('; s :] -> left_paren_in_comment bp s - | [: `'*'; s :] -> star_in_comment bp s - | [: `'"'; _ = string bp 0; s :] -> comment bp s - | [: `'''; s :] -> quote_in_comment bp s - | [: `c; s :] -> comment bp s - | [: :] ep -> err (bp, ep) "comment not terminated" ] - and quote_in_comment bp = - parser - [ [: `'''; s :] -> comment bp s - | [: `'\\'; s :] -> quote_antislash_in_comment bp 0 s - | [: s :] -> - do { - match Stream.npeek 2 s with - [ [_; '''] -> do { Stream.junk s; Stream.junk s } - | _ -> () ]; - comment bp s - } ] - and quote_any_in_comment bp = - parser - [ [: `'''; s :] -> comment bp s - | [: a = comment bp :] -> a ] - and quote_antislash_in_comment bp len = - parser - [ [: `'''; s :] -> comment bp s - | [: `'\\' | '"' | 'n' | 't' | 'b' | 'r'; s :] -> - quote_any_in_comment bp s - | [: `'0'..'9'; s :] -> quote_antislash_digit_in_comment bp s - | [: a = comment bp :] -> a ] - and quote_antislash_digit_in_comment bp = - parser - [ [: `'0'..'9'; s :] -> quote_antislash_digit2_in_comment bp s - | [: a = comment bp :] -> a ] - and quote_antislash_digit2_in_comment bp = - parser - [ [: `'0'..'9'; s :] -> quote_any_in_comment bp s - | [: a = comment bp :] -> a ] - and left_paren_in_comment bp = - parser - [ [: `'*'; s :] -> do { comment bp s; comment bp s } - | [: a = comment bp :] -> a ] - and star_in_comment bp = - parser - [ [: `')' :] -> () - | [: a = comment bp :] -> a ] - and linedir n s = - match stream_peek_nth n s with - [ Some (' ' | '\t') -> linedir (n + 1) s - | Some ('0'..'9') -> linedir_digits (n + 1) s - | _ -> False ] - and linedir_digits n s = - match stream_peek_nth n s with - [ Some ('0'..'9') -> linedir_digits (n + 1) s - | _ -> linedir_quote n s ] - and linedir_quote n s = - match stream_peek_nth n s with - [ Some (' ' | '\t') -> linedir_quote (n + 1) s - | Some '"' -> True - | _ -> False ] - and any_to_nl = - parser - [ [: `'\013' | '\010' :] ep -> bolpos.val := ep - | [: `_; s :] -> any_to_nl s - | [: :] -> () ] - in - fun cstrm -> - try - let glex = glexr.val in - let comm_bp = Stream.count cstrm in - let r = next_token False cstrm in - do { - match glex.tok_comm with - [ Some list -> - if fst (snd r) > comm_bp then - let comm_loc = (comm_bp, fst (snd r)) in - glex.tok_comm := Some [comm_loc :: list] - else () - | None -> () ]; - r - } - with - [ Stream.Error str -> - err (Stream.count cstrm, Stream.count cstrm + 1) str ] -; - - -value dollar_for_antiquotation = ref True; -value specific_space_dot = ref False; - -value func kwd_table glexr = - let bolpos = ref 0 in - let find = Hashtbl.find kwd_table in - let dfa = dollar_for_antiquotation.val in - let ssd = specific_space_dot.val in - Token.lexer_func_of_parser (next_token_fun dfa ssd find bolpos glexr) -; - -value rec check_keyword_stream = - parser [: _ = check; _ = Stream.empty :] -> True -and check = - parser - [ [: `'A'..'Z' | 'a'..'z' | '\192'..'\214' | '\216'..'\246' | '\248'..'\255' - ; - s :] -> - check_ident s - | [: `'!' | '?' | '~' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' | - '%' | '.' - ; - s :] -> - check_ident2 s - | [: `'<'; s :] -> - match Stream.npeek 1 s with - [ [':' | '<'] -> () - | _ -> check_ident2 s ] - | [: `':'; - _ = - parser - [ [: `']' | ':' | '=' | '>' :] -> () - | [: :] -> () ] :] ep -> - () - | [: `'>' | '|'; - _ = - parser - [ [: `']' | '}' :] -> () - | [: a = check_ident2 :] -> a ] :] -> - () - | [: `'[' | '{'; s :] -> - match Stream.npeek 2 s with - [ ['<'; '<' | ':'] -> () - | _ -> - match s with parser - [ [: `'|' | '<' | ':' :] -> () - | [: :] -> () ] ] - | [: `';'; - _ = - parser - [ [: `';' :] -> () - | [: :] -> () ] :] -> - () - | [: `_ :] -> () ] -and check_ident = - parser - [ [: `'A'..'Z' | 'a'..'z' | '\192'..'\214' | '\216'..'\246' | - '\248'..'\255' | '0'..'9' | '_' | ''' - ; - s :] -> - check_ident s - | [: :] -> () ] -and check_ident2 = - parser - [ [: `'!' | '?' | '~' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' | - '%' | '.' | ':' | '<' | '>' | '|' - ; - s :] -> - check_ident2 s - | [: :] -> () ] -; - -value check_keyword s = - try check_keyword_stream (Stream.of_string s) with _ -> False -; - -value error_no_respect_rules p_con p_prm = - raise - (Token.Error - ("the token " ^ - (if p_con = "" then "\"" ^ p_prm ^ "\"" - else if p_prm = "" then p_con - else p_con ^ " \"" ^ p_prm ^ "\"") ^ - " does not respect Plexer rules")) -; - -value error_ident_and_keyword p_con p_prm = - raise - (Token.Error - ("the token \"" ^ p_prm ^ "\" is used as " ^ p_con ^ - " and as keyword")) -; - -value using_token kwd_table ident_table (p_con, p_prm) = - match p_con with - [ "" -> - if not (Hashtbl.mem kwd_table p_prm) then - if check_keyword p_prm then - if Hashtbl.mem ident_table p_prm then - error_ident_and_keyword (Hashtbl.find ident_table p_prm) p_prm - else Hashtbl.add kwd_table p_prm p_prm - else error_no_respect_rules p_con p_prm - else () - | "LIDENT" -> - if p_prm = "" then () - else - match p_prm.[0] with - [ 'A'..'Z' -> error_no_respect_rules p_con p_prm - | _ -> - if Hashtbl.mem kwd_table p_prm then - error_ident_and_keyword p_con p_prm - else Hashtbl.add ident_table p_prm p_con ] - | "UIDENT" -> - if p_prm = "" then () - else - match p_prm.[0] with - [ 'a'..'z' -> error_no_respect_rules p_con p_prm - | _ -> - if Hashtbl.mem kwd_table p_prm then - error_ident_and_keyword p_con p_prm - else Hashtbl.add ident_table p_prm p_con ] - | "INT" | "INT32" | "INT64" | "NATIVEINT" - | "FLOAT" | "CHAR" | "STRING" - | "TILDEIDENT" | "QUESTIONIDENT" | "LABEL" | "OPTLABEL" - | "QUOTATION" | "ANTIQUOT" | "LOCATE" | "EOI" -> - () - | _ -> - raise - (Token.Error - ("the constructor \"" ^ p_con ^ - "\" is not recognized by Plexer")) ] -; - -value removing_token kwd_table ident_table (p_con, p_prm) = - match p_con with - [ "" -> Hashtbl.remove kwd_table p_prm - | "LIDENT" | "UIDENT" -> - if p_prm <> "" then Hashtbl.remove ident_table p_prm else () - | _ -> () ] -; - -value text = - fun - [ ("", t) -> "'" ^ t ^ "'" - | ("LIDENT", "") -> "lowercase identifier" - | ("LIDENT", t) -> "'" ^ t ^ "'" - | ("UIDENT", "") -> "uppercase identifier" - | ("UIDENT", t) -> "'" ^ t ^ "'" - | ("INT", "") -> "integer" - | ("INT32", "") -> "32 bits integer" - | ("INT64", "") -> "64 bits integer" - | ("NATIVEINT", "") -> "native integer" - | (("INT" | "INT32" | "NATIVEINT"), s) -> "'" ^ s ^ "'" - | ("FLOAT", "") -> "float" - | ("STRING", "") -> "string" - | ("CHAR", "") -> "char" - | ("QUOTATION", "") -> "quotation" - | ("ANTIQUOT", k) -> "antiquot \"" ^ k ^ "\"" - | ("LOCATE", "") -> "locate" - | ("EOI", "") -> "end of input" - | (con, "") -> con - | (con, prm) -> con ^ " \"" ^ prm ^ "\"" ] -; - -value eq_before_colon p e = - loop 0 where rec loop i = - if i == String.length e then - failwith "Internal error in Plexer: incorrect ANTIQUOT" - else if i == String.length p then e.[i] == ':' - else if p.[i] == e.[i] then loop (i + 1) - else False -; - -value after_colon e = - try - let i = String.index e ':' in - String.sub e (i + 1) (String.length e - i - 1) - with - [ Not_found -> "" ] -; - -value tok_match = - fun - [ ("ANTIQUOT", p_prm) -> - fun - [ ("ANTIQUOT", prm) when eq_before_colon p_prm prm -> after_colon prm - | _ -> raise Stream.Failure ] - | tok -> Token.default_match tok ] -; - -value gmake () = - let kwd_table = Hashtbl.create 301 in - let id_table = Hashtbl.create 301 in - let glexr = - ref - {tok_func = fun []; tok_using = fun []; tok_removing = fun []; - tok_match = fun []; tok_text = fun []; tok_comm = None} - in - let glex = - {tok_func = func kwd_table glexr; - tok_using = using_token kwd_table id_table; - tok_removing = removing_token kwd_table id_table; tok_match = tok_match; - tok_text = text; tok_comm = None} - in - do { glexr.val := glex; glex } -; - -value tparse = - fun - [ ("ANTIQUOT", p_prm) -> - let p = - parser - [: `("ANTIQUOT", prm) when eq_before_colon p_prm prm :] -> - after_colon prm - in - Some p - | _ -> None ] -; - -value make () = - let kwd_table = Hashtbl.create 301 in - let id_table = Hashtbl.create 301 in - let glexr = - ref - {tok_func = fun []; tok_using = fun []; tok_removing = fun []; - tok_match = fun []; tok_text = fun []; tok_comm = None} - in - {func = func kwd_table glexr; using = using_token kwd_table id_table; - removing = removing_token kwd_table id_table; tparse = tparse; text = text} -; diff --git a/camlp4/lib/plexer.mli b/camlp4/lib/plexer.mli deleted file mode 100644 index 32d8fe6b8e..0000000000 --- a/camlp4/lib/plexer.mli +++ /dev/null @@ -1,72 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(** A lexical analyzer. *) - -value gmake : unit -> Token.glexer Token.t; - (** Some lexer provided. See the module [Token]. The tokens returned - follow the Objective Caml and the Revised syntax lexing rules. - - The meaning of the tokens are: -- * [("", s)] is the keyword [s]. -- * [("LIDENT", s)] is the ident [s] starting with a lowercase letter. -- * [("UIDENT", s)] is the ident [s] starting with an uppercase letter. -- * [("INT", s)] (resp. ["INT32"], ["INT64"] and ["NATIVEINT"]) - is an integer constant whose string source is [s]. -- * [("FLOAT", s)] is a float constant whose string source is [s]. -- * [("STRING", s)] is the string constant [s]. -- * [("CHAR", s)] is the character constant [s]. -- * [("QUOTATION", "t:s")] is a quotation [t] holding the string [s]. -- * [("ANTIQUOT", "t:s")] is an antiquotation [t] holding the string [s]. -- * [("LOCATE", "i:s")] is a location directive at pos [i] holding [s]. -- * [("EOI", "")] is the end of input. - - The associated token patterns in the EXTEND statement hold the - same names than the first string (constructor name) of the tokens - expressions above. - - Warning: the string associated with the constructor [STRING] is - the string found in the source without any interpretation. In - particular, the backslashes are not interpreted. For example, if - the input is ["\n"] the string is *not* a string with one - element containing the character "return", but a string of two - elements: the backslash and the character ["n"]. To interpret - a string use the function [Token.eval_string]. Same thing for - the constructor [CHAR]: to get the character, don't get the - first character of the string, but use the function - [Token.eval_char]. - - The lexer do not use global (mutable) variables: instantiations - of [Plexer.gmake ()] do not perturb each other. *) - -value dollar_for_antiquotation : ref bool; - (** When True (default), the next call to [Plexer.make ()] returns a - lexer where the dollar sign is used for antiquotations. If False, - the dollar sign can be used as token. *) - -value specific_space_dot : ref bool; - (** When False (default), the next call to [Plexer.make ()] returns a - lexer where the dots can be preceded by spaces. If True, dots - preceded by spaces return the keyword " ." (space dot), otherwise - return the keyword "." (dot). *) - -value no_quotations : ref bool; - (** When True, all lexers built by [Plexer.make ()] do not lex the - quotation syntax any more. Default is False (quotations are - lexed). *) - -(**/**) - -(* deprecated since version 3.05; use rather function gmake *) -value make : unit -> Token.lexer; diff --git a/camlp4/lib/stdpp.ml b/camlp4/lib/stdpp.ml deleted file mode 100644 index a89cb15d8e..0000000000 --- a/camlp4/lib/stdpp.ml +++ /dev/null @@ -1,79 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -exception Exc_located of (int * int) and exn; - -value raise_with_loc loc exc = - match exc with - [ Exc_located _ _ -> raise exc - | _ -> raise (Exc_located loc exc) ] -; - -value line_of_loc fname (bp, ep) = - try - let ic = open_in_bin fname in - let strm = Stream.of_channel ic in - let rec loop fname lin = - let rec not_a_line_dir col = - parser cnt - [: `c; s :] -> - if cnt < bp then - if c = '\n' then loop fname (lin + 1) - else not_a_line_dir (col + 1) s - else - let col = col - (cnt - bp) in - (fname, lin, col, col + ep - bp) - in - let rec a_line_dir str n col = - parser - [ [: `'\n' :] -> loop str n - | [: `_; s :] -> a_line_dir str n (col + 1) s ] - in - let rec spaces col = - parser - [ [: `' '; s :] -> spaces (col + 1) s - | [: :] -> col ] - in - let rec check_string str n col = - parser - [ [: `'"'; col = spaces (col + 1); s :] -> a_line_dir str n col s - | [: `c when c <> '\n'; s :] -> - check_string (str ^ String.make 1 c) n (col + 1) s - | [: a = not_a_line_dir col :] -> a ] - in - let check_quote n col = - parser - [ [: `'"'; s :] -> check_string "" n (col + 1) s - | [: a = not_a_line_dir col :] -> a ] - in - let rec check_num n col = - parser - [ [: `('0'..'9' as c); s :] -> - check_num (10 * n + Char.code c - Char.code '0') (col + 1) s - | [: col = spaces col; s :] -> check_quote n col s ] - in - let begin_line = - parser - [ [: `'#'; col = spaces 1; s :] -> check_num 0 col s - | [: a = not_a_line_dir 0 :] -> a ] - in - begin_line strm - in - let r = try loop fname 1 with [ Stream.Failure -> (fname, 1, bp, ep) ] in - do { close_in ic; r } - with - [ Sys_error _ -> (fname, 1, bp, ep) ] -; - -value loc_name = ref "loc"; diff --git a/camlp4/lib/stdpp.mli b/camlp4/lib/stdpp.mli deleted file mode 100644 index 069e56bee3..0000000000 --- a/camlp4/lib/stdpp.mli +++ /dev/null @@ -1,37 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(** Standard definitions. *) - -exception Exc_located of (int * int) and exn; - (** [Exc_located loc e] is an encapsulation of the exception [e] with - the input location [loc]. To be used in quotation expanders - and in grammars to specify some input location for an error. - Do not raise this exception directly: rather use the following - function [raise_with_loc]. *) - -value raise_with_loc : (int * int) -> exn -> 'a; - (** [raise_with_loc loc e], if [e] is already the exception [Exc_located], - re-raise it, else raise the exception [Exc_located loc e]. *) - -value line_of_loc : string -> (int * int) -> (string * int * int * int); - (** [line_of_loc fname loc] reads the file [fname] up to the - location [loc] and returns the real input file, the line number - and the characters location in the line; the real input file - can be different from [fname] because of possibility of line - directives typically generated by /lib/cpp. *) - -value loc_name : ref string; - (** Name of the location variable used in grammars and in the predefined - quotations for OCaml syntax trees. Default: [loc] *) diff --git a/camlp4/lib/token.ml b/camlp4/lib/token.ml deleted file mode 100644 index e26798af9c..0000000000 --- a/camlp4/lib/token.ml +++ /dev/null @@ -1,229 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2001 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -type t = (string * string); -type pattern = (string * string); - -exception Error of string; - -type location = (int * int); -type location_function = int -> (int * int); -type lexer_func 'te = Stream.t char -> (Stream.t 'te * location_function); - -type glexer 'te = - { tok_func : lexer_func 'te; - tok_using : pattern -> unit; - tok_removing : pattern -> unit; - tok_match : pattern -> 'te -> string; - tok_text : pattern -> string; - tok_comm : mutable option (list location) } -; -type lexer = - { func : lexer_func t; - using : pattern -> unit; - removing : pattern -> unit; - tparse : pattern -> option (Stream.t t -> string); - text : pattern -> string } -; - -value lexer_text (con, prm) = - if con = "" then "'" ^ prm ^ "'" - else if prm = "" then con - else con ^ " '" ^ prm ^ "'" -; - -value locerr () = invalid_arg "Lexer: location function"; -value loct_create () = (ref (Array.create 1024 None), ref False); -value loct_func (loct, ov) i = - match - if i < 0 || i >= Array.length loct.val then - if ov.val then Some (0, 0) else None - else Array.unsafe_get loct.val i - with - [ Some loc -> loc - | _ -> locerr () ] -; -value loct_add (loct, ov) i loc = - if i >= Array.length loct.val then - let new_tmax = Array.length loct.val * 2 in - if new_tmax < Sys.max_array_length then do { - let new_loct = Array.create new_tmax None in - Array.blit loct.val 0 new_loct 0 (Array.length loct.val); - loct.val := new_loct; - loct.val.(i) := Some loc - } - else ov.val := True - else loct.val.(i) := Some loc -; - -value make_stream_and_location next_token_loc = - let loct = loct_create () in - let ts = - Stream.from - (fun i -> - let (tok, loc) = next_token_loc () in - do { loct_add loct i loc; Some tok }) - in - (ts, loct_func loct) -; - -value lexer_func_of_parser next_token_loc cs = - make_stream_and_location (fun () -> next_token_loc cs) -; - -value lexer_func_of_ocamllex lexfun cs = - let lb = - Lexing.from_function - (fun s n -> - try do { s.[0] := Stream.next cs; 1 } with [ Stream.Failure -> 0 ]) - in - let next_token_loc _ = - let tok = lexfun lb in - let loc = (Lexing.lexeme_start lb, Lexing.lexeme_end lb) in - (tok, loc) - in - make_stream_and_location next_token_loc -; - -(* Char and string tokens to real chars and string *) - -value buff = ref (String.create 80); -value store len x = - do { - if len >= String.length buff.val then - buff.val := buff.val ^ String.create (String.length buff.val) - else (); - buff.val.[len] := x; - succ len - } -; -value mstore len s = - add_rec len 0 where rec add_rec len i = - if i == String.length s then len else add_rec (store len s.[i]) (succ i) -; -value get_buff len = String.sub buff.val 0 len; - -value valch x = Char.code x - Char.code '0'; -value valch_a x = Char.code x - Char.code 'a' + 10; -value valch_A x = Char.code x - Char.code 'A' + 10; - -value rec backslash s i = - if i = String.length s then raise Not_found - else - match s.[i] with - [ 'n' -> ('\n', i + 1) - | 'r' -> ('\r', i + 1) - | 't' -> ('\t', i + 1) - | 'b' -> ('\b', i + 1) - | '\\' -> ('\\', i + 1) - | '"' -> ('"', i + 1) - | ''' -> (''', i + 1) - | '0'..'9' as c -> backslash1 (valch c) s (i + 1) - | 'x' -> backslash1h s (i + 1) - | _ -> raise Not_found ] -and backslash1 cod s i = - if i = String.length s then raise Not_found - else - match s.[i] with - [ '0'..'9' as c -> backslash2 (10 * cod + valch c) s (i + 1) - | _ -> raise Not_found ] -and backslash2 cod s i = - if i = String.length s then raise Not_found - else - match s.[i] with - [ '0'..'9' as c -> (Char.chr (10 * cod + valch c), i + 1) - | _ -> raise Not_found ] -and backslash1h s i = - if i = String.length s then raise Not_found - else - match s.[i] with - [ '0'..'9' as c -> backslash2h (valch c) s (i + 1) - | 'a'..'f' as c -> backslash2h (valch_a c) s (i + 1) - | 'A'..'F' as c -> backslash2h (valch_A c) s (i + 1) - | _ -> raise Not_found ] -and backslash2h cod s i = - if i = String.length s then ('\\', i - 2) - else - match s.[i] with - [ '0'..'9' as c -> (Char.chr (16 * cod + valch c), i + 1) - | 'a'..'f' as c -> (Char.chr (16 * cod + valch_a c), i + 1) - | 'A'..'F' as c -> (Char.chr (16 * cod + valch_A c), i + 1) - | _ -> raise Not_found ] -; - -value rec skip_indent s i = - if i = String.length s then i - else - match s.[i] with - [ ' ' | '\t' -> skip_indent s (i + 1) - | _ -> i ] -; - -value skip_opt_linefeed s i = - if i = String.length s then i else if s.[i] = '\010' then i + 1 else i -; - -value eval_char s = - if String.length s = 1 then s.[0] - else if String.length s = 0 then failwith "invalid char token" - else if s.[0] = '\\' then - if String.length s = 2 && s.[1] = ''' then ''' - else - try - let (c, i) = backslash s 1 in - if i = String.length s then c else raise Not_found - with - [ Not_found -> failwith "invalid char token" ] - else failwith "invalid char token" -; - -value eval_string (bp, ep) s = - loop 0 0 where rec loop len i = - if i = String.length s then get_buff len - else - let (len, i) = - if s.[i] = '\\' then - let i = i + 1 in - if i = String.length s then failwith "invalid string token" - else if s.[i] = '"' then (store len '"', i + 1) - else - match s.[i] with - [ '\010' -> (len, skip_indent s (i + 1)) - | '\013' -> (len, skip_indent s (skip_opt_linefeed s (i + 1))) - | c -> - try - let (c, i) = backslash s i in - (store len c, i) - with - [ Not_found -> do { - Printf.eprintf - "Warning: char %d, Invalid backslash escape in string\n%!" - (bp+i+1); - (store (store len '\\') c, i + 1) } ] ] - else (store len s.[i], i + 1) - in - loop len i -; - -value default_match = - fun - [ ("ANY", "") -> fun (con, prm) -> prm - | ("ANY", v) -> - fun (con, prm) -> if v = prm then v else raise Stream.Failure - | (p_con, "") -> - fun (con, prm) -> if con = p_con then prm else raise Stream.Failure - | (p_con, p_prm) -> - fun (con, prm) -> - if con = p_con && prm = p_prm then prm else raise Stream.Failure ] -; diff --git a/camlp4/lib/token.mli b/camlp4/lib/token.mli deleted file mode 100644 index fbd1aefd30..0000000000 --- a/camlp4/lib/token.mli +++ /dev/null @@ -1,133 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2001 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(** Lexers for Camlp4 grammars. - - This module defines the Camlp4 lexer type to be used in extensible - grammars (see module [Grammar]). It also provides some useful functions - to create lexers (this module should be renamed [Glexer] one day). *) - -type pattern = (string * string); - (** Token patterns come from the EXTEND statement. -- The first string is the constructor name (must start with - an uppercase character). When it is empty, the second string - is supposed to be a keyword. -- The second string is the constructor parameter. Empty if it - has no parameter. -- The way tokens patterns are interpreted to parse tokens is - done by the lexer, function [tok_match] below. *) - -exception Error of string; - (** An lexing error exception to be used by lexers. *) - -(** {6 Lexer type} *) - -type location = (int * int); -type location_function = int -> location; - (** The type for a function associating a number of a token in a stream - (starting from 0) to its source location. *) -type lexer_func 'te = Stream.t char -> (Stream.t 'te * location_function); - (** The type for a lexer function. The character stream is the input - stream to be lexed. The result is a pair of a token stream and - a location function for this tokens stream. *) - -type glexer 'te = - { tok_func : lexer_func 'te; - tok_using : pattern -> unit; - tok_removing : pattern -> unit; - tok_match : pattern -> 'te -> string; - tok_text : pattern -> string; - tok_comm : mutable option (list location) } -; - (** The type for a lexer used by Camlp4 grammars. -- The field [tok_func] is the main lexer function. See [lexer_func] - type above. This function may be created from a [char stream parser] - or for an [ocamllex] function using the functions below. -- The field [tok_using] is a function telling the lexer that the grammar - uses this token (pattern). The lexer can check that its constructor - is correct, and interpret some kind of tokens as keywords (to record - them in its tables). Called by [EXTEND] statements. -- The field [tok_removing] is a function telling the lexer that the - grammar does not uses the given token (pattern) any more. If the - lexer has a notion of "keywords", it can release it from its tables. - Called by [DELETE_RULE] statements. -- The field [tok_match] is a function taking a pattern and returning - a function matching a token against the pattern. Warning: for - efficency, write it as a function returning functions according - to the values of the pattern, not a function with two parameters. -- The field [tok_text] returns the name of some token pattern, - used in error messages. -- The field [tok_comm] if not None asks the lexer to record the - locations of the comments. *) - -value lexer_text : pattern -> string; - (** A simple [tok_text] function for lexers *) - -value default_match : pattern -> (string * string) -> string; - (** A simple [tok_match] function for lexers, appling to token type - [(string * string)] *) - -(** {6 Lexers from char stream parsers or ocamllex function} - - The functions below create lexer functions either from a [char stream] - parser or for an [ocamllex] function. With the returned function [f], - the simplest [Token.lexer] can be written: - {[ - { Token.tok_func = f; - Token.tok_using = (fun _ -> ()); - Token.tok_removing = (fun _ -> ()); - Token.tok_match = Token.default_match; - Token.tok_text = Token.lexer_text } - ]} - Note that a better [tok_using] function should check the used tokens - and raise [Token.Error] for incorrect ones. The other functions - [tok_removing], [tok_match] and [tok_text] may have other implementations - as well. *) - -value lexer_func_of_parser : - (Stream.t char -> ('te * location)) -> lexer_func 'te; - (** A lexer function from a lexer written as a char stream parser - returning the next token and its location. *) -value lexer_func_of_ocamllex : (Lexing.lexbuf -> 'te) -> lexer_func 'te; - (** A lexer function from a lexer created by [ocamllex] *) - -value make_stream_and_location : - (unit -> ('te * location)) -> (Stream.t 'te * location_function); - (** General function *) - -(** {6 Useful functions} *) - -value eval_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 eval_string : location -> string -> string; - (** Convert a string token, where the escape sequences (backslashes) - remain to be interpreted; issue a warning if an incorrect - backslash sequence is found; - [Token.eval_string loc (String.escaped s)] returns [s] *) - -(**/**) - -(* deprecated since version 3.05; use rather type glexer *) -type t = (string * string); -type lexer = - { func : lexer_func t; - using : pattern -> unit; - removing : pattern -> unit; - tparse : pattern -> option (Stream.t t -> string); - text : pattern -> string } -; diff --git a/camlp4/man/.cvsignore b/camlp4/man/.cvsignore deleted file mode 100644 index 2dc933cb1d..0000000000 --- a/camlp4/man/.cvsignore +++ /dev/null @@ -1,2 +0,0 @@ -camlp4.1 -camlp4.help diff --git a/camlp4/man/Makefile b/camlp4/man/Makefile deleted file mode 100644 index a7aa303478..0000000000 --- a/camlp4/man/Makefile +++ /dev/null @@ -1,28 +0,0 @@ -# $Id$ - -include ../config/Makefile - -TARGET=camlp4.1 -ALIASES=camlp4o.1 camlp4r.1 mkcamlp4.1 ocpp.1 camlp4o.opt.1 camlp4r.opt.1 - -all: $(TARGET) - -clean:: - rm -f $(TARGET) - -depend: - -get_promote: - -install: - if test -n '$(MANDIR)'; then \ - $(MKDIR) $(MANDIR)/man1 ; \ - cp $(TARGET) $(MANDIR)/man1/. ; \ - for i in $(ALIASES); do \ - rm -f $(MANDIR)/man1/$$i; \ - echo '.so man1/$(TARGET)' > $(MANDIR)/man1/$$i; \ - done; \ - fi - -camlp4.1: camlp4.1.tpl - sed -e "s'LIBDIR'$(LIBDIR)'g" camlp4.1.tpl > camlp4.1 diff --git a/camlp4/man/Makefile.Mac b/camlp4/man/Makefile.Mac deleted file mode 100644 index df95e66fb5..0000000000 --- a/camlp4/man/Makefile.Mac +++ /dev/null @@ -1,31 +0,0 @@ -####################################################################### -# # -# Camlp4 # -# # -# Damien Doligez, projet Para, INRIA Rocquencourt # -# # -# Copyright 1999 Institut National de Recherche en Informatique et # -# en Automatique. Distributed only by permission. # -# # -####################################################################### - -# $Id$ - -TARGETS = camlp4.help - -all Ä {TARGETS} - -clean ÄÄ - delete -i {TARGETS} - -depend Ä $OutOfDate - -get_promote Ä $OutOfDate - -install Ä - (newfolder "{MANDIR}" || set status 0) ³ dev:null - duplicate -y {TARGETS} "{MANDIR}" - -camlp4.help Ä camlp4.help.tpl - streamedit -e "1,$ replace -c ° /LIBDIR/ '{P4LIBDIR}'" camlp4.help.tpl ¶ - > camlp4.help diff --git a/camlp4/man/camlp4.1.tpl b/camlp4/man/camlp4.1.tpl deleted file mode 100644 index b40b5f9f0b..0000000000 --- a/camlp4/man/camlp4.1.tpl +++ /dev/null @@ -1,302 +0,0 @@ -.TH CAMLP4 1 "" "INRIA" -.SH NAME -camlp4 - Pre-Precessor-Pretty-Printer for OCaml -.br -mkcamlp4 - Create custom camlp4 -.br -ocpp - Universal preprocessor - -.SH SYNOPSIS -.B camlp4 -[ -load-options -] [--] [ -other-options -] -.br -.B camlp4o -[ -load-options -] [--] [ -other-options -] -.br -.B camlp4r -[ -load-options -] [--] [ -other-options -] -.br -.B camlp4sch -[ -load-options -] [--] [ -other-options -] -.br -.B camlp4o.cma -.br -.B camlp4r.cma -.br -.B camlp4sch.cma -.br -.B mkcamlp4 -.br -.B ocpp -[ -load-options -] -file -.LP -.br -.B camlp4o.opt -[--] [ -other-options -] -.br -.B camlp4r.opt -[--] [ -other-options -] - -.SH DESCRIPTION -.B camlp4 -is a Pre-Processor-Pretty-Printer for OCaml, parsing a source -file and printing some result on standard output. -.LP -.B camlp4o, -.B camlp4r -and -.B camlp4sch -are versions of -.B camlp4 -with some files already loaded (see further). -.LP -.B camlp4o.cma, -.B camlp4r.cma -and -.B camlp4sch.cma -are files to be loaded in ocaml toplevel to use the camlp4 machinery -.LP -.B mkcamlp4 -creates camlp4 executables with almost the same options than ocamlmktop. -See further. -.LP -.B ocpp -is an universal preprocessor, treating any kind of source file, -generating the same text with the possible quotations expanded. -.LP -.B camlp4o.opt -and -.B camlp4r.opt -are versions of camlp4o and camlp4r compiled by the native-code compiler -ocamlopt. They are faster but not extensible. And they are not available -in all installations of camlp4. - -.SH LOAD OPTIONS - -The load options select parsing and printing actions recorded in OCaml -object files (ending with .cmo or .cma). Several usage of these options -are authorized. They must precede the other options. - -.LP -An optionnal -.B \-\- -may end the load options. - -.TP -.BI \-I\ directory -Add -.I directory -in the search path for files loaded. Unless the option \-nolib is used, -the camlp4 library directory is appended to the path. Warning: there is -no automatic search in the current directory: add "\-I ." for this. -.TP -.B \-where -Print camlp4 library directory name and exit. -.TP -.B \-nolib -No automatic search for objects files in camlp4 library directory. -.TP -.BI object-file -The file is loaded in camlp4 core. - -.SH OTHER OPTIONS - -.LP -The others options are: - -.TP -.I file -Treat -.I file -as an interface file if it ends with .mli and as an implementation file -if it ends with .ml. - -.TP -.BI \-intf\ file -Treat -.I file -as an interface file, whatever its extension. -.TP -.BI \-impl\ file -Treat -.I file -as an implementation file, whatever its extension. -.TP -.B \-unsafe -Generate unsafe accesses to arrays and strings. -.TP -.B \-noassert -Do not compile assertion checks. -.TP -.B \-verbose -More verbose in parsing errors. -.TP -.BI \-QD\ file -Dump in -.I file -in case of syntax error in the result of a quotation expansion. -.TP -.BI \-o\ out-file -Print the result on out-file instead of standard output. File is opened -with open_out_bin (see OCaml library Pervasives). -.TP -.B \-v -Print the version number and exit. -.TP -.B \-help -Print the available options and exit. This print includes the options -possibly added by the loaded object files. - -.LP -The others options can be extended by loaded object files. The provided -files add the following options: - -.TP -.BI \-l\ line-length -Added by pr_o.cmo and pr_r.cmo: set the line length (default 78). -.TP -.BI \-sep\ string -Added by pr_o.cmo and pr_r.cmo: print this string between phrases instead -of comments. -.TP -.BI \-no_ss -Added by pr_o.cmo: do not print double semicolons -.TP -.BI \-D\ ident -Added by pa_macro.cmo: define the ident. -.TP -.BI \-U\ ident -Added by pa_macro.cmo: undefine the ident. - -.SH "PROVIDED FILES" -These files are installed in the directory LIBDIR/camlp4. - -.LP -Parsing files: -.nf -.ta 1c - pa_o.cmo: syntax of OCaml - pa_op.cmo: streams and parsers - pa_oop.cmo: streams and parsers (without code optimization) - pa_r.cmo: revised syntax - pa_rp.cmo: streams and parsers - pa_scheme.cmo: scheme syntax - pa_extend.cmo: syntax extension for grammars - pa_extfold.cmo: extension of pa_extend with FOLD0 and FOLD1 - pa_extfun.cmo: syntax extension for extensible functions - pa_fstream.cmo: syntax extension for functional streams - pa_macro.cmo: add macros (ifdef, define) like in C - pa_lefteval.cmo: left-to-right evaluation of parameters - pa_olabl.cmo: old syntax for labels -.fi -.LP -Printing files: -.nf -.ta 1c - pr_o.cmo: syntax of OCaml - pr_op.cmo: try to rebuild streams and parsers syntax - pr_r.cmo: revised syntax - pr_rp.cmo: try to rebuild streams and parsers syntax - pr_scheme.cmo: scheme syntax - pr_schemep.cmo: try to rebuild streams and parsers syntax - pr_extend.cmo: try to rebuild EXTEND statements - pr_extfun.cmo: try to rebuild extfun statements - pr_dump.cmo: syntax tree - pr_depend.cmo: file dependencies - pr_null.cmo: no output -.fi -.LP -Quotation expanders: -.nf -.ta 1c - q_MLast.cmo: syntax tree nodes - q_phony.cmo: keeping quotations for pretty printing -.fi -.LP -The command -.B camlp4o -is a shortcut for: -.nf -.ta 1c - camlp4 pa_o.cmo pa_op.cmo pr_dump.cmo -.fi -.LP -The command -.B camlp4r -is a shortcut for: -.nf -.ta 1c - camlp4 pa_r.cmo pa_rp.cmo pr_dump.cmo -.fi -.LP -The command -.B camlp4sch -is a shortcut for: -.nf -.ta 1c - camlp4 pa_scheme.cmo pr_dump.cmo -.fi -.LP -.LP -The file -.B camlp4o.cma -can be loaded in the toplevel to start camlp4 with OCaml syntax. -.LP -The file -.B camlp4r.cma -can be loaded in the toplevel to start camlp4 with revised syntax. -.LP -The file -.B camlp4sch.cma -can be loaded in the toplevel to start camlp4 with Scheme syntax. - -.SH "MKCAMLP4" - -.B mkcamlp4 -creates camlp4 executables with almost the same options than ocamlmktop. -The only difference is that the interfaces to be visible must be explicitly -added in the command line as ".cmi" files. For example, how to add the -the OCaml module "str": -.nf -.ta 1c 2c - mkcamlp4 -custom str.cmi str.cma -cclib -lstr \\ - -o camlp4str -.fi - -.SH "FILES" -Camlp4 library directory in the present installation: -.br -LIBDIR/camlp4 - -.SH "SEE ALSO" -Camlp4 - tutorial -.br -Camlp4 - reference manual -.br -ocamlc(1), ocaml(1). - -.SH AUTHOR -Daniel de Rauglaudre, INRIA Rocquencourt. diff --git a/camlp4/man/camlp4.help.tpl b/camlp4/man/camlp4.help.tpl deleted file mode 100644 index 8b13789179..0000000000 --- a/camlp4/man/camlp4.help.tpl +++ /dev/null @@ -1 +0,0 @@ - diff --git a/camlp4/meta/.cvsignore b/camlp4/meta/.cvsignore deleted file mode 100644 index 460c5a60df..0000000000 --- a/camlp4/meta/.cvsignore +++ /dev/null @@ -1,3 +0,0 @@ -*.cm[oia] -camlp4r -camlp4r.opt diff --git a/camlp4/meta/.depend b/camlp4/meta/.depend deleted file mode 100644 index 737ea5ec6b..0000000000 --- a/camlp4/meta/.depend +++ /dev/null @@ -1,16 +0,0 @@ -pa_extend.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi -pa_extend.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx -pa_extend_m.cmo: pa_extend.cmo -pa_extend_m.cmx: pa_extend.cmx -pa_ifdef.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi -pa_ifdef.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx -pa_macro.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi -pa_macro.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx -pa_r.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi -pa_r.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx -pa_rp.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi -pa_rp.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx -pr_dump.cmo: ../camlp4/ast2pt.cmi $(OTOP)/utils/config.cmi ../camlp4/pcaml.cmi -pr_dump.cmx: ../camlp4/ast2pt.cmx $(OTOP)/utils/config.cmx ../camlp4/pcaml.cmx -q_MLast.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi ../camlp4/quotation.cmi -q_MLast.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx ../camlp4/quotation.cmx diff --git a/camlp4/meta/Makefile b/camlp4/meta/Makefile deleted file mode 100644 index ba1481bed7..0000000000 --- a/camlp4/meta/Makefile +++ /dev/null @@ -1,59 +0,0 @@ -# $Id$ - -include ../config/Makefile - -INCLUDES=-I ../camlp4 -I ../boot -I $(OTOP)/utils -OCAMLCFLAGS=-warn-error A $(INCLUDES) -OBJS=q_MLast.cmo pa_r.cmo pa_rp.cmo pa_extend.cmo pa_extend_m.cmo pa_macro.cmo pr_dump.cmo -OBJSX=$(OBJS:.cmo=.cmx) -CAMLP4RM=pa_r.cmo pa_rp.cmo pr_dump.cmo -CAMLP4RMX=$(CAMLP4RM:.cmo=.cmx) -SHELL=/bin/sh -COUT=$(OBJS) camlp4r$(EXE) -COPT=$(OBJSX) camlp4r.opt - -all: $(COUT) -opt: $(COPT) - -camlp4r$(EXE): ../camlp4/camlp4$(EXE) $(CAMLP4RM) - rm -f camlp4r$(EXE) - cd ../camlp4; $(MAKE) OTOP=$(OTOP) CAMLP4=../meta/camlp4r$(EXE) CAMLP4M="-I ../meta $(CAMLP4RM)" - -camlp4r.opt: $(CAMLP4RMX) - rm -f camlp4r.opt - cd ../camlp4; $(MAKE) optp4 OTOP=$(OTOP) CAMLP4OPT=../meta/camlp4r.opt CAMLP4M="-I ../meta $(CAMLP4RMX)" - -clean:: - rm -f *.cm* *.pp[io] *.o *.bak .*.bak $(COUT) $(COPT) - -depend: - cp .depend .depend.bak - > .depend - @for i in *.mli *.ml; do \ - ../tools/apply.sh pr_depend.cmo -- $(INCLUDES) $$i | \ - sed -e 's| \.\./\.\.| $$(OTOP)|g' >> .depend; \ - done - -promote: - cp $(COUT) pa_extend.cmi ../boot/. - -compare: - @for j in $(COUT); do \ - if cmp $$j ../boot/$$j; then :; else exit 1; fi; \ - done - -install: - -$(MKDIR) "$(LIBDIR)/camlp4" "$(BINDIR)" - cp $(OBJS) "$(LIBDIR)/camlp4/." - cp pa_macro.cmi pa_extend.cmi "$(LIBDIR)/camlp4/." - cp camlp4r$(EXE) "$(BINDIR)/." - if test -f camlp4r.opt; then \ - cp camlp4r.opt "$(BINDIR)/camlp4r.opt$(EXE)" ;\ - for target in $(OBJSX) $(OBJSX:.cmx=.$(O)) ; do \ - if test -f $$target; then \ - cp $$target "$(LIBDIR)/camlp4/."; \ - fi; \ - done; \ - fi - -include .depend diff --git a/camlp4/meta/Makefile.Mac b/camlp4/meta/Makefile.Mac deleted file mode 100644 index 9451d5222c..0000000000 --- a/camlp4/meta/Makefile.Mac +++ /dev/null @@ -1,50 +0,0 @@ -####################################################################### -# # -# Camlp4 # -# # -# Damien Doligez, projet Para, INRIA Rocquencourt # -# # -# Copyright 1999 Institut National de Recherche en Informatique et # -# en Automatique. Distributed only by permission. # -# # -####################################################################### - -# $Id$ - -INCLUDES = -I ::camlp4: -I ::boot: -I "{OTOP}utils:" -OCAMLCFLAGS = {INCLUDES} -OBJS = q_MLast.cmo pa_r.cmo pa_rp.cmo pa_extend.cmo pa_extend_m.cmo ¶ - pa_ifdef.cmo pr_dump.cmo -CAMLP4RM = pa_r.cmo pa_rp.cmo pr_dump.cmo -OUT = {OBJS} camlp4r - -all Ä {OUT} - -camlp4r Ä ::camlp4:camlp4 {CAMLP4RM} - delete -i camlp4r - directory ::camlp4: - domake -d CAMLP4=::meta:camlp4r -d CAMLP4M="-I ::meta {CAMLP4RM}" - directory ::meta: - -clean ÄÄ - delete -i {OUT} - -{dependrule} - -promote Ä - duplicate -y {OUT} pa_extend.cmi ::boot: - -compare Ä - for i in {OUT} - equal -s {i} ::boot:{i} || exit 1 - end - -install Ä - (newfolder "{P4LIBDIR}" || set status 0) ³ dev:null - (newfolder "{BINDIR}" || set status 0) ³ dev:null - duplicate -y {OBJS} "{P4LIBDIR}" - duplicate -y camlp4r "{BINDIR}" - -{defrules} - -pr_dump.cmo Ä ::camlp4:ast2pt.cmo "{OTOP}utils:config.cmi" ::camlp4:pcaml.cmi diff --git a/camlp4/meta/Makefile.Mac.depend b/camlp4/meta/Makefile.Mac.depend deleted file mode 100644 index 29675238e9..0000000000 --- a/camlp4/meta/Makefile.Mac.depend +++ /dev/null @@ -1,12 +0,0 @@ -pa_extend.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi -pa_extend.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx -pa_extend_m.cmoÄ ::camlp4:mLast.cmi pa_extend.cmo -pa_extend_m.cmxÄ ::camlp4:mLast.cmi pa_extend.cmx -pa_macro.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi -pa_macro.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx -pa_r.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi -pa_r.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx -pa_rp.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi -pa_rp.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx -q_MLast.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi ::camlp4:quotation.cmi -q_MLast.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx ::camlp4:quotation.cmx diff --git a/camlp4/meta/mk_q_MLast.sh b/camlp4/meta/mk_q_MLast.sh deleted file mode 100755 index c678f350ad..0000000000 --- a/camlp4/meta/mk_q_MLast.sh +++ /dev/null @@ -1,12 +0,0 @@ -#!/bin/sh -# $Id$ - -IFILE=pa_r.ml -OFILE=q_MLast.ml -( -sed -e '/^EXTEND$/,$d' $OFILE -echo EXTEND -../../boot/ocamlrun ./camlp4r -I . -I ../etc q_MLast.cmo pa_extend.cmo pr_r.cmo pr_extend.cmo -cip -quotify $IFILE | sed -e '1,/^EXTEND$/d' -e '/^END;$/,$d' -echo ' (* Antiquotations for local entries *)' -sed -e '1,/Antiquotations for local entries/d' $OFILE -) diff --git a/camlp4/meta/pa_extend.ml b/camlp4/meta/pa_extend.ml deleted file mode 100644 index e8fed87b62..0000000000 --- a/camlp4/meta/pa_extend.ml +++ /dev/null @@ -1,916 +0,0 @@ -(* camlp4r pa_extend.cmo q_MLast.cmo *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -open Stdpp; - -value split_ext = ref False; - -Pcaml.add_option "-split_ext" (Arg.Set split_ext) - "Split EXTEND by functions to turn around a PowerPC problem."; - -Pcaml.add_option "-split_gext" (Arg.Set split_ext) - "Old name for the option -split_ext."; - -type loc = (int * int); - -type name 'e = { expr : 'e; tvar : string; loc : (int * int) }; - -type styp = - [ STlid of loc and string - | STapp of loc and styp and styp - | STquo of loc and string - | STself of loc and string - | STtyp of MLast.ctyp ] -; - -type text 'e = - [ TXmeta of loc and string and list (text 'e) and 'e and styp - | TXlist of loc and bool and text 'e and option (text 'e) - | TXnext of loc - | TXnterm of loc and name 'e and option string - | TXopt of loc and text 'e - | TXrules of loc and list (list (text 'e) * 'e) - | TXself of loc - | TXtok of loc and string and 'e ] -; - -type 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 (psymbol 'e 'p); action : option 'e } -and psymbol 'e 'p = { pattern : option 'p; symbol : symbol 'e 'p } -and symbol 'e 'p = { used : list string; text : text 'e; styp : styp } -; - -type used = [ Unused | UsedScanned | UsedNotScanned ]; - -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 s (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 ps -> mark_symbol modif ht ps.symbol) - rule.prod) - rules) - e.levels - } - else ()) - ht - }; - Hashtbl.iter - (fun s (r, e) -> - if r.val = Unused then - Pcaml.warning.val e.name.loc ("Unused local entry \"" ^ s ^ "\"") - else ()) - ht; - } -; - -value locate n = let loc = n.loc in <:expr< $n.expr$ >>; - -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.symbol.used @ nl) nl r.prod) [] - rl -; - -value retype_rule_list_without_patterns loc rl = - try - List.map - (fun - [ {prod = [{pattern = None; symbol = s}]; action = None} -> - {prod = [{pattern = Some <:patt< x >>; symbol = s}]; - action = Some <:expr< x >>} - | {prod = []; action = Some _} as r -> r - | _ -> raise Exit ]) - rl - with - [ Exit -> rl ] -; - -value quotify = ref False; -value meta_action = ref False; - -module MetaAction = - struct - value not_impl f x = - let desc = - if Obj.is_block (Obj.repr x) then - "tag = " ^ string_of_int (Obj.tag (Obj.repr x)) - else "int_val = " ^ string_of_int (Obj.magic x) - in - failwith (f ^ ", not impl: " ^ desc) - ; - value loc = (0, 0); - value rec mlist mf = - fun - [ [] -> <:expr< [] >> - | [x :: l] -> <:expr< [ $mf x$ :: $mlist mf l$ ] >> ] - ; - value moption mf = - fun - [ None -> <:expr< None >> - | Some x -> <:expr< Some $mf x$ >> ] - ; - value mbool = - fun - [ False -> <:expr< False >> - | True -> <:expr< True >> ] - ; - value mloc = <:expr< (0, 0) >>; - value rec mexpr = - fun - [ MLast.ExAcc loc e1 e2 -> - <:expr< MLast.ExAcc $mloc$ $mexpr e1$ $mexpr e2$ >> - | MLast.ExApp loc e1 e2 -> - <:expr< MLast.ExApp $mloc$ $mexpr e1$ $mexpr e2$ >> - | MLast.ExChr loc s -> <:expr< MLast.ExChr $mloc$ $str:s$ >> - | MLast.ExFun loc pwel -> <:expr< MLast.ExFun $mloc$ $mlist mpwe pwel$ >> - | MLast.ExIfe loc e1 e2 e3 -> - <:expr< MLast.ExIfe $mloc$ $mexpr e1$ $mexpr e2$ $mexpr e3$ >> - | MLast.ExInt loc s -> <:expr< MLast.ExInt $mloc$ $str:s$ >> - | MLast.ExFlo loc s -> <:expr< MLast.ExFlo $mloc$ $str:s$ >> - | MLast.ExLet loc rf pel e -> - <:expr< MLast.ExLet $mloc$ $mbool rf$ $mlist mpe pel$ $mexpr e$ >> - | MLast.ExLid loc s -> <:expr< MLast.ExLid $mloc$ $str:s$ >> - | MLast.ExMat loc e pwel -> - <:expr< MLast.ExMat $mloc$ $mexpr e$ $mlist mpwe pwel$ >> - | MLast.ExRec loc pel eo -> - <:expr< MLast.ExRec $mloc$ $mlist mpe pel$ $moption mexpr eo$ >> - | MLast.ExSeq loc el -> <:expr< MLast.ExSeq $mloc$ $mlist mexpr el$ >> - | MLast.ExSte loc e1 e2 -> - <:expr< MLast.ExSte $mloc$ $mexpr e1$ $mexpr e2$ >> - | MLast.ExStr loc s -> - <:expr< MLast.ExStr $mloc$ $str:String.escaped s$ >> - | MLast.ExTry loc e pwel -> - <:expr< MLast.ExTry $mloc$ $mexpr e$ $mlist mpwe pwel$ >> - | MLast.ExTup loc el -> <:expr< MLast.ExTup $mloc$ $mlist mexpr el$ >> - | MLast.ExTyc loc e t -> - <:expr< MLast.ExTyc $mloc$ $mexpr e$ $mctyp t$ >> - | MLast.ExUid loc s -> <:expr< MLast.ExUid $mloc$ $str:s$ >> - | x -> not_impl "mexpr" x ] - and mpatt = - fun - [ MLast.PaAcc loc p1 p2 -> - <:expr< MLast.PaAcc $mloc$ $mpatt p1$ $mpatt p2$ >> - | MLast.PaAny loc -> <:expr< MLast.PaAny $mloc$ >> - | MLast.PaApp loc p1 p2 -> - <:expr< MLast.PaApp $mloc$ $mpatt p1$ $mpatt p2$ >> - | MLast.PaInt loc s -> <:expr< MLast.PaInt $mloc$ $str:s$ >> - | MLast.PaLid loc s -> <:expr< MLast.PaLid $mloc$ $str:s$ >> - | MLast.PaOrp loc p1 p2 -> - <:expr< MLast.PaOrp $mloc$ $mpatt p1$ $mpatt p2$ >> - | MLast.PaStr loc s -> - <:expr< MLast.PaStr $mloc$ $str:String.escaped s$ >> - | MLast.PaTup loc pl -> <:expr< MLast.PaTup $mloc$ $mlist mpatt pl$ >> - | MLast.PaTyc loc p t -> - <:expr< MLast.PaTyc $mloc$ $mpatt p$ $mctyp t$ >> - | MLast.PaUid loc s -> <:expr< MLast.PaUid $mloc$ $str:s$ >> - | x -> not_impl "mpatt" x ] - and mctyp = - fun - [ MLast.TyAcc loc t1 t2 -> - <:expr< MLast.TyAcc $mloc$ $mctyp t1$ $mctyp t2$ >> - | MLast.TyApp loc t1 t2 -> - <:expr< MLast.TyApp $mloc$ $mctyp t1$ $mctyp t2$ >> - | MLast.TyLid loc s -> <:expr< MLast.TyLid $mloc$ $str:s$ >> - | MLast.TyQuo loc s -> <:expr< MLast.TyQuo $mloc$ $str:s$ >> - | MLast.TyTup loc tl -> <:expr< MLast.TyTup $mloc$ $mlist mctyp tl$ >> - | MLast.TyUid loc s -> <:expr< MLast.TyUid $mloc$ $str:s$ >> - | x -> not_impl "mctyp" x ] - and mpe (p, e) = <:expr< ($mpatt p$, $mexpr e$) >> - and mpwe (p, w, e) = <:expr< ($mpatt p$, $moption mexpr w$, $mexpr e$) >> - ; - end -; - -value mklistexp loc = - loop True where rec loop top = - fun - [ [] -> <:expr< [] >> - | [e1 :: el] -> - let loc = - if top then loc else (fst (MLast.loc_of_expr e1), snd loc) - in - <:expr< [$e1$ :: $loop False el$] >> ] -; - -value mklistpat loc = - loop True where rec loop top = - fun - [ [] -> <:patt< [] >> - | [p1 :: pl] -> - let loc = - if top then loc else (fst (MLast.loc_of_patt p1), snd loc) - in - <:patt< [$p1$ :: $loop False pl$] >> ] -; - -value rec expr_fa al = - fun - [ <:expr< $f$ $a$ >> -> expr_fa [a :: al] f - | f -> (f, al) ] -; - -value rec quot_expr e = - let loc = MLast.loc_of_expr e in - match e with - [ <:expr< None >> -> <:expr< Qast.Option None >> - | <:expr< Some $e$ >> -> <:expr< Qast.Option (Some $quot_expr e$) >> - | <:expr< False >> -> <:expr< Qast.Bool False >> - | <:expr< True >> -> <:expr< Qast.Bool True >> - | <:expr< () >> -> e - | <:expr< Qast.List $_$ >> -> e - | <:expr< Qast.Option $_$ >> -> e - | <:expr< Qast.Str $_$ >> -> e - | <:expr< [] >> -> <:expr< Qast.List [] >> - | <:expr< [$e$] >> -> <:expr< Qast.List [$quot_expr e$] >> - | <:expr< [$e1$ :: $e2$] >> -> - <:expr< Qast.Cons $quot_expr e1$ $quot_expr e2$ >> - | <:expr< $_$ $_$ >> -> - let (f, al) = expr_fa [] e in - match f with - [ <:expr< $uid:c$ >> -> - let al = List.map quot_expr al in - <:expr< Qast.Node $str:c$ $mklistexp loc al$ >> - | <:expr< MLast.$uid:c$ >> -> - let al = List.map quot_expr al in - <:expr< Qast.Node $str:c$ $mklistexp loc al$ >> - | <:expr< $uid:m$.$uid:c$ >> -> - let al = List.map quot_expr al in - <:expr< Qast.Node $str:m ^ "." ^ c$ $mklistexp loc al$ >> - | <:expr< $lid:f$ >> -> - let al = List.map quot_expr al in - List.fold_left (fun f e -> <:expr< $f$ $e$ >>) - <:expr< $lid:f$ >> al - | _ -> e ] - | <:expr< {$list:pel$} >> -> - try - let lel = - List.map - (fun (p, e) -> - let lab = - match p with - [ <:patt< $lid:c$ >> -> <:expr< $str:c$ >> - | <:patt< $_$.$lid:c$ >> -> <:expr< $str:c$ >> - | _ -> raise Not_found ] - in - <:expr< ($lab$, $quot_expr e$) >>) - pel - in - <:expr< Qast.Record $mklistexp loc lel$>> - with - [ Not_found -> e ] - | <:expr< $lid:s$ >> -> - if s = Stdpp.loc_name.val then <:expr< Qast.Loc >> else e - | <:expr< MLast.$uid:s$ >> -> <:expr< Qast.Node $str:s$ [] >> - | <:expr< $uid:m$.$uid:s$ >> -> <:expr< Qast.Node $str:m ^ "." ^ s$ [] >> - | <:expr< $uid:s$ >> -> <:expr< Qast.Node $str:s$ [] >> - | <:expr< $str:s$ >> -> <:expr< Qast.Str $str:s$ >> - | <:expr< ($list:el$) >> -> - let el = List.map quot_expr el in - <:expr< Qast.Tuple $mklistexp loc el$ >> - | <:expr< let $opt:r$ $list:pel$ in $e$ >> -> - let pel = List.map (fun (p, e) -> (p, quot_expr e)) pel in - <:expr< let $opt:r$ $list:pel$ in $quot_expr e$ >> - | _ -> e ] -; - -value symgen = "xx"; - -value pname_of_ptuple pl = - List.fold_left - (fun pname p -> - match p with - [ <:patt< $lid:s$ >> -> pname ^ s - | _ -> pname ]) - "" pl -; - -value quotify_action psl act = - let e = quot_expr act in - List.fold_left - (fun e ps -> - match ps.pattern with - [ Some <:patt< ($list:pl$) >> -> - let loc = (0, 0) in - let pname = pname_of_ptuple pl in - let (pl1, el1) = - let (l, _) = - List.fold_left - (fun (l, cnt) _ -> - ([symgen ^ string_of_int cnt :: l], cnt + 1)) - ([], 1) pl - in - let l = List.rev l in - (List.map (fun s -> <:patt< $lid:s$ >>) l, - List.map (fun s -> <:expr< $lid:s$ >>) l) - in - <:expr< - let ($list:pl$) = - match $lid:pname$ with - [ Qast.Tuple $mklistpat loc pl1$ -> ($list:el1$) - | _ -> match () with [] ] - in $e$ >> - | _ -> e ]) - e psl -; - -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 - Stdpp.raise_with_loc loc - (Stream.Error ("'" ^ x ^ "' illegal in anonymous entry level")) - else <:ctyp< '$tvar$ >> - | STtyp t -> t ] -; - -value rec make_expr gmod tvar = - fun - [ TXmeta loc n tl e t -> - let el = - List.fold_right - (fun t el -> <:expr< [$make_expr gmod "" t$ :: $el$] >>) - tl <:expr< [] >> - in - <:expr< - Gramext.Smeta $str:n$ $el$ (Obj.repr ($e$ : $make_ctyp t tvar$)) >> - | TXlist loc min t ts -> - let txt = make_expr gmod "" t in - match (min, ts) with - [ (False, None) -> <:expr< Gramext.Slist0 $txt$ >> - | (True, None) -> <:expr< Gramext.Slist1 $txt$ >> - | (False, Some s) -> - let x = make_expr gmod tvar s in - <:expr< Gramext.Slist0sep $txt$ $x$ >> - | (True, Some s) -> - let x = make_expr gmod tvar s in - <:expr< Gramext.Slist1sep $txt$ $x$ >> ] - | TXnext loc -> <:expr< Gramext.Snext >> - | TXnterm loc n lev -> - match lev with - [ Some lab -> - <:expr< - Gramext.Snterml - ($uid:gmod$.Entry.obj ($n.expr$ : $uid:gmod$.Entry.e '$n.tvar$)) - $str:lab$ >> - | None -> - if n.tvar = tvar then <:expr< Gramext.Sself >> - else - <:expr< - Gramext.Snterm - ($uid:gmod$.Entry.obj - ($n.expr$ : $uid:gmod$.Entry.e '$n.tvar$)) >> ] - | TXopt loc t -> <:expr< Gramext.Sopt $make_expr gmod "" t$ >> - | TXrules loc rl -> - <:expr< Gramext.srules $make_expr_rules loc gmod rl ""$ >> - | TXself loc -> <:expr< Gramext.Sself >> - | TXtok loc s e -> <:expr< Gramext.Stoken ($str:s$, $e$) >> ] -and make_expr_rules loc gmod rl tvar = - List.fold_left - (fun txt (sl, ac) -> - let sl = - List.fold_right - (fun t txt -> - let x = make_expr gmod tvar t in - <:expr< [$x$ :: $txt$] >>) - sl <:expr< [] >> - in - <:expr< [($sl$, $ac$) :: $txt$] >>) - <:expr< [] >> rl -; - -value text_of_action loc psl rtvar act tvar = - let locid = <:patt< $lid:Stdpp.loc_name.val$ >> in - let act = - match act with - [ Some act -> if quotify.val then quotify_action psl act else act - | None -> <:expr< () >> ] - in - let e = <:expr< fun [ ($locid$ : (int * int)) -> ($act$ : '$rtvar$) ] >> in - let txt = - List.fold_left - (fun txt ps -> - match ps.pattern with - [ None -> <:expr< fun _ -> $txt$ >> - | Some p -> - let t = make_ctyp ps.symbol.styp tvar in - let p = - match p with - [ <:patt< ($list:pl$) >> when quotify.val -> - <:patt< $lid:pname_of_ptuple pl$ >> - | _ -> p ] - in - <:expr< fun ($p$ : $t$) -> $txt$ >> ]) - e psl - in - let txt = - if meta_action.val then - <:expr< Obj.magic $MetaAction.mexpr txt$ >> - else txt - in - <:expr< Gramext.action $txt$ >> -; - -value srules loc t rl tvar = - List.map - (fun r -> - let sl = List.map (fun ps -> ps.symbol.text) r.prod in - let ac = text_of_action loc r.prod t r.action tvar in - (sl, ac)) - rl -; - -value expr_of_delete_rule loc gmod n sl = - let sl = - List.fold_right - (fun s e -> <:expr< [$make_expr gmod "" s.text$ :: $e$] >>) sl - <:expr< [] >> - in - (<:expr< $n.expr$ >>, sl) -; - -value rec ident_of_expr = - fun - [ <:expr< $lid:s$ >> -> s - | <:expr< $uid:s$ >> -> s - | <:expr< $e1$ . $e2$ >> -> ident_of_expr e1 ^ "__" ^ ident_of_expr e2 - | _ -> failwith "internal error in pa_extend" ] -; - -value mk_name loc e = {expr = e; tvar = ident_of_expr e; loc = loc}; - -value slist loc min sep symb = - let t = - match sep with - [ Some s -> Some s.text - | None -> None ] - in - TXlist loc min symb.text t -; - -value sstoken loc s = - let n = mk_name loc <:expr< $lid:"a_" ^ s$ >> in - TXnterm loc n None -; - -value mk_psymbol p s t = - let symb = {used = []; text = s; styp = t} in - {pattern = Some p; symbol = symb} -; - -value sslist loc min sep s = - let rl = - let r1 = - let prod = - let n = mk_name loc <:expr< a_list >> in - [mk_psymbol <: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_psymbol <: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} -; - -value ssopt loc s = - let rl = - let r1 = - let prod = - let n = mk_name loc <:expr< a_opt >> in - [mk_psymbol <: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 - [ TXtok loc "" <:expr< $str:_$ >> -> - let rl = - [{prod = [{pattern = Some <:patt< x >>; symbol = s}]; - action = Some <:expr< Qast.Str x >>}] - in - let t = new_type_var () in - {used = []; text = TXrules loc (srules loc t rl ""); - styp = STquo loc t} - | _ -> s ] - in - let prod = - [mk_psymbol <: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} -; - -value text_of_entry loc gmod e = - let ent = - let x = e.name in - let loc = e.name.loc in - <:expr< ($x.expr$ : $uid:gmod$.Entry.e '$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 gmod 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 gmod functor_version gl el args = - match gl with - [ Some ([n1 :: _] as 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 globals = - List.map - (fun {expr = e; tvar = x; loc = loc} -> - (<:patt< _ >>, <:expr< ($e$ : $uid:gmod$.Entry.e '$x$) >>)) - nl - in - let locals = - List.map - (fun {expr = e; tvar = x; loc = loc} -> - let i = - match e with - [ <:expr< $lid:i$ >> -> i - | _ -> failwith "internal error in pa_extend" ] - in - (<:patt< $lid:i$ >>, <:expr< - (grammar_entry_create $str:i$ : $uid:gmod$.Entry.e '$x$) >>)) - ll - in - let e = - if ll = [] then args - else if functor_version then - <:expr< - let grammar_entry_create = $uid:gmod$.Entry.create in - let $list:locals$ in $args$ >> - else - <:expr< - let grammar_entry_create s = - $uid:gmod$.Entry.create ($uid:gmod$.of_entry $locate n1$) s - in - let $list:locals$ in $args$ >> - in - <:expr< let $list:globals$ in $e$ >> - } - | _ -> args ] -; - -value text_of_extend loc gmod gl el f = - if split_ext.val then - let args = - List.map - (fun e -> - let (ent, pos, txt) = text_of_entry e.name.loc gmod e in - let ent = <:expr< $uid:gmod$.Entry.obj $ent$ >> in - let e = <:expr< ($ent$, $pos$, $txt$) >> in - <:expr< let aux () = $f$ [$e$] in aux () >>) - el - in - let args = <:expr< do { $list:args$ } >> in - let_in_of_extend loc gmod False gl el args - else - let args = - List.fold_right - (fun e el -> - let (ent, pos, txt) = text_of_entry e.name.loc gmod e in - let ent = <:expr< $uid:gmod$.Entry.obj $ent$ >> in - let e = <:expr< ($ent$, $pos$, $txt$) >> in - <:expr< [$e$ :: $el$] >>) - el <:expr< [] >> - in - let args = let_in_of_extend loc gmod False gl el args in - <:expr< $f$ $args$ >> -; - -value text_of_functorial_extend loc gmod gl el = - let args = - let el = - List.map - (fun e -> - let (ent, pos, txt) = text_of_entry e.name.loc gmod e in - let e = <:expr< $uid:gmod$.extend $ent$ $pos$ $txt$ >> in - if split_ext.val then <:expr< let aux () = $e$ in aux () >> else e) - el - in - <:expr< do { $list:el$ } >> - in - let_in_of_extend loc gmod True gl el args -; - -open Pcaml; -value symbol = Grammar.Entry.create gram "symbol"; -value semi_sep = - if syntax_name.val = "Scheme" then - Grammar.Entry.of_parser gram "'/'" (parser [: `("", "/") :] -> ()) - else - Grammar.Entry.of_parser gram "';'" (parser [: `("", ";") :] -> ()) -; - -EXTEND - GLOBAL: expr symbol; - expr: AFTER "top" - [ [ "EXTEND"; e = extend_body; "END" -> e - | "GEXTEND"; e = gextend_body; "END" -> e - | "DELETE_RULE"; e = delete_rule_body; "END" -> e - | "GDELETE_RULE"; e = gdelete_rule_body; "END" -> e ] ] - ; - extend_body: - [ [ f = efunction; sl = OPT global; - el = LIST1 [ e = entry; semi_sep -> e ] -> - text_of_extend loc "Grammar" sl el f ] ] - ; - gextend_body: - [ [ g = UIDENT; sl = OPT global; el = LIST1 [ e = entry; semi_sep -> e ] -> - text_of_functorial_extend loc g sl el ] ] - ; - delete_rule_body: - [ [ n = name; ":"; sl = LIST1 symbol SEP semi_sep -> - let (e, b) = expr_of_delete_rule loc "Grammar" n sl in - <:expr< Grammar.delete_rule $e$ $b$ >> ] ] - ; - gdelete_rule_body: - [ [ g = UIDENT; n = name; ":"; sl = LIST1 symbol SEP semi_sep -> - let (e, b) = expr_of_delete_rule loc g n sl in - <:expr< $uid:g$.delete_rule $e$ $b$ >> ] ] - ; - efunction: - [ [ UIDENT "FUNCTION"; ":"; f = qualid; semi_sep -> f - | -> <:expr< Grammar.extend >> ] ] - ; - 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< Gramext.First >> - | UIDENT "LAST" -> <:expr< Gramext.Last >> - | UIDENT "BEFORE"; n = string -> <:expr< Gramext.Before $n$ >> - | UIDENT "AFTER"; n = string -> <:expr< Gramext.After $n$ >> - | UIDENT "LEVEL"; n = string -> <:expr< Gramext.Level $n$ >> ] ] - ; - level_list: - [ [ "["; ll = LIST0 level SEP "|"; "]" -> ll ] ] - ; - level: - [ [ lab = OPT STRING; ass = OPT assoc; rules = rule_list -> - {label = lab; assoc = ass; rules = rules} ] ] - ; - assoc: - [ [ UIDENT "LEFTA" -> <:expr< Gramext.LeftA >> - | UIDENT "RIGHTA" -> <:expr< Gramext.RightA >> - | UIDENT "NONA" -> <:expr< Gramext.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 -> - {pattern = Some <:patt< $lid:p$ >>; symbol = s} - | i = LIDENT; lev = OPT [ UIDENT "LEVEL"; s = STRING -> s ] -> - let name = mk_name loc <:expr< $lid:i$ >> in - let text = TXnterm loc name lev in - let styp = STquo loc i in - let symb = {used = [i]; text = text; styp = styp} in - {pattern = None; symbol = symb} - | p = pattern; "="; s = symbol -> {pattern = Some p; symbol = s} - | s = symbol -> {pattern = None; symbol = s} ] ] - ; - symbol: - [ "top" NONA - [ UIDENT "LIST0"; s = SELF; - sep = OPT [ UIDENT "SEP"; t = symbol -> t ] -> - if quotify.val then sslist loc False sep s - else - 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} - | UIDENT "LIST1"; s = SELF; - sep = OPT [ UIDENT "SEP"; t = symbol -> t ] -> - if quotify.val then sslist loc True sep s - else - 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} - | UIDENT "OPT"; s = SELF -> - if quotify.val then ssopt loc s - else - let styp = STapp loc (STlid loc "option") s.styp in - let text = TXopt loc s.text in - {used = s.used; text = text; styp = styp} ] - | [ UIDENT "SELF" -> - {used = []; text = TXself loc; styp = STself loc "SELF"} - | UIDENT "NEXT" -> - {used = []; text = TXnext loc; styp = STself loc "NEXT"} - | "["; 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} - | x = UIDENT -> - let text = - if quotify.val then sstoken loc x - else TXtok loc x <:expr< "" >> - in - {used = []; text = text; styp = STlid loc "string"} - | x = UIDENT; e = string -> - let text = TXtok loc x e in - {used = []; text = text; styp = STlid loc "string"} - | e = string -> - let text = TXtok loc "" e in - {used = []; text = text; styp = STlid loc "string"} - | i = UIDENT; "."; e = qualid; - lev = OPT [ UIDENT "LEVEL"; s = STRING -> s ] -> - let n = mk_name loc <:expr< $uid:i$ . $e$ >> in - {used = [n.tvar]; text = TXnterm loc n lev; - styp = STquo loc n.tvar} - | n = name; lev = OPT [ UIDENT "LEVEL"; s = STRING -> s ] -> - {used = [n.tvar]; text = TXnterm loc n lev; - styp = STquo loc n.tvar} - | "("; s_t = SELF; ")" -> s_t ] ] - ; - pattern: - [ [ i = LIDENT -> <:patt< $lid:i$ >> - | "_" -> <:patt< _ >> - | "("; p = SELF; ")" -> <:patt< $p$ >> - | "("; p = SELF; ","; pl = patterns_comma; ")" -> - <:patt< ( $list:[p :: pl]$ ) >> ] ] - ; - patterns_comma: - [ [ pl = SELF; ","; p = pattern -> pl @ [p] ] - | [ p = pattern -> [p] ] ] - ; - name: - [ [ e = qualid -> mk_name loc e ] ] - ; - qualid: - [ [ e1 = SELF; "."; e2 = SELF -> <:expr< $e1$ . $e2$ >> ] - | [ i = UIDENT -> <:expr< $uid:i$ >> - | i = LIDENT -> <:expr< $lid:i$ >> ] ] - ; - string: - [ [ s = STRING -> <:expr< $str:s$ >> - | i = ANTIQUOT -> - let shift = fst loc + String.length "$" in - let e = - try Grammar.Entry.parse Pcaml.expr_eoi (Stream.of_string i) with - [ Exc_located (bp, ep) exc -> - raise_with_loc (shift + bp, shift + ep) exc ] - in - Pcaml.expr_reloc (fun (bp, ep) -> (shift + bp, shift + ep)) 0 e ] ] - ; -END; - -Pcaml.add_option "-quotify" (Arg.Set quotify) - "Generate code for quotations"; - -Pcaml.add_option "-meta_action" (Arg.Set meta_action) - "Undocumented"; diff --git a/camlp4/meta/pa_extend_m.ml b/camlp4/meta/pa_extend_m.ml deleted file mode 100644 index 7e000dd7b4..0000000000 --- a/camlp4/meta/pa_extend_m.ml +++ /dev/null @@ -1,26 +0,0 @@ -(* camlp4r pa_extend.cmo q_MLast.cmo *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -open Pa_extend; - -EXTEND - 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; diff --git a/camlp4/meta/pa_ifdef.ml b/camlp4/meta/pa_ifdef.ml deleted file mode 100644 index 59d448ef1b..0000000000 --- a/camlp4/meta/pa_ifdef.ml +++ /dev/null @@ -1,85 +0,0 @@ -(* camlp4r pa_extend.cmo q_MLast.cmo *) -(* $Id$ *) - -type item_or_def 'a = - [ SdStr of 'a | SdDef of string | SdUnd of string | SdNop ] -; - -value list_remove x l = - List.fold_right (fun e l -> if e = x then l else [e :: l]) l [] -; - -value defined = ref ["OCAML_305"; "CAMLP4_300"; "NEWSEQ"]; -value define x = defined.val := [x :: defined.val]; -value undef x = defined.val := list_remove x defined.val; - -EXTEND - GLOBAL: Pcaml.expr Pcaml.str_item Pcaml.sig_item; - Pcaml.expr: LEVEL "top" - [ [ "ifdef"; c = UIDENT; "then"; e1 = Pcaml.expr; "else"; - e2 = Pcaml.expr -> - if List.mem c defined.val then e1 else e2 - | "ifndef"; c = UIDENT; "then"; e1 = Pcaml.expr; "else"; - e2 = Pcaml.expr -> - if List.mem c defined.val then e2 else e1 ] ] - ; - Pcaml.str_item: FIRST - [ [ x = def_undef_str -> - match x with - [ SdStr si -> si - | SdDef x -> do { define x; <:str_item< declare end >> } - | SdUnd x -> do { undef x; <:str_item< declare end >> } - | SdNop -> <:str_item< declare end >> ] ] ] - ; - def_undef_str: - [ [ "ifdef"; c = UIDENT; "then"; e1 = str_item_def_undef; - "else"; e2 = str_item_def_undef -> - if List.mem c defined.val then e1 else e2 - | "ifdef"; c = UIDENT; "then"; e1 = str_item_def_undef -> - if List.mem c defined.val then e1 else SdNop - | "ifndef"; c = UIDENT; "then"; e1 = str_item_def_undef; - "else"; e2 = str_item_def_undef -> - if List.mem c defined.val then e2 else e1 - | "ifndef"; c = UIDENT; "then"; e1 = str_item_def_undef -> - if List.mem c defined.val then SdNop else e1 - | "define"; c = UIDENT -> SdDef c - | "undef"; c = UIDENT -> SdUnd c ] ] - ; - str_item_def_undef: - [ [ d = def_undef_str -> d - | si = Pcaml.str_item -> SdStr si ] ] - ; - Pcaml.sig_item: FIRST - [ [ x = def_undef_sig -> - match x with - [ SdStr si -> si - | SdDef x -> do { define x; <:sig_item< declare end >> } - | SdUnd x -> do { undef x; <:sig_item< declare end >> } - | SdNop -> <:sig_item< declare end >> ] ] ] - ; - def_undef_sig: - [ [ "ifdef"; c = UIDENT; "then"; e1 = sig_item_def_undef; - "else"; e2 = sig_item_def_undef -> - if List.mem c defined.val then e1 else e2 - | "ifdef"; c = UIDENT; "then"; e1 = sig_item_def_undef -> - if List.mem c defined.val then e1 else SdNop - | "ifndef"; c = UIDENT; "then"; e1 = sig_item_def_undef; - "else"; e2 = sig_item_def_undef -> - if List.mem c defined.val then e2 else e1 - | "ifndef"; c = UIDENT; "then"; e1 = sig_item_def_undef -> - if List.mem c defined.val then SdNop else e1 - | "define"; c = UIDENT -> SdDef c - | "undef"; c = UIDENT -> SdUnd c ] ] - ; - sig_item_def_undef: - [ [ d = def_undef_sig -> d - | si = Pcaml.sig_item -> SdStr si ] ] - ; -END; - -Pcaml.add_option "-D" (Arg.String define) - " Define for ifdef instruction." -; -Pcaml.add_option "-U" (Arg.String undef) - " Undefine for ifdef instruction." -; diff --git a/camlp4/meta/pa_macro.ml b/camlp4/meta/pa_macro.ml deleted file mode 100644 index 406a3bd622..0000000000 --- a/camlp4/meta/pa_macro.ml +++ /dev/null @@ -1,251 +0,0 @@ -(* camlp4r *) -(* $Id$ *) - -(* -Added statements: - - At toplevel (structure item): - - DEFINE - DEFINE = - DEFINE () = - IFDEF THEN END - IFDEF THEN ELSE END - IFNDEF THEN END - IFNDEF THEN ELSE END - - In expressions: - - IFDEF THEN ELSE END - IFNDEF THEN ELSE END - __FILE__ - __LOCATION__ - - In patterns: - - IFDEF THEN ELSE END - IFNDEF THEN ELSE END - - As Camlp4 options: - - -D - -U - - After having used a DEFINE followed by "= ", you - can use it in expressions *and* in patterns. If the expression defining - the macro cannot be used as a pattern, there is an error message if - it is used in a pattern. - - The expression __FILE__ returns the current compiled file name. - The expression __LOCATION__ returns the current location of itself. - -*) - -#load "pa_extend.cmo"; -#load "q_MLast.cmo"; - -open Pcaml; - -type item_or_def 'a = - [ SdStr of 'a - | SdDef of string and option (list string * MLast.expr) - | SdUnd of string - | SdNop ] -; - -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 loc = (0, 0); - -value subst mloc env = - loop where rec loop = - fun - [ <:expr< let $opt:rf$ $list:pel$ in $e$ >> -> - let pel = List.map (fun (p, e) -> (p, loop e)) pel in - <:expr< let $opt:rf$ $list:pel$ in $loop e$ >> - | <:expr< if $e1$ then $e2$ else $e3$ >> -> - <:expr< if $loop e1$ then $loop e2$ else $loop e3$ >> - | <:expr< $e1$ $e2$ >> -> <:expr< $loop e1$ $loop e2$ >> - | <:expr< $lid:x$ >> | <:expr< $uid:x$ >> as e -> - try <:expr< $anti:List.assoc x env$ >> with - [ Not_found -> e ] - | <:expr< ($list:x$) >> -> <:expr< ($list:List.map loop x$) >> - | <:expr< { $list:pel$ } >> -> - let pel = List.map (fun (p, e) -> (p, loop e)) pel in - <:expr< { $list:pel$ } >> - | e -> e ] -; - -value substp mloc env = - loop where rec loop = - fun - [ <:expr< $e1$ $e2$ >> -> <:patt< $loop e1$ $loop e2$ >> - | <:expr< $lid:x$ >> -> - try <:patt< $anti:List.assoc x env$ >> with - [ Not_found -> <:patt< $lid:x$ >> ] - | <:expr< $uid:x$ >> -> - try <:patt< $anti:List.assoc x env$ >> with - [ Not_found -> <:patt< $uid:x$ >> ] - | <:expr< $int:x$ >> -> <:patt< $int:x$ >> - | <:expr< ($list:x$) >> -> <:patt< ($list:List.map loop x$) >> - | <:expr< { $list:pel$ } >> -> - let ppl = List.map (fun (p, e) -> (p, loop e)) pel in - <:patt< { $list:ppl$ } >> - | x -> - Stdpp.raise_with_loc mloc - (Failure - "this macro cannot be used in a pattern (see its definition)") ] -; - -value incorrect_number loc l1 l2 = - Stdpp.raise_with_loc 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 - expr: LEVEL "simple" - [ [ UIDENT $x$ -> Pcaml.expr_reloc (fun _ -> loc) 0 e ] ] - ; - patt: LEVEL "simple" - [ [ UIDENT $x$ -> - let p = substp loc [] e in - Pcaml.patt_reloc (fun _ -> loc) 0 p ] ] - ; - END - | Some (sl, e) -> - EXTEND - expr: LEVEL "apply" - [ [ UIDENT $x$; param = SELF -> - let el = - match param with - [ <:expr< ($list:el$) >> -> el - | e -> [e] ] - in - if List.length el = List.length sl then - let env = List.combine sl el in - let e = subst loc env e in - Pcaml.expr_reloc (fun _ -> loc) 0 e - else - incorrect_number loc el sl ] ] - ; - patt: LEVEL "simple" - [ [ UIDENT $x$; param = SELF -> - let pl = - match param with - [ <:patt< ($list:pl$) >> -> pl - | 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 - Pcaml.patt_reloc (fun _ -> loc) 0 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 expr: UIDENT $x$ END; - DELETE_RULE patt: UIDENT $x$ END; - } - | Some (_, _) -> - do { - DELETE_RULE expr: UIDENT $x$; SELF END; - DELETE_RULE patt: UIDENT $x$; SELF END; - } - | None -> () ]; - defined.val := list_remove x defined.val; - } - with - [ Not_found -> () ] -; - -EXTEND - GLOBAL: expr patt str_item sig_item; - str_item: FIRST - [ [ x = macro_def -> - match x with - [ SdStr [si] -> si - | SdStr sil -> <:str_item< declare $list:sil$ end >> - | SdDef x eo -> do { define eo x; <:str_item< declare end >> } - | SdUnd x -> do { undef x; <:str_item< declare end >> } - | SdNop -> <:str_item< declare end >> ] ] ] - ; - macro_def: - [ [ "DEFINE"; i = uident; def = opt_macro_value -> SdDef i def - | "UNDEF"; i = uident -> SdUnd i - | "IFDEF"; i = uident; "THEN"; d = str_item_or_macro; "END" -> - if is_defined i then d else SdNop - | "IFDEF"; i = uident; "THEN"; d1 = str_item_or_macro; "ELSE"; - d2 = str_item_or_macro; "END" -> - if is_defined i then d1 else d2 - | "IFNDEF"; i = uident; "THEN"; d = str_item_or_macro; "END" -> - if is_defined i then SdNop else d - | "IFNDEF"; i = uident; "THEN"; d1 = str_item_or_macro; "ELSE"; - d2 = str_item_or_macro; "END" -> - if is_defined i then d2 else d1 ] ] - ; - str_item_or_macro: - [ [ d = macro_def -> d - | si = LIST1 str_item -> SdStr si ] ] - ; - opt_macro_value: - [ [ "("; pl = LIST1 LIDENT SEP ","; ")"; "="; e = expr -> Some (pl, e) - | "="; e = expr -> Some ([], e) - | -> None ] ] - ; - expr: LEVEL "top" - [ [ "IFDEF"; i = uident; "THEN"; e1 = expr; "ELSE"; e2 = expr; "END" -> - if is_defined i then e1 else e2 - | "IFNDEF"; i = uident; "THEN"; e1 = expr; "ELSE"; e2 = expr; "END" -> - if is_defined i then e2 else e1 ] ] - ; - expr: LEVEL "simple" - [ [ LIDENT "__FILE__" -> <:expr< $str:Pcaml.input_file.val$ >> - | LIDENT "__LOCATION__" -> - let bp = string_of_int (fst loc) in - let ep = string_of_int (snd loc) in - <:expr< ($int:bp$, $int:ep$) >> ] ] - ; - patt: - [ [ "IFDEF"; i = uident; "THEN"; p1 = patt; "ELSE"; p2 = patt; "END" -> - if is_defined i then p1 else p2 - | "IFNDEF"; i = uident; "THEN"; p1 = patt; "ELSE"; p2 = patt; "END" -> - if is_defined i then p2 else p1 ] ] - ; - uident: - [ [ i = UIDENT -> i ] ] - ; -END; - -Pcaml.add_option "-D" (Arg.String (define None)) - " Define for IFDEF instruction." -; -Pcaml.add_option "-U" (Arg.String undef) - " Undefine for IFDEF instruction." -; diff --git a/camlp4/meta/pa_r.ml b/camlp4/meta/pa_r.ml deleted file mode 100644 index dd6b499ac5..0000000000 --- a/camlp4/meta/pa_r.ml +++ /dev/null @@ -1,943 +0,0 @@ -(* camlp4r pa_extend.cmo q_MLast.cmo *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -open Stdpp; -open Pcaml; - -Pcaml.no_constructors_arity.val := False; - -value help_sequences () = - do { - Printf.eprintf "\ -New syntax: - do {e1; e2; ... ; en} - while e do {e1; e2; ... ; en} - for v = v1 to/downto v2 do {e1; e2; ... ; en} -Old (discouraged) syntax: - do e1; e2; ... ; en-1; return en - while e do e1; e2; ... ; en; done - for v = v1 to/downto v2 do e1; e2; ... ; en; done -To avoid compilation warning use the new syntax. -"; - flush stderr; - exit 1 - } -; -Pcaml.add_option "-help_seq" (Arg.Unit help_sequences) - "Print explanations about new sequences and exit."; - -do { - let odfa = Plexer.dollar_for_antiquotation.val in - Plexer.dollar_for_antiquotation.val := False; - Grammar.Unsafe.gram_reinit gram (Plexer.gmake ()); - Plexer.dollar_for_antiquotation.val := odfa; - Grammar.Unsafe.clear_entry interf; - Grammar.Unsafe.clear_entry implem; - Grammar.Unsafe.clear_entry top_phrase; - Grammar.Unsafe.clear_entry use_file; - Grammar.Unsafe.clear_entry module_type; - Grammar.Unsafe.clear_entry module_expr; - Grammar.Unsafe.clear_entry sig_item; - Grammar.Unsafe.clear_entry str_item; - Grammar.Unsafe.clear_entry expr; - Grammar.Unsafe.clear_entry patt; - Grammar.Unsafe.clear_entry ctyp; - Grammar.Unsafe.clear_entry let_binding; - Grammar.Unsafe.clear_entry type_declaration; - Grammar.Unsafe.clear_entry class_type; - Grammar.Unsafe.clear_entry class_expr; - Grammar.Unsafe.clear_entry class_sig_item; - Grammar.Unsafe.clear_entry class_str_item -}; - -Pcaml.parse_interf.val := Grammar.Entry.parse interf; -Pcaml.parse_implem.val := Grammar.Entry.parse implem; - -value o2b = - fun - [ Some _ -> True - | None -> False ] -; - -value mksequence loc = - fun - [ [e] -> e - | el -> <:expr< do { $list:el$ } >> ] -; - -value mkmatchcase loc p aso w e = - let p = - match aso with - [ Some p2 -> <:patt< ($p$ as $p2$) >> - | _ -> p ] - in - (p, w, e) -; - -value neg_string n = - let len = String.length n in - if len > 0 && n.[0] = '-' then String.sub n 1 (len - 1) - else "-" ^ n -; - -value mkumin loc f arg = - match arg with - [ <:expr< $int:n$ >> -> <:expr< $int:neg_string n$ >> - | MLast.ExInt32 loc n -> MLast.ExInt32 loc (neg_string n) - | MLast.ExInt64 loc n -> MLast.ExInt64 loc (neg_string n) - | MLast.ExNativeInt loc n -> MLast.ExNativeInt loc (neg_string n) - | <:expr< $flo:n$ >> -> <:expr< $flo:neg_string n$ >> - | _ -> - let f = "~" ^ f in - <:expr< $lid:f$ $arg$ >> ] -; - -value mklistexp loc last = - loop True where rec loop top = - fun - [ [] -> - match last with - [ Some e -> e - | None -> <:expr< [] >> ] - | [e1 :: el] -> - let loc = - if top then loc else (fst (MLast.loc_of_expr e1), snd loc) - in - <:expr< [$e1$ :: $loop False el$] >> ] -; - -value mklistpat loc last = - loop True where rec loop top = - fun - [ [] -> - match last with - [ Some p -> p - | None -> <:patt< [] >> ] - | [p1 :: pl] -> - let loc = - if top then loc else (fst (MLast.loc_of_patt p1), snd loc) - in - <:patt< [$p1$ :: $loop False pl$] >> ] -; - -value mkexprident loc i j = - let rec loop m = - fun - [ <:expr< $x$ . $y$ >> -> loop <:expr< $m$ . $x$ >> y - | e -> <:expr< $m$ . $e$ >> ] - in - loop <:expr< $uid:i$ >> j -; - -value mkassert loc e = - match e with - [ <:expr< False >> -> MLast.ExAsf loc - | _ -> MLast.ExAsr loc e ] -; - -value append_elem el e = el @ [e]; - -(* ...suppose to flush the input in case of syntax error to avoid multiple - errors in case of cut-and-paste in the xterm, but work bad: for example - the input "for x = 1;" waits for another line before displaying the - error... -value rec sync cs = - match cs with parser - [ [: `';' :] -> sync_semi cs - | [: `_ :] -> sync cs ] -and sync_semi cs = - match Stream.peek cs with - [ Some ('\010' | '\013') -> () - | _ -> sync cs ] -; -Pcaml.sync.val := sync; -*) - -value ipatt = Grammar.Entry.create gram "ipatt"; -value with_constr = Grammar.Entry.create gram "with_constr"; -value row_field = Grammar.Entry.create gram "row_field"; - -value not_yet_warned_variant = ref True; -value warn_variant loc = - if not_yet_warned_variant.val then do { - not_yet_warned_variant.val := False; - Pcaml.warning.val loc - (Printf.sprintf - "use of syntax of variants types deprecated since version 3.05"); - } - else () -; - -value not_yet_warned = ref True; -value warn_sequence loc = - if not_yet_warned.val then do { - not_yet_warned.val := False; - Pcaml.warning.val loc - ("use of syntax of sequences deprecated since version 3.01.1"); - } - else () -; -Pcaml.add_option "-no_warn_seq" (Arg.Clear not_yet_warned) - "No warning when using old syntax for sequences."; - -EXTEND - GLOBAL: sig_item str_item ctyp patt expr module_type module_expr class_type - class_expr class_sig_item class_str_item let_binding type_declaration - ipatt with_constr row_field; - module_expr: - [ [ "functor"; "("; i = UIDENT; ":"; t = module_type; ")"; "->"; - me = SELF -> - <:module_expr< functor ( $i$ : $t$ ) -> $me$ >> - | "struct"; st = LIST0 [ s = str_item; ";" -> s ]; "end" -> - <:module_expr< struct $list:st$ end >> ] - | [ me1 = SELF; me2 = SELF -> <:module_expr< $me1$ $me2$ >> ] - | [ me1 = SELF; "."; me2 = SELF -> <:module_expr< $me1$ . $me2$ >> ] - | "simple" - [ i = UIDENT -> <:module_expr< $uid:i$ >> - | "("; me = SELF; ":"; mt = module_type; ")" -> - <:module_expr< ( $me$ : $mt$ ) >> - | "("; me = SELF; ")" -> <:module_expr< $me$ >> ] ] - ; - str_item: - [ "top" - [ "declare"; st = LIST0 [ s = str_item; ";" -> s ]; "end" -> - <:str_item< declare $list:st$ end >> - | "exception"; (_, c, tl) = constructor_declaration; b = rebind_exn -> - <:str_item< exception $c$ of $list:tl$ = $b$ >> - | "external"; i = LIDENT; ":"; t = ctyp; "="; pd = LIST1 STRING -> - <:str_item< external $i$ : $t$ = $list:pd$ >> - | "include"; me = module_expr -> <:str_item< include $me$ >> - | "module"; i = UIDENT; mb = module_binding -> - <:str_item< module $i$ = $mb$ >> - | "module"; "rec"; nmtmes = LIST1 module_rec_binding SEP "and" -> - MLast.StRecMod loc nmtmes - | "module"; "type"; i = UIDENT; "="; mt = module_type -> - <:str_item< module type $i$ = $mt$ >> - | "open"; i = mod_ident -> <:str_item< open $i$ >> - | "type"; tdl = LIST1 type_declaration SEP "and" -> - <:str_item< type $list:tdl$ >> - | "value"; r = OPT "rec"; l = LIST1 let_binding SEP "and" -> - <:str_item< value $opt:o2b r$ $list:l$ >> - | e = expr -> <:str_item< $exp:e$ >> ] ] - ; - rebind_exn: - [ [ "="; sl = mod_ident -> sl - | -> [] ] ] - ; - module_binding: - [ RIGHTA - [ "("; m = UIDENT; ":"; mt = module_type; ")"; mb = SELF -> - <:module_expr< functor ( $m$ : $mt$ ) -> $mb$ >> - | ":"; mt = module_type; "="; me = module_expr -> - <:module_expr< ( $me$ : $mt$ ) >> - | "="; me = module_expr -> <:module_expr< $me$ >> ] ] - ; - module_rec_binding: - [ [ m = UIDENT; ":"; mt = module_type; "="; me = module_expr -> - (m, mt, me) ] ] - ; - module_type: - [ [ "functor"; "("; i = UIDENT; ":"; t = SELF; ")"; "->"; mt = SELF -> - <:module_type< functor ( $i$ : $t$ ) -> $mt$ >> ] - | [ mt = SELF; "with"; wcl = LIST1 with_constr SEP "and" -> - <:module_type< $mt$ with $list:wcl$ >> ] - | [ "sig"; sg = LIST0 [ s = sig_item; ";" -> s ]; "end" -> - <:module_type< sig $list:sg$ end >> ] - | [ m1 = SELF; m2 = SELF -> <:module_type< $m1$ $m2$ >> ] - | [ m1 = SELF; "."; m2 = SELF -> <:module_type< $m1$ . $m2$ >> ] - | "simple" - [ i = UIDENT -> <:module_type< $uid:i$ >> - | i = LIDENT -> <:module_type< $lid:i$ >> - | "'"; i = ident -> <:module_type< ' $i$ >> - | "("; mt = SELF; ")" -> <:module_type< $mt$ >> ] ] - ; - sig_item: - [ "top" - [ "declare"; st = LIST0 [ s = sig_item; ";" -> s ]; "end" -> - <:sig_item< declare $list:st$ end >> - | "exception"; (_, c, tl) = constructor_declaration -> - <:sig_item< exception $c$ of $list:tl$ >> - | "external"; i = LIDENT; ":"; t = ctyp; "="; pd = LIST1 STRING -> - <:sig_item< external $i$ : $t$ = $list:pd$ >> - | "include"; mt = module_type -> <:sig_item< include $mt$ >> - | "module"; i = UIDENT; mt = module_declaration -> - <:sig_item< module $i$ : $mt$ >> - | "module"; "rec"; mds = LIST1 module_rec_declaration SEP "and" -> - MLast.SgRecMod loc mds - | "module"; "type"; i = UIDENT; "="; mt = module_type -> - <:sig_item< module type $i$ = $mt$ >> - | "open"; i = mod_ident -> <:sig_item< open $i$ >> - | "type"; tdl = LIST1 type_declaration SEP "and" -> - <:sig_item< type $list:tdl$ >> - | "value"; i = LIDENT; ":"; t = ctyp -> - <:sig_item< value $i$ : $t$ >> ] ] - ; - module_declaration: - [ RIGHTA - [ ":"; mt = module_type -> <:module_type< $mt$ >> - | "("; i = UIDENT; ":"; t = module_type; ")"; mt = SELF -> - <:module_type< functor ( $i$ : $t$ ) -> $mt$ >> ] ] - ; - module_rec_declaration: - [ [ m = UIDENT; ":"; mt = module_type -> (m, mt)] ] - ; - with_constr: - [ [ "type"; i = mod_ident; tpl = LIST0 type_parameter; "="; t = ctyp -> - <:with_constr< type $i$ $list:tpl$ = $t$ >> - | "module"; i = mod_ident; "="; me = module_expr -> - <:with_constr< module $i$ = $me$ >> ] ] - ; - expr: - [ "top" RIGHTA - [ "let"; r = OPT "rec"; l = LIST1 let_binding SEP "and"; "in"; - x = SELF -> - <:expr< let $opt:o2b r$ $list:l$ in $x$ >> - | "let"; "module"; m = UIDENT; mb = module_binding; "in"; e = SELF -> - <:expr< let module $m$ = $mb$ in $e$ >> - | "fun"; "["; l = LIST0 match_case SEP "|"; "]" -> - <:expr< fun [ $list:l$ ] >> - | "fun"; p = ipatt; e = fun_def -> <:expr< fun $p$ -> $e$ >> - | "match"; e = SELF; "with"; "["; l = LIST0 match_case SEP "|"; "]" -> - <:expr< match $e$ with [ $list:l$ ] >> - | "match"; e = SELF; "with"; p1 = ipatt; "->"; e1 = SELF -> - <:expr< match $e$ with $p1$ -> $e1$ >> - | "try"; e = SELF; "with"; "["; l = LIST0 match_case SEP "|"; "]" -> - <:expr< try $e$ with [ $list:l$ ] >> - | "try"; e = SELF; "with"; p1 = ipatt; "->"; e1 = SELF -> - <:expr< try $e$ with $p1$ -> $e1$ >> - | "if"; e1 = SELF; "then"; e2 = SELF; "else"; e3 = SELF -> - <:expr< if $e1$ then $e2$ else $e3$ >> - | "do"; "{"; seq = sequence; "}" -> mksequence loc seq - | "for"; i = LIDENT; "="; e1 = SELF; df = direction_flag; e2 = SELF; - "do"; "{"; seq = sequence; "}" -> - <:expr< for $i$ = $e1$ $to:df$ $e2$ do { $list:seq$ } >> - | "while"; e = SELF; "do"; "{"; seq = sequence; "}" -> - <:expr< while $e$ do { $list:seq$ } >> ] - | "where" - [ e = SELF; "where"; rf = OPT "rec"; lb = let_binding -> - <:expr< let $opt:o2b rf$ $list:[lb]$ in $e$ >> ] - | ":=" NONA - [ e1 = SELF; ":="; e2 = SELF; dummy -> <:expr< $e1$ := $e2$ >> ] - | "||" RIGHTA - [ e1 = SELF; "||"; e2 = SELF -> <:expr< $e1$ || $e2$ >> ] - | "&&" RIGHTA - [ e1 = SELF; "&&"; e2 = SELF -> <:expr< $e1$ && $e2$ >> ] - | "<" LEFTA - [ e1 = SELF; "<"; e2 = SELF -> <:expr< $e1$ < $e2$ >> - | e1 = SELF; ">"; e2 = SELF -> <:expr< $e1$ > $e2$ >> - | e1 = SELF; "<="; e2 = SELF -> <:expr< $e1$ <= $e2$ >> - | e1 = SELF; ">="; e2 = SELF -> <:expr< $e1$ >= $e2$ >> - | e1 = SELF; "="; e2 = SELF -> <:expr< $e1$ = $e2$ >> - | e1 = SELF; "<>"; e2 = SELF -> <:expr< $e1$ <> $e2$ >> - | e1 = SELF; "=="; e2 = SELF -> <:expr< $e1$ == $e2$ >> - | e1 = SELF; "!="; e2 = SELF -> <:expr< $e1$ != $e2$ >> ] - | "^" RIGHTA - [ e1 = SELF; "^"; e2 = SELF -> <:expr< $e1$ ^ $e2$ >> - | e1 = SELF; "@"; e2 = SELF -> <:expr< $e1$ @ $e2$ >> ] - | "+" LEFTA - [ e1 = SELF; "+"; e2 = SELF -> <:expr< $e1$ + $e2$ >> - | e1 = SELF; "-"; e2 = SELF -> <:expr< $e1$ - $e2$ >> - | e1 = SELF; "+."; e2 = SELF -> <:expr< $e1$ +. $e2$ >> - | e1 = SELF; "-."; e2 = SELF -> <:expr< $e1$ -. $e2$ >> ] - | "*" LEFTA - [ e1 = SELF; "*"; e2 = SELF -> <:expr< $e1$ * $e2$ >> - | e1 = SELF; "/"; e2 = SELF -> <:expr< $e1$ / $e2$ >> - | e1 = SELF; "*."; e2 = SELF -> <:expr< $e1$ *. $e2$ >> - | e1 = SELF; "/."; e2 = SELF -> <:expr< $e1$ /. $e2$ >> - | e1 = SELF; "land"; e2 = SELF -> <:expr< $e1$ land $e2$ >> - | e1 = SELF; "lor"; e2 = SELF -> <:expr< $e1$ lor $e2$ >> - | e1 = SELF; "lxor"; e2 = SELF -> <:expr< $e1$ lxor $e2$ >> - | e1 = SELF; "mod"; e2 = SELF -> <:expr< $e1$ mod $e2$ >> ] - | "**" RIGHTA - [ e1 = SELF; "**"; e2 = SELF -> <:expr< $e1$ ** $e2$ >> - | e1 = SELF; "asr"; e2 = SELF -> <:expr< $e1$ asr $e2$ >> - | e1 = SELF; "lsl"; e2 = SELF -> <:expr< $e1$ lsl $e2$ >> - | e1 = SELF; "lsr"; e2 = SELF -> <:expr< $e1$ lsr $e2$ >> ] - | "unary minus" NONA - [ "-"; e = SELF -> mkumin loc "-" e - | "-."; e = SELF -> mkumin loc "-." e ] - | "apply" LEFTA - [ e1 = SELF; e2 = SELF -> <:expr< $e1$ $e2$ >> - | "assert"; e = SELF -> mkassert loc e - | "lazy"; e = SELF -> <:expr< lazy ($e$) >> ] - | "." LEFTA - [ e1 = SELF; "."; "("; e2 = SELF; ")" -> <:expr< $e1$ .( $e2$ ) >> - | e1 = SELF; "."; "["; e2 = SELF; "]" -> <:expr< $e1$ .[ $e2$ ] >> - | e1 = SELF; "."; e2 = SELF -> <:expr< $e1$ . $e2$ >> ] - | "~-" NONA - [ "~-"; e = SELF -> <:expr< ~- $e$ >> - | "~-."; e = SELF -> <:expr< ~-. $e$ >> ] - | "simple" - [ s = INT -> <:expr< $int:s$ >> - | s = INT32 -> MLast.ExInt32 loc s - | s = INT64 -> MLast.ExInt64 loc s - | s = NATIVEINT -> MLast.ExNativeInt loc s - | s = FLOAT -> <:expr< $flo:s$ >> - | s = STRING -> <:expr< $str:s$ >> - | s = CHAR -> <:expr< $chr:s$ >> - | i = expr_ident -> i - | "["; "]" -> <:expr< [] >> - | "["; el = LIST1 expr SEP ";"; last = cons_expr_opt; "]" -> - mklistexp loc last el - | "[|"; el = LIST0 expr SEP ";"; "|]" -> <:expr< [| $list:el$ |] >> - | "{"; lel = LIST1 label_expr SEP ";"; "}" -> <:expr< { $list:lel$ } >> - | "{"; "("; e = SELF; ")"; "with"; lel = LIST1 label_expr SEP ";"; - "}" -> - <:expr< { ($e$) with $list:lel$ } >> - | "("; ")" -> <:expr< () >> - | "("; e = SELF; ":"; t = ctyp; ")" -> <:expr< ($e$ : $t$) >> - | "("; e = SELF; ","; el = LIST1 expr SEP ","; ")" -> - <:expr< ( $list:[e::el]$) >> - | "("; e = SELF; ")" -> <:expr< $e$ >> ] ] - ; - cons_expr_opt: - [ [ "::"; e = expr -> Some e - | -> None ] ] - ; - dummy: - [ [ -> () ] ] - ; - sequence: - [ [ "let"; rf = OPT "rec"; l = LIST1 let_binding SEP "and"; [ "in" | ";" ]; - el = SELF -> - [<:expr< let $opt:o2b rf$ $list:l$ in $mksequence loc el$ >>] - | e = expr; ";"; el = SELF -> [e :: el] - | e = expr; ";" -> [e] - | e = expr -> [e] ] ] - ; - let_binding: - [ [ p = ipatt; e = fun_binding -> (p, e) ] ] - ; - fun_binding: - [ RIGHTA - [ p = ipatt; e = SELF -> <:expr< fun $p$ -> $e$ >> - | "="; e = expr -> <:expr< $e$ >> - | ":"; t = ctyp; "="; e = expr -> <:expr< ($e$ : $t$) >> ] ] - ; - match_case: - [ [ p = patt; aso = as_patt_opt; w = when_expr_opt; "->"; e = expr -> - mkmatchcase loc p aso w e ] ] - ; - as_patt_opt: - [ [ "as"; p = patt -> Some p - | -> None ] ] - ; - when_expr_opt: - [ [ "when"; e = expr -> Some e - | -> None ] ] - ; - label_expr: - [ [ i = patt_label_ident; e = fun_binding -> (i, e) ] ] - ; - expr_ident: - [ RIGHTA - [ i = LIDENT -> <:expr< $lid:i$ >> - | i = UIDENT -> <:expr< $uid:i$ >> - | i = UIDENT; "."; j = SELF -> mkexprident loc i j ] ] - ; - fun_def: - [ RIGHTA - [ p = ipatt; e = SELF -> <:expr< fun $p$ -> $e$ >> - | "->"; e = expr -> e ] ] - ; - patt: - [ LEFTA - [ p1 = SELF; "|"; p2 = SELF -> <:patt< $p1$ | $p2$ >> ] - | NONA - [ p1 = SELF; ".."; p2 = SELF -> <:patt< $p1$ .. $p2$ >> ] - | LEFTA - [ p1 = SELF; p2 = SELF -> <:patt< $p1$ $p2$ >> ] - | LEFTA - [ p1 = SELF; "."; p2 = SELF -> <:patt< $p1$ . $p2$ >> ] - | "simple" - [ s = LIDENT -> <:patt< $lid:s$ >> - | s = UIDENT -> <:patt< $uid:s$ >> - | s = INT -> <:patt< $int:s$ >> - | s = INT32 -> MLast.PaInt32 loc s - | s = INT64 -> MLast.PaInt64 loc s - | s = NATIVEINT -> MLast.PaNativeInt loc s - | s = FLOAT -> <:patt< $flo:s$ >> - | s = STRING -> <:patt< $str:s$ >> - | s = CHAR -> <:patt< $chr:s$ >> - | "-"; s = INT -> MLast.PaInt loc (neg_string s) - | "-"; s = INT32 -> MLast.PaInt32 loc (neg_string s) - | "-"; s = INT64 -> MLast.PaInt64 loc (neg_string s) - | "-"; s = NATIVEINT -> MLast.PaNativeInt loc (neg_string s) - | "-"; s = FLOAT -> <:patt< $flo:neg_string s$ >> - | "["; "]" -> <:patt< [] >> - | "["; pl = LIST1 patt SEP ";"; last = cons_patt_opt; "]" -> - mklistpat loc last pl - | "[|"; pl = LIST0 patt SEP ";"; "|]" -> <:patt< [| $list:pl$ |] >> - | "{"; lpl = LIST1 label_patt SEP ";"; "}" -> <:patt< { $list:lpl$ } >> - | "("; ")" -> <:patt< () >> - | "("; p = SELF; ")" -> <:patt< $p$ >> - | "("; p = SELF; ":"; t = ctyp; ")" -> <:patt< ($p$ : $t$) >> - | "("; p = SELF; "as"; p2 = SELF; ")" -> <:patt< ($p$ as $p2$) >> - | "("; p = SELF; ","; pl = LIST1 patt SEP ","; ")" -> - <:patt< ( $list:[p::pl]$) >> - | "_" -> <:patt< _ >> ] ] - ; - cons_patt_opt: - [ [ "::"; p = patt -> Some p - | -> None ] ] - ; - label_patt: - [ [ i = patt_label_ident; "="; p = patt -> (i, p) ] ] - ; - patt_label_ident: - [ LEFTA - [ p1 = SELF; "."; p2 = SELF -> <:patt< $p1$ . $p2$ >> ] - | "simple" RIGHTA - [ i = UIDENT -> <:patt< $uid:i$ >> - | i = LIDENT -> <:patt< $lid:i$ >> ] ] - ; - ipatt: - [ [ "{"; lpl = LIST1 label_ipatt SEP ";"; "}" -> <:patt< { $list:lpl$ } >> - | "("; ")" -> <:patt< () >> - | "("; p = SELF; ")" -> <:patt< $p$ >> - | "("; p = SELF; ":"; t = ctyp; ")" -> <:patt< ($p$ : $t$) >> - | "("; p = SELF; "as"; p2 = SELF; ")" -> <:patt< ($p$ as $p2$) >> - | "("; p = SELF; ","; pl = LIST1 ipatt SEP ","; ")" -> - <:patt< ( $list:[p::pl]$) >> - | s = LIDENT -> <:patt< $lid:s$ >> - | "_" -> <:patt< _ >> ] ] - ; - label_ipatt: - [ [ i = patt_label_ident; "="; p = ipatt -> (i, p) ] ] - ; - type_declaration: - [ [ n = type_patt; tpl = LIST0 type_parameter; "="; tk = ctyp; - cl = LIST0 constrain -> - (n, tpl, tk, cl) ] ] - ; - type_patt: - [ [ n = LIDENT -> (loc, n) ] ] - ; - constrain: - [ [ "constraint"; t1 = ctyp; "="; t2 = ctyp -> (t1, t2) ] ] - ; - type_parameter: - [ [ "'"; i = ident -> (i, (False, False)) - | "+"; "'"; i = ident -> (i, (True, False)) - | "-"; "'"; i = ident -> (i, (False, True)) ] ] - ; - ctyp: - [ LEFTA - [ t1 = SELF; "=="; t2 = SELF -> <:ctyp< $t1$ == $t2$ >> ] - | LEFTA - [ t1 = SELF; "as"; t2 = SELF -> <:ctyp< $t1$ as $t2$ >> ] - | LEFTA - [ "!"; pl = LIST1 typevar; "."; t = ctyp -> - <:ctyp< ! $list:pl$ . $t$ >> ] - | "arrow" RIGHTA - [ t1 = SELF; "->"; t2 = SELF -> <:ctyp< $t1$ -> $t2$ >> ] - | "label" NONA - [ i = TILDEIDENT; ":"; t = SELF -> <:ctyp< ~ $i$ : $t$ >> - | i = LABEL; t = SELF -> <:ctyp< ~ $i$ : $t$ >> - | i = QUESTIONIDENT; ":"; t = SELF -> <:ctyp< ? $i$ : $t$ >> - | i = OPTLABEL; t = SELF -> <:ctyp< ? $i$ : $t$ >> ] - | LEFTA - [ t1 = SELF; t2 = SELF -> <:ctyp< $t1$ $t2$ >> ] - | LEFTA - [ t1 = SELF; "."; t2 = SELF -> <:ctyp< $t1$ . $t2$ >> ] - | "simple" - [ "'"; i = ident -> <:ctyp< '$i$ >> - | "_" -> <:ctyp< _ >> - | i = LIDENT -> <:ctyp< $lid:i$ >> - | i = UIDENT -> <:ctyp< $uid:i$ >> - | "("; t = SELF; "*"; tl = LIST1 ctyp SEP "*"; ")" -> - <:ctyp< ( $list:[t::tl]$ ) >> - | "("; t = SELF; ")" -> <:ctyp< $t$ >> - | "private"; "["; cdl = LIST0 constructor_declaration SEP "|"; "]" -> - <:ctyp< private [ $list:cdl$ ] >> - | "private"; "{"; ldl = LIST1 label_declaration SEP ";"; "}" -> - <:ctyp< private { $list:ldl$ } >> - | "["; cdl = LIST0 constructor_declaration SEP "|"; "]" -> - <:ctyp< [ $list:cdl$ ] >> - | "{"; ldl = LIST1 label_declaration SEP ";"; "}" -> - <:ctyp< { $list:ldl$ } >> ] ] - ; - constructor_declaration: - [ [ ci = UIDENT; "of"; cal = LIST1 ctyp SEP "and" -> (loc, ci, cal) - | ci = UIDENT -> (loc, ci, []) ] ] - ; - label_declaration: - [ [ i = LIDENT; ":"; mf = OPT "mutable"; t = ctyp -> - (loc, i, o2b mf, t) ] ] - ; - ident: - [ [ i = LIDENT -> i - | i = UIDENT -> i ] ] - ; - mod_ident: - [ RIGHTA - [ i = UIDENT -> [i] - | i = LIDENT -> [i] - | i = UIDENT; "."; j = SELF -> [i :: j] ] ] - ; - (* Objects and Classes *) - str_item: - [ [ "class"; cd = LIST1 class_declaration SEP "and" -> - <:str_item< class $list:cd$ >> - | "class"; "type"; ctd = LIST1 class_type_declaration SEP "and" -> - <:str_item< class type $list:ctd$ >> ] ] - ; - sig_item: - [ [ "class"; cd = LIST1 class_description SEP "and" -> - <:sig_item< class $list:cd$ >> - | "class"; "type"; ctd = LIST1 class_type_declaration SEP "and" -> - <:sig_item< class type $list:ctd$ >> ] ] - ; - class_declaration: - [ [ vf = OPT "virtual"; i = LIDENT; ctp = class_type_parameters; - cfb = class_fun_binding -> - {MLast.ciLoc = loc; MLast.ciVir = o2b vf; MLast.ciPrm = ctp; - MLast.ciNam = i; MLast.ciExp = cfb} ] ] - ; - class_fun_binding: - [ [ "="; ce = class_expr -> ce - | ":"; ct = class_type; "="; ce = class_expr -> - <:class_expr< ($ce$ : $ct$) >> - | p = ipatt; cfb = SELF -> <:class_expr< fun $p$ -> $cfb$ >> ] ] - ; - class_type_parameters: - [ [ -> (loc, []) - | "["; tpl = LIST1 type_parameter SEP ","; "]" -> (loc, tpl) ] ] - ; - class_fun_def: - [ [ p = ipatt; ce = SELF -> <:class_expr< fun $p$ -> $ce$ >> - | "->"; ce = class_expr -> ce ] ] - ; - class_expr: - [ "top" - [ "fun"; p = ipatt; ce = class_fun_def -> - <:class_expr< fun $p$ -> $ce$ >> - | "let"; rf = OPT "rec"; lb = LIST1 let_binding SEP "and"; "in"; - ce = SELF -> - <:class_expr< let $opt:o2b rf$ $list:lb$ in $ce$ >> ] - | "apply" NONA - [ ce = SELF; e = expr LEVEL "label" -> - <:class_expr< $ce$ $e$ >> ] - | "simple" - [ ci = class_longident; "["; ctcl = LIST0 ctyp SEP ","; "]" -> - <:class_expr< $list:ci$ [ $list:ctcl$ ] >> - | ci = class_longident -> <:class_expr< $list:ci$ >> - | "object"; cspo = OPT class_self_patt; cf = class_structure; "end" -> - <:class_expr< object $opt:cspo$ $list:cf$ end >> - | "("; ce = SELF; ":"; ct = class_type; ")" -> - <:class_expr< ($ce$ : $ct$) >> - | "("; ce = SELF; ")" -> ce ] ] - ; - class_structure: - [ [ cf = LIST0 [ cf = class_str_item; ";" -> cf ] -> cf ] ] - ; - class_self_patt: - [ [ "("; p = patt; ")" -> p - | "("; p = patt; ":"; t = ctyp; ")" -> <:patt< ($p$ : $t$) >> ] ] - ; - class_str_item: - [ [ "declare"; st = LIST0 [ s= class_str_item; ";" -> s ]; "end" -> - <:class_str_item< declare $list:st$ end >> - | "inherit"; ce = class_expr; pb = OPT as_lident -> - <:class_str_item< inherit $ce$ $opt:pb$ >> - | "value"; mf = OPT "mutable"; lab = label; e = cvalue_binding -> - <:class_str_item< value $opt:o2b mf$ $lab$ = $e$ >> - | "method"; "virtual"; pf = OPT "private"; l = label; ":"; t = ctyp -> - <:class_str_item< method virtual $opt:o2b pf$ $l$ : $t$ >> - | "method"; pf = OPT "private"; l = label; topt = OPT polyt; - e = fun_binding -> - <:class_str_item< method $opt:o2b pf$ $l$ $opt:topt$ = $e$ >> - | "type"; t1 = ctyp; "="; t2 = ctyp -> - <:class_str_item< type $t1$ = $t2$ >> - | "initializer"; se = expr -> <:class_str_item< initializer $se$ >> ] ] - ; - as_lident: - [ [ "as"; i = LIDENT -> i ] ] - ; - polyt: - [ [ ":"; t = ctyp -> t ] ] - ; - cvalue_binding: - [ [ "="; e = expr -> e - | ":"; t = ctyp; "="; e = expr -> <:expr< ($e$ : $t$) >> - | ":"; t = ctyp; ":>"; t2 = ctyp; "="; e = expr -> - <:expr< ($e$ : $t$ :> $t2$) >> - | ":>"; t = ctyp; "="; e = expr -> <:expr< ($e$ :> $t$) >> ] ] - ; - label: - [ [ i = LIDENT -> i ] ] - ; - class_type: - [ [ "["; t = ctyp; "]"; "->"; ct = SELF -> - <:class_type< [ $t$ ] -> $ct$ >> - | id = clty_longident; "["; tl = LIST1 ctyp SEP ","; "]" -> - <:class_type< $list:id$ [ $list:tl$ ] >> - | id = clty_longident -> <:class_type< $list:id$ >> - | "object"; cst = OPT class_self_type; - csf = LIST0 [ csf = class_sig_item; ";" -> csf ]; "end" -> - <:class_type< object $opt:cst$ $list:csf$ end >> ] ] - ; - class_self_type: - [ [ "("; t = ctyp; ")" -> t ] ] - ; - class_sig_item: - [ [ "declare"; st = LIST0 [ s = class_sig_item; ";" -> s ]; "end" -> - <:class_sig_item< declare $list:st$ end >> - | "inherit"; cs = class_type -> <:class_sig_item< inherit $cs$ >> - | "value"; mf = OPT "mutable"; l = label; ":"; t = ctyp -> - <:class_sig_item< value $opt:o2b mf$ $l$ : $t$ >> - | "method"; "virtual"; pf = OPT "private"; l = label; ":"; t = ctyp -> - <:class_sig_item< method virtual $opt:o2b pf$ $l$ : $t$ >> - | "method"; pf = OPT "private"; l = label; ":"; t = ctyp -> - <:class_sig_item< method $opt:o2b pf$ $l$ : $t$ >> - | "type"; t1 = ctyp; "="; t2 = ctyp -> - <:class_sig_item< type $t1$ = $t2$ >> ] ] - ; - class_description: - [ [ vf = OPT "virtual"; n = LIDENT; ctp = class_type_parameters; ":"; - ct = class_type -> - {MLast.ciLoc = loc; MLast.ciVir = o2b vf; MLast.ciPrm = ctp; - MLast.ciNam = n; MLast.ciExp = ct} ] ] - ; - class_type_declaration: - [ [ vf = OPT "virtual"; n = LIDENT; ctp = class_type_parameters; "="; - cs = class_type -> - {MLast.ciLoc = loc; MLast.ciVir = o2b vf; MLast.ciPrm = ctp; - MLast.ciNam = n; MLast.ciExp = cs} ] ] - ; - expr: LEVEL "apply" - [ LEFTA - [ "new"; i = class_longident -> <:expr< new $list:i$ >> ] ] - ; - expr: LEVEL "." - [ [ e = SELF; "#"; lab = label -> <:expr< $e$ # $lab$ >> ] ] - ; - expr: LEVEL "simple" - [ [ "("; e = SELF; ":"; t = ctyp; ":>"; t2 = ctyp; ")" -> - <:expr< ($e$ : $t$ :> $t2$ ) >> - | "("; e = SELF; ":>"; t = ctyp; ")" -> <:expr< ($e$ :> $t$) >> - | "{<"; fel = LIST0 field_expr SEP ";"; ">}" -> - <:expr< {< $list:fel$ >} >> ] ] - ; - field_expr: - [ [ l = label; "="; e = expr -> (l, e) ] ] - ; - ctyp: LEVEL "simple" - [ [ "#"; id = class_longident -> <:ctyp< # $list:id$ >> - | "<"; ml = LIST0 field SEP ";"; v = OPT ".."; ">" -> - <:ctyp< < $list:ml$ $opt:o2b v$ > >> ] ] - ; - field: - [ [ lab = LIDENT; ":"; t = ctyp -> (lab, t) ] ] - ; - typevar: - [ [ "'"; i = ident -> i ] ] - ; - clty_longident: - [ [ m = UIDENT; "."; l = SELF -> [m :: l] - | i = LIDENT -> [i] ] ] - ; - class_longident: - [ [ m = UIDENT; "."; l = SELF -> [m :: l] - | i = LIDENT -> [i] ] ] - ; - ctyp: LEVEL "simple" - [ [ "["; "="; rfl = row_field_list; "]" -> - <:ctyp< [ = $list:rfl$ ] >> - | "["; ">"; rfl = row_field_list; "]" -> - <:ctyp< [ > $list:rfl$ ] >> - | "["; "<"; rfl = row_field_list; "]" -> - <:ctyp< [ < $list:rfl$ ] >> - | "["; "<"; rfl = row_field_list; ">"; ntl = LIST1 name_tag; "]" -> - <:ctyp< [ < $list:rfl$ > $list:ntl$ ] >> ] ] - ; - row_field_list: - [ [ rfl = LIST0 row_field SEP "|" -> rfl ] ] - ; - row_field: - [ [ "`"; i = ident -> <:row_field< ` $i$ >> - | "`"; i = ident; "of"; ao = OPT "&"; l = LIST1 ctyp SEP "&" -> - <:row_field< ` $i$ of $opt:o2b ao$ $list:l$ >> - | t = ctyp -> <:row_field< $t$ >> ] ] - ; - name_tag: - [ [ "`"; i = ident -> i ] ] - ; - patt: LEVEL "simple" - [ [ "`"; s = ident -> <:patt< ` $s$ >> - | "#"; sl = mod_ident -> <:patt< # $list:sl$ >> - | i = TILDEIDENT; ":"; p = SELF -> <:patt< ~ $i$ : $p$ >> - | i = LABEL; p = SELF -> <:patt< ~ $i$ : $p$ >> - | i = TILDEIDENT -> <:patt< ~ $i$ >> - | i = QUESTIONIDENT; ":"; "("; p = patt_tcon; eo = OPT eq_expr; ")" -> - <:patt< ? $i$ : ($p$ $opt:eo$) >> - | i = OPTLABEL; "("; p = patt_tcon; eo = OPT eq_expr; ")" -> - <:patt< ? $i$ : ($p$ $opt:eo$) >> - | i = QUESTIONIDENT -> - <:patt< ? $i$ >> - | "?"; "("; p = patt_tcon; eo = OPT eq_expr; ")" -> - <:patt< ? ($p$ $opt:eo$) >> ] ] - ; - patt_tcon: - [ [ p = patt; ":"; t = ctyp -> <:patt< ($p$ : $t$) >> - | p = patt -> p ] ] - ; - ipatt: - [ [ i = TILDEIDENT; ":"; p = SELF -> <:patt< ~ $i$ : $p$ >> - | i = LABEL; p = SELF -> <:patt< ~ $i$ : $p$ >> - | i = TILDEIDENT -> <:patt< ~ $i$ >> - | i = QUESTIONIDENT; ":"; "("; p = ipatt_tcon; eo = OPT eq_expr; ")" -> - <:patt< ? $i$ : ($p$ $opt:eo$) >> - | i = OPTLABEL; "("; p = ipatt_tcon; eo = OPT eq_expr; ")" -> - <:patt< ? $i$ : ($p$ $opt:eo$) >> - | i = QUESTIONIDENT -> - <:patt< ? $i$ >> - | "?"; "("; p = ipatt_tcon; eo = OPT eq_expr; ")" -> - <:patt< ? ($p$ $opt:eo$) >> ] ] - ; - ipatt_tcon: - [ [ p = ipatt; ":"; t = ctyp -> <:patt< ($p$ : $t$) >> - | p = ipatt -> p ] ] - ; - eq_expr: - [ [ "="; e = expr -> e ] ] - ; - expr: AFTER "apply" - [ "label" NONA - [ i = TILDEIDENT; ":"; e = SELF -> <:expr< ~ $i$ : $e$ >> - | i = LABEL; e = SELF -> <:expr< ~ $i$ : $e$ >> - | i = TILDEIDENT -> <:expr< ~ $i$ >> - | i = QUESTIONIDENT; ":"; e = SELF -> <:expr< ? $i$ : $e$ >> - | i = OPTLABEL; e = SELF -> <:expr< ? $i$ : $e$ >> - | i = QUESTIONIDENT -> <:expr< ? $i$ >> ] ] - ; - expr: LEVEL "simple" - [ [ "`"; s = ident -> <:expr< ` $s$ >> ] ] - ; - direction_flag: - [ [ "to" -> True - | "downto" -> False ] ] - ; - (* Compatibility old syntax of variant types definitions *) - ctyp: LEVEL "simple" - [ [ "[|"; warning_variant; rfl = row_field_list; "|]" -> - <:ctyp< [ = $list:rfl$ ] >> - | "[|"; warning_variant; ">"; rfl = row_field_list; "|]" -> - <:ctyp< [ > $list:rfl$ ] >> - | "[|"; warning_variant; "<"; rfl = row_field_list; "|]" -> - <:ctyp< [ < $list:rfl$ ] >> - | "[|"; warning_variant; "<"; rfl = row_field_list; ">"; - ntl = LIST1 name_tag; "|]" -> - <:ctyp< [ < $list:rfl$ > $list:ntl$ ] >> ] ] - ; - warning_variant: - [ [ -> warn_variant loc ] ] - ; - (* Compatibility old syntax of sequences *) - expr: LEVEL "top" - [ [ "do"; seq = LIST0 [ e = expr; ";" -> e ]; "return"; warning_sequence; - e = SELF -> - <:expr< do { $list:append_elem seq e$ } >> - | "for"; i = LIDENT; "="; e1 = SELF; df = direction_flag; e2 = SELF; - "do"; seq = LIST0 [ e = expr; ";" -> e ]; warning_sequence; "done" -> - <:expr< for $i$ = $e1$ $to:df$ $e2$ do { $list:seq$ } >> - | "while"; e = SELF; "do"; seq = LIST0 [ e = expr; ";" -> e ]; - warning_sequence; "done" -> - <:expr< while $e$ do { $list:seq$ } >> ] ] - ; - warning_sequence: - [ [ -> warn_sequence loc ] ] - ; -END; - -EXTEND - GLOBAL: interf implem use_file top_phrase expr patt; - interf: - [ [ "#"; n = LIDENT; dp = OPT expr; ";" -> - ([(<:sig_item< # $n$ $opt:dp$ >>, loc)], True) - | si = sig_item_semi; (sil, stopped) = SELF -> ([si :: sil], stopped) - | EOI -> ([], False) ] ] - ; - sig_item_semi: - [ [ si = sig_item; ";" -> (si, loc) ] ] - ; - implem: - [ [ "#"; n = LIDENT; dp = OPT expr; ";" -> - ([(<:str_item< # $n$ $opt:dp$ >>, loc)], True) - | si = str_item_semi; (sil, stopped) = SELF -> ([si :: sil], stopped) - | EOI -> ([], False) ] ] - ; - str_item_semi: - [ [ si = str_item; ";" -> (si, loc) ] ] - ; - top_phrase: - [ [ ph = phrase -> Some ph - | EOI -> None ] ] - ; - use_file: - [ [ "#"; n = LIDENT; dp = OPT expr; ";" -> - ([<:str_item< # $n$ $opt:dp$ >>], True) - | si = str_item; ";"; (sil, stopped) = SELF -> ([si :: sil], stopped) - | EOI -> ([], False) ] ] - ; - phrase: - [ [ "#"; n = LIDENT; dp = OPT expr; ";" -> - <:str_item< # $n$ $opt:dp$ >> - | sti = str_item; ";" -> sti ] ] - ; - expr: LEVEL "simple" - [ [ x = LOCATE -> - let x = - try - let i = String.index x ':' in - (int_of_string (String.sub x 0 i), - String.sub x (i + 1) (String.length x - i - 1)) - with - [ Not_found | Failure _ -> (0, x) ] - in - Pcaml.handle_expr_locate loc x - | x = QUOTATION -> - let x = - try - let i = String.index x ':' in - (String.sub x 0 i, - String.sub x (i + 1) (String.length x - i - 1)) - with - [ Not_found -> ("", x) ] - in - Pcaml.handle_expr_quotation loc x ] ] - ; - patt: LEVEL "simple" - [ [ x = LOCATE -> - let x = - try - let i = String.index x ':' in - (int_of_string (String.sub x 0 i), - String.sub x (i + 1) (String.length x - i - 1)) - with - [ Not_found | Failure _ -> (0, x) ] - in - Pcaml.handle_patt_locate loc x - | x = QUOTATION -> - let x = - try - let i = String.index x ':' in - (String.sub x 0 i, - String.sub x (i + 1) (String.length x - i - 1)) - with - [ Not_found -> ("", x) ] - in - Pcaml.handle_patt_quotation loc x ] ] - ; -END; diff --git a/camlp4/meta/pa_rp.ml b/camlp4/meta/pa_rp.ml deleted file mode 100644 index cb3566cd3e..0000000000 --- a/camlp4/meta/pa_rp.ml +++ /dev/null @@ -1,318 +0,0 @@ -(* camlp4r pa_extend.cmo q_MLast.cmo *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1998 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -open Pcaml; - -type spat_comp = - [ SpTrm of MLast.loc and MLast.patt and option MLast.expr - | SpNtr of MLast.loc and MLast.patt and MLast.expr - | SpStr of MLast.loc and MLast.patt ] -; -type sexp_comp = - [ SeTrm of MLast.loc and MLast.expr | SeNtr of MLast.loc and MLast.expr ] -; - -value strm_n = "strm__"; -value peek_fun loc = <:expr< Stream.peek >>; -value junk_fun loc = <:expr< Stream.junk >>; - -(* Parsers. *) -(* In syntax generated, many cases are optimisations. *) - -value rec pattern_eq_expression p e = - match (p, e) with - [ (<:patt< $lid:a$ >>, <:expr< $lid:b$ >>) -> a = b - | (<:patt< $uid:a$ >>, <:expr< $uid:b$ >>) -> a = b - | (<:patt< $p1$ $p2$ >>, <:expr< $e1$ $e2$ >>) -> - pattern_eq_expression p1 e1 && pattern_eq_expression p2 e2 - | _ -> False ] -; - -value is_raise e = - match e with - [ <:expr< raise $_$ >> -> True - | _ -> False ] -; - -value is_raise_failure e = - match e with - [ <:expr< raise Stream.Failure >> -> True - | _ -> False ] -; - -value rec handle_failure e = - match e with - [ <:expr< try $te$ with [ Stream.Failure -> $e$] >> -> handle_failure e - | <:expr< match $me$ with [ $list:pel$ ] >> -> - handle_failure me && - List.for_all - (fun - [ (_, None, e) -> handle_failure e - | _ -> False ]) - pel - | <:expr< let $list:pel$ in $e$ >> -> - List.for_all (fun (p, e) -> handle_failure e) pel && handle_failure e - | <:expr< $lid:_$ >> | <:expr< $int:_$ >> | <:expr< $str:_$ >> | - <:expr< $chr:_$ >> | <:expr< fun [ $list:_$ ] >> | <:expr< $uid:_$ >> -> - True - | <:expr< raise $e$ >> -> - match e with - [ <:expr< Stream.Failure >> -> False - | _ -> True ] - | <:expr< $f$ $x$ >> -> - is_constr_apply f && handle_failure f && handle_failure x - | _ -> False ] -and is_constr_apply = - fun - [ <:expr< $uid:_$ >> -> True - | <:expr< $lid:_$ >> -> False - | <:expr< $x$ $_$ >> -> is_constr_apply x - | _ -> False ] -; - -value rec subst v e = - let loc = MLast.loc_of_expr e in - match e with - [ <:expr< $lid:x$ >> -> - let x = if x = v then strm_n else x in <:expr< $lid:x$ >> - | <:expr< $uid:_$ >> -> e - | <:expr< $int:_$ >> -> e - | <:expr< $chr:_$ >> -> e - | <:expr< $str:_$ >> -> e - | <:expr< $_$.$_$ >> -> e - | <:expr< let $opt:rf$ $list:pel$ in $e$ >> -> - <:expr< let $opt:rf$ $list:List.map (subst_pe v) pel$ in $subst v e$ >> - | <:expr< $e1$ $e2$ >> -> <:expr< $subst v e1$ $subst v e2$ >> - | <:expr< ( $list:el$ ) >> -> <:expr< ( $list:List.map (subst v) el$ ) >> - | _ -> raise Not_found ] -and subst_pe v (p, e) = - match p with - [ <:patt< $lid:v'$ >> when v <> v' -> (p, subst v e) - | _ -> raise Not_found ] -; - -value stream_pattern_component skont ckont = - fun - [ SpTrm loc p wo -> - <:expr< match $peek_fun loc$ $lid:strm_n$ with - [ Some $p$ $when:wo$ -> - do { $junk_fun loc$ $lid:strm_n$; $skont$ } - | _ -> $ckont$ ] >> - | SpNtr loc p e -> - let e = - match e with - [ <:expr< fun [ ($lid:v$ : Stream.t _) -> $e$ ] >> when v = strm_n -> e - | _ -> <:expr< $e$ $lid:strm_n$ >> ] - in - if pattern_eq_expression p skont then - if is_raise_failure ckont then e - else if handle_failure e then e - else <:expr< try $e$ with [ Stream.Failure -> $ckont$ ] >> - else if is_raise_failure ckont then <:expr< let $p$ = $e$ in $skont$ >> - else if pattern_eq_expression <:patt< Some $p$ >> skont then - <:expr< try Some $e$ with [ Stream.Failure -> $ckont$ ] >> - else if is_raise ckont then - let tst = - if handle_failure e then e - else <:expr< try $e$ with [ Stream.Failure -> $ckont$ ] >> - in - <:expr< let $p$ = $tst$ in $skont$ >> - else - <:expr< match try Some $e$ with [ Stream.Failure -> None ] with - [ Some $p$ -> $skont$ - | _ -> $ckont$ ] >> - | SpStr loc p -> - try - match p with - [ <:patt< $lid:v$ >> -> subst v skont - | _ -> raise Not_found ] - with - [ Not_found -> <:expr< let $p$ = $lid:strm_n$ in $skont$ >> ] ] -; - -value rec stream_pattern loc epo e ekont = - fun - [ [] -> - match epo with - [ Some ep -> <:expr< let $ep$ = Stream.count $lid:strm_n$ in $e$ >> - | _ -> e ] - | [(spc, err) :: spcl] -> - let skont = - let ekont err = - let str = - match err with - [ Some estr -> estr - | _ -> <:expr< "" >> ] - in - <:expr< raise (Stream.Error $str$) >> - in - stream_pattern loc epo e ekont spcl - in - let ckont = ekont err in stream_pattern_component skont ckont spc ] -; - -value stream_patterns_term loc ekont tspel = - let pel = - List.map - (fun (p, w, loc, spcl, epo, e) -> - let p = <:patt< Some $p$ >> in - let e = - let ekont err = - let str = - match err with - [ Some estr -> estr - | _ -> <:expr< "" >> ] - in - <:expr< raise (Stream.Error $str$) >> - in - let skont = stream_pattern loc epo e ekont spcl in - <:expr< do { $junk_fun loc$ $lid:strm_n$; $skont$ } >> - in - (p, w, e)) - tspel - in - let pel = pel @ [(<:patt< _ >>, None, ekont ())] in - <:expr< match $peek_fun loc$ $lid:strm_n$ with [ $list:pel$ ] >> -; - -value rec group_terms = - fun - [ [([(SpTrm loc p w, None) :: spcl], epo, e) :: spel] -> - let (tspel, spel) = group_terms spel in - ([(p, w, loc, spcl, epo, e) :: tspel], spel) - | spel -> ([], spel) ] -; - -value rec parser_cases loc = - fun - [ [] -> <:expr< raise Stream.Failure >> - | spel -> - match group_terms spel with - [ ([], [(spcl, epo, e) :: spel]) -> - stream_pattern loc epo e (fun _ -> parser_cases loc spel) spcl - | (tspel, spel) -> - stream_patterns_term loc (fun _ -> parser_cases loc spel) tspel ] ] -; - -value cparser loc bpo pc = - let e = parser_cases loc pc in - let e = - match bpo with - [ Some bp -> <:expr< let $bp$ = Stream.count $lid:strm_n$ in $e$ >> - | None -> e ] - in - let p = <:patt< ($lid:strm_n$ : Stream.t _) >> in <:expr< fun $p$ -> $e$ >> -; - -value cparser_match loc me bpo pc = - let pc = parser_cases loc pc in - let e = - match bpo with - [ Some bp -> <:expr< let $bp$ = Stream.count $lid:strm_n$ in $pc$ >> - | None -> pc ] - in - match me with - [ <:expr< $lid:x$ >> when x = strm_n -> e - | _ -> <:expr< let ($lid:strm_n$ : Stream.t _) = $me$ in $e$ >> ] -; - -(* streams *) - -value rec not_computing = - fun - [ <:expr< $lid:_$ >> | <:expr< $uid:_$ >> | <:expr< $int:_$ >> | - <:expr< $flo:_$ >> | <:expr< $chr:_$ >> | <:expr< $str:_$ >> -> - True - | <:expr< $x$ $y$ >> -> is_cons_apply_not_computing x && not_computing y - | _ -> False ] -and is_cons_apply_not_computing = - fun - [ <:expr< $uid:_$ >> -> True - | <:expr< $lid:_$ >> -> False - | <:expr< $x$ $y$ >> -> is_cons_apply_not_computing x && not_computing y - | _ -> False ] -; - -value slazy loc e = - match e with - [ <:expr< $f$ () >> -> - match f with - [ <:expr< $lid:_$ >> -> f - | _ -> <:expr< fun _ -> $e$ >> ] - | _ -> <:expr< fun _ -> $e$ >> ] -; - -value rec cstream gloc = - fun - [ [] -> let loc = gloc in <:expr< Stream.sempty >> - | [SeTrm loc e] -> - if not_computing e then <:expr< Stream.ising $e$ >> - else <:expr< Stream.lsing $slazy loc e$ >> - | [SeTrm loc e :: secl] -> - if not_computing e then <:expr< Stream.icons $e$ $cstream gloc secl$ >> - else <:expr< Stream.lcons $slazy loc e$ $cstream gloc secl$ >> - | [SeNtr loc e] -> - if not_computing e then e else <:expr< Stream.slazy $slazy loc e$ >> - | [SeNtr loc e :: secl] -> - if not_computing e then <:expr< Stream.iapp $e$ $cstream gloc secl$ >> - else <:expr< Stream.lapp $slazy loc e$ $cstream gloc secl$ >> ] -; - -(* Syntax extensions in Revised Syntax grammar *) - -EXTEND - GLOBAL: expr; - expr: LEVEL "top" - [ [ "parser"; po = OPT ipatt; "["; pcl = LIST0 parser_case SEP "|"; "]" -> - <:expr< $cparser loc po pcl$ >> - | "parser"; po = OPT ipatt; pc = parser_case -> - <:expr< $cparser loc po [pc]$ >> - | "match"; e = SELF; "with"; "parser"; po = OPT ipatt; "["; - pcl = LIST0 parser_case SEP "|"; "]" -> - <:expr< $cparser_match loc e po pcl$ >> - | "match"; e = SELF; "with"; "parser"; po = OPT ipatt; - pc = parser_case -> - <:expr< $cparser_match loc e po [pc]$ >> ] ] - ; - parser_case: - [ [ "[:"; sp = stream_patt; ":]"; po = OPT ipatt; "->"; e = expr -> - (sp, po, e) ] ] - ; - stream_patt: - [ [ spc = stream_patt_comp -> [(spc, None)] - | spc = stream_patt_comp; ";"; - sp = LIST1 stream_patt_comp_err SEP ";" -> - [(spc, None) :: sp] - | -> [] ] ] - ; - stream_patt_comp_err: - [ [ spc = stream_patt_comp; eo = OPT [ "?"; e = expr -> e ] -> - (spc, eo) ] ] - ; - stream_patt_comp: - [ [ "`"; p = patt; eo = OPT [ "when"; e = expr -> e ] -> SpTrm loc p eo - | p = patt; "="; e = expr -> SpNtr loc p e - | p = patt -> SpStr loc p ] ] - ; - ipatt: - [ [ i = LIDENT -> <:patt< $lid:i$ >> ] ] - ; - expr: LEVEL "simple" - [ [ "[:"; se = LIST0 stream_expr_comp SEP ";"; ":]" -> - <:expr< $cstream loc se$ >> ] ] - ; - stream_expr_comp: - [ [ "`"; e = expr -> SeTrm loc e | e = expr -> SeNtr loc e ] ] - ; -END; diff --git a/camlp4/meta/pr_dump.ml b/camlp4/meta/pr_dump.ml deleted file mode 100644 index 2558c5fa93..0000000000 --- a/camlp4/meta/pr_dump.ml +++ /dev/null @@ -1,52 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2001 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -value open_out_file () = - match Pcaml.output_file.val with - [ Some f -> open_out_bin f - | None -> do { set_binary_mode_out stdout True; stdout } ] -; - -value interf ast = - let pt = Ast2pt.interf (List.map fst ast) in - let oc = open_out_file () in - let fname = Pcaml.input_file.val in - do { - output_string oc Config.ast_intf_magic_number; - output_value oc (if fname = "-" then "" else fname); - output_value oc pt; - flush oc; - match Pcaml.output_file.val with - [ Some _ -> close_out oc - | None -> () ] - } -; - -value implem ast = - let pt = Ast2pt.implem (List.map fst ast) in - let oc = open_out_file () in - let fname = Pcaml.input_file.val in - do { - output_string oc Config.ast_impl_magic_number; - output_value oc (if fname = "-" then "" else fname); - output_value oc pt; - flush oc; - match Pcaml.output_file.val with - [ Some _ -> close_out oc - | None -> () ] - } -; - -Pcaml.print_interf.val := interf; -Pcaml.print_implem.val := implem; diff --git a/camlp4/meta/q_MLast.ml b/camlp4/meta/q_MLast.ml deleted file mode 100644 index c10ad7980c..0000000000 --- a/camlp4/meta/q_MLast.ml +++ /dev/null @@ -1,1501 +0,0 @@ -(* camlp4r pa_extend.cmo pa_extend_m.cmo q_MLast.cmo *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -value gram = Grammar.gcreate (Plexer.gmake ()); - -module Qast = - struct - type t = - [ Node of string and list t - | List of list t - | Tuple of list t - | Option of option t - | Int of string - | Str of string - | Bool of bool - | Cons of t and t - | Apply of string and list t - | Record of list (string * t) - | Loc - | Antiquot of MLast.loc and string ] - ; - value loc = (0, 0); - value rec to_expr = - fun - [ Node n al -> - List.fold_left (fun e a -> <:expr< $e$ $to_expr a$ >>) - <:expr< MLast.$uid:n$ >> al - | List al -> - List.fold_right (fun a e -> <:expr< [$to_expr a$ :: $e$] >>) al - <:expr< [] >> - | Tuple al -> <:expr< ($list:List.map to_expr al$) >> - | Option None -> <:expr< None >> - | Option (Some a) -> <:expr< Some $to_expr a$ >> - | Int s -> <:expr< $int:s$ >> - | Str s -> <:expr< $str:s$ >> - | Bool True -> <:expr< True >> - | Bool False -> <:expr< False >> - | Cons a1 a2 -> <:expr< [$to_expr a1$ :: $to_expr a2$] >> - | Apply f al -> - List.fold_left (fun e a -> <:expr< $e$ $to_expr a$ >>) - <:expr< $lid:f$ >> al - | Record lal -> <:expr< {$list:List.map to_expr_label lal$} >> - | Loc -> <:expr< $lid:Stdpp.loc_name.val$ >> - | Antiquot loc s -> - let e = - try Grammar.Entry.parse Pcaml.expr_eoi (Stream.of_string s) with - [ Stdpp.Exc_located (bp, ep) exc -> - raise (Stdpp.Exc_located (fst loc + bp, fst loc + ep) exc) ] - in - <:expr< $anti:e$ >> ] - and to_expr_label (l, a) = (<:patt< MLast.$lid:l$ >>, to_expr a); - value rec to_patt = - fun - [ Node n al -> - List.fold_left (fun e a -> <:patt< $e$ $to_patt a$ >>) - <:patt< MLast.$uid:n$ >> al - | List al -> - List.fold_right (fun a p -> <:patt< [$to_patt a$ :: $p$] >>) al - <:patt< [] >> - | Tuple al -> <:patt< ($list:List.map to_patt al$) >> - | Option None -> <:patt< None >> - | Option (Some a) -> <:patt< Some $to_patt a$ >> - | Int s -> <:patt< $int:s$ >> - | Str s -> <:patt< $str:s$ >> - | Bool True -> <:patt< True >> - | Bool False -> <:patt< False >> - | Cons a1 a2 -> <:patt< [$to_patt a1$ :: $to_patt a2$] >> - | Apply _ _ -> failwith "bad pattern" - | Record lal -> <:patt< {$list:List.map to_patt_label lal$} >> - | Loc -> <:patt< _ >> - | Antiquot loc s -> - let p = - try Grammar.Entry.parse Pcaml.patt_eoi (Stream.of_string s) with - [ Stdpp.Exc_located (bp, ep) exc -> - raise (Stdpp.Exc_located (fst loc + bp, fst loc + ep) exc) ] - in - <:patt< $anti:p$ >> ] - and to_patt_label (l, a) = (<:patt< MLast.$lid:l$ >>, to_patt a); - end -; - -value antiquot k (bp, ep) x = - let shift = - if k = "" then String.length "$" - else String.length "$" + String.length k + String.length ":" - in - Qast.Antiquot (shift + bp, shift + ep) x -; - -value sig_item = Grammar.Entry.create gram "signature item"; -value str_item = Grammar.Entry.create gram "structure item"; -value ctyp = Grammar.Entry.create gram "type"; -value patt = Grammar.Entry.create gram "pattern"; -value expr = Grammar.Entry.create gram "expression"; - -value module_type = Grammar.Entry.create gram "module type"; -value module_expr = Grammar.Entry.create gram "module expression"; - -value class_type = Grammar.Entry.create gram "class type"; -value class_expr = Grammar.Entry.create gram "class expr"; -value class_sig_item = Grammar.Entry.create gram "class signature item"; -value class_str_item = Grammar.Entry.create gram "class structure item"; - -value ipatt = Grammar.Entry.create gram "ipatt"; -value let_binding = Grammar.Entry.create gram "let_binding"; -value type_declaration = Grammar.Entry.create gram "type_declaration"; -value with_constr = Grammar.Entry.create gram "with_constr"; -value row_field = Grammar.Entry.create gram "row_field"; - -value a_list = Grammar.Entry.create gram "a_list"; -value a_opt = Grammar.Entry.create gram "a_opt"; -value a_UIDENT = Grammar.Entry.create gram "a_UIDENT"; -value a_LIDENT = Grammar.Entry.create gram "a_LIDENT"; -value a_INT = Grammar.Entry.create gram "a_INT"; -value a_FLOAT = Grammar.Entry.create gram "a_FLOAT"; -value a_STRING = Grammar.Entry.create gram "a_STRING"; -value a_CHAR = Grammar.Entry.create gram "a_CHAR"; -value a_TILDEIDENT = Grammar.Entry.create gram "a_TILDEIDENT"; -value a_LABEL = Grammar.Entry.create gram "a_LABEL"; -value a_QUESTIONIDENT = Grammar.Entry.create gram "a_QUESTIONIDENT"; -value a_OPTLABEL = Grammar.Entry.create gram "a_OPTLABEL"; - -value o2b = - fun - [ Qast.Option (Some _) -> Qast.Bool True - | Qast.Option None -> Qast.Bool False - | x -> x ] -; - -value mksequence _ = - fun - [ Qast.List [e] -> e - | el -> Qast.Node "ExSeq" [Qast.Loc; el] ] -; - -value mkmatchcase _ p aso w e = - let p = - match aso with - [ Qast.Option (Some p2) -> Qast.Node "PaAli" [Qast.Loc; p; p2] - | Qast.Option None -> p - | _ -> Qast.Node "PaAli" [Qast.Loc; p; aso] ] - in - Qast.Tuple [p; w; e] -; - -value neg_string n = - let len = String.length n in - if len > 0 && n.[0] = '-' then String.sub n 1 (len - 1) - else "-" ^ n -; - -value mkumin _ f arg = - match arg with - [ Qast.Node "ExInt" [Qast.Loc; Qast.Str n] when int_of_string n > 0 -> - let n = neg_string n in - Qast.Node "ExInt" [Qast.Loc; Qast.Str n] - | Qast.Node "ExFlo" [Qast.Loc; Qast.Str n] when float_of_string n > 0.0 -> - let n = neg_string n in - Qast.Node "ExFlo" [Qast.Loc; Qast.Str n] - | _ -> - match f with - [ Qast.Str f -> - let f = "~" ^ f in - Qast.Node "ExApp" - [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str f]; arg] - | _ -> assert False ] ] -; - -value mkuminpat _ f is_int s = - let s = - match s with - [ Qast.Str s -> Qast.Str (neg_string s) - | s -> failwith "bad unary minus" ] - in - match is_int with - [ Qast.Bool True -> Qast.Node "PaInt" [Qast.Loc; s] - | Qast.Bool False -> Qast.Node "PaFlo" [Qast.Loc; s] - | _ -> assert False ] -; - -value mklistexp _ last = - loop True where rec loop top = - fun - [ Qast.List [] -> - match last with - [ Qast.Option (Some e) -> e - | Qast.Option None -> Qast.Node "ExUid" [Qast.Loc; Qast.Str "[]"] - | a -> a ] - | Qast.List [e1 :: el] -> - Qast.Node "ExApp" - [Qast.Loc; - Qast.Node "ExApp" - [Qast.Loc; Qast.Node "ExUid" [Qast.Loc; Qast.Str "::"]; e1]; - loop False (Qast.List el)] - | a -> a ] -; - -value mklistpat _ last = - loop True where rec loop top = - fun - [ Qast.List [] -> - match last with - [ Qast.Option (Some p) -> p - | Qast.Option None -> Qast.Node "PaUid" [Qast.Loc; Qast.Str "[]"] - | a -> a ] - | Qast.List [p1 :: pl] -> - Qast.Node "PaApp" - [Qast.Loc; - Qast.Node "PaApp" - [Qast.Loc; Qast.Node "PaUid" [Qast.Loc; Qast.Str "::"]; p1]; - loop False (Qast.List pl)] - | a -> a ] -; - -value mkexprident loc i j = - loop (Qast.Node "ExUid" [Qast.Loc; i]) j where rec loop m = - fun - [ Qast.Node "ExAcc" [_; x; y] -> - loop (Qast.Node "ExAcc" [Qast.Loc; m; x]) y - | e -> Qast.Node "ExAcc" [Qast.Loc; m; e] ] -; - -value mkassert _ e = - match e with - [ Qast.Node "ExUid" [_; Qast.Str "False"] -> Qast.Node "ExAsf" [Qast.Loc] - | _ -> Qast.Node "ExAsr" [Qast.Loc; e] ] -; - -value append_elem el e = Qast.Apply "@" [el; Qast.List [e]]; - -value not_yet_warned_antiq = ref True; -value warn_antiq loc vers = - if not_yet_warned_antiq.val then do { - not_yet_warned_antiq.val := False; - Pcaml.warning.val loc - (Printf.sprintf - "use of antiquotation syntax deprecated since version %s" vers); - } - else () -; - -value not_yet_warned_variant = ref True; -value warn_variant _ = - if not_yet_warned_variant.val then do { - not_yet_warned_variant.val := False; - Pcaml.warning.val (0, 1) - (Printf.sprintf - "use of syntax of variants types deprecated since version 3.05"); - } - else () -; - -value not_yet_warned_seq = ref True; -value warn_sequence _ = - if not_yet_warned_seq.val then do { - not_yet_warned_seq.val := False; - Pcaml.warning.val (0, 1) - (Printf.sprintf - "use of syntax of sequences deprecated since version 3.01.1"); - } - else () -; - -EXTEND - GLOBAL: sig_item str_item ctyp patt expr module_type module_expr class_type - class_expr class_sig_item class_str_item let_binding type_declaration - ipatt with_constr row_field; - module_expr: - [ [ "functor"; "("; i = a_UIDENT; ":"; t = module_type; ")"; "->"; - me = SELF -> - Qast.Node "MeFun" [Qast.Loc; i; t; me] - | "struct"; st = SLIST0 [ s = str_item; ";" -> s ]; "end" -> - Qast.Node "MeStr" [Qast.Loc; st] ] - | [ me1 = SELF; me2 = SELF -> Qast.Node "MeApp" [Qast.Loc; me1; me2] ] - | [ me1 = SELF; "."; me2 = SELF -> - Qast.Node "MeAcc" [Qast.Loc; me1; me2] ] - | "simple" - [ i = a_UIDENT -> Qast.Node "MeUid" [Qast.Loc; i] - | "("; me = SELF; ":"; mt = module_type; ")" -> - Qast.Node "MeTyc" [Qast.Loc; me; mt] - | "("; me = SELF; ")" -> me ] ] - ; - str_item: - [ "top" - [ "declare"; st = SLIST0 [ s = str_item; ";" -> s ]; "end" -> - Qast.Node "StDcl" [Qast.Loc; st] - | "exception"; ctl = constructor_declaration; b = rebind_exn -> - let (_, c, tl) = - match ctl with - [ Qast.Tuple [xx1; xx2; xx3] -> (xx1, xx2, xx3) - | _ -> match () with [] ] - in - Qast.Node "StExc" [Qast.Loc; c; tl; b] - | "external"; i = a_LIDENT; ":"; t = ctyp; "="; pd = SLIST1 a_STRING -> - Qast.Node "StExt" [Qast.Loc; i; t; pd] - | "include"; me = module_expr -> Qast.Node "StInc" [Qast.Loc; me] - | "module"; i = a_UIDENT; mb = module_binding -> - Qast.Node "StMod" [Qast.Loc; i; mb] - | "module"; "rec"; nmtmes = SLIST1 module_rec_binding SEP "and" -> - Qast.Node "StRecMod" [Qast.Loc; nmtmes] - | "module"; "type"; i = a_UIDENT; "="; mt = module_type -> - Qast.Node "StMty" [Qast.Loc; i; mt] - | "open"; i = mod_ident -> Qast.Node "StOpn" [Qast.Loc; i] - | "type"; tdl = SLIST1 type_declaration SEP "and" -> - Qast.Node "StTyp" [Qast.Loc; tdl] - | "value"; r = SOPT "rec"; l = SLIST1 let_binding SEP "and" -> - Qast.Node "StVal" [Qast.Loc; o2b r; l] - | e = expr -> Qast.Node "StExp" [Qast.Loc; e] ] ] - ; - rebind_exn: - [ [ "="; sl = mod_ident -> sl - | -> Qast.List [] ] ] - ; - module_binding: - [ RIGHTA - [ "("; m = a_UIDENT; ":"; mt = module_type; ")"; mb = SELF -> - Qast.Node "MeFun" [Qast.Loc; m; mt; mb] - | ":"; mt = module_type; "="; me = module_expr -> - Qast.Node "MeTyc" [Qast.Loc; me; mt] - | "="; me = module_expr -> me ] ] - ; - module_rec_binding: - [ [ m = a_UIDENT; ":"; mt = module_type; "="; me = module_expr -> - Qast.Tuple [m; me; mt] ] ] - ; - module_type: - [ [ "functor"; "("; i = a_UIDENT; ":"; t = SELF; ")"; "->"; mt = SELF -> - Qast.Node "MtFun" [Qast.Loc; i; t; mt] ] - | [ mt = SELF; "with"; wcl = SLIST1 with_constr SEP "and" -> - Qast.Node "MtWit" [Qast.Loc; mt; wcl] ] - | [ "sig"; sg = SLIST0 [ s = sig_item; ";" -> s ]; "end" -> - Qast.Node "MtSig" [Qast.Loc; sg] ] - | [ m1 = SELF; m2 = SELF -> Qast.Node "MtApp" [Qast.Loc; m1; m2] ] - | [ m1 = SELF; "."; m2 = SELF -> Qast.Node "MtAcc" [Qast.Loc; m1; m2] ] - | "simple" - [ i = a_UIDENT -> Qast.Node "MtUid" [Qast.Loc; i] - | i = a_LIDENT -> Qast.Node "MtLid" [Qast.Loc; i] - | "'"; i = ident -> Qast.Node "MtQuo" [Qast.Loc; i] - | "("; mt = SELF; ")" -> mt ] ] - ; - sig_item: - [ "top" - [ "declare"; st = SLIST0 [ s = sig_item; ";" -> s ]; "end" -> - Qast.Node "SgDcl" [Qast.Loc; st] - | "exception"; ctl = constructor_declaration -> - let (_, c, tl) = - match ctl with - [ Qast.Tuple [xx1; xx2; xx3] -> (xx1, xx2, xx3) - | _ -> match () with [] ] - in - Qast.Node "SgExc" [Qast.Loc; c; tl] - | "external"; i = a_LIDENT; ":"; t = ctyp; "="; pd = SLIST1 a_STRING -> - Qast.Node "SgExt" [Qast.Loc; i; t; pd] - | "include"; mt = module_type -> Qast.Node "SgInc" [Qast.Loc; mt] - | "module"; i = a_UIDENT; mt = module_declaration -> - Qast.Node "SgMod" [Qast.Loc; i; mt] - | "module"; "type"; i = a_UIDENT; "="; mt = module_type -> - Qast.Node "SgMty" [Qast.Loc; i; mt] - | "module"; "rec"; mds = SLIST1 module_rec_declaration SEP "and" -> - Qast.Node "SgRecMod" [Qast.Loc; mds] - | "open"; i = mod_ident -> Qast.Node "SgOpn" [Qast.Loc; i] - | "type"; tdl = SLIST1 type_declaration SEP "and" -> - Qast.Node "SgTyp" [Qast.Loc; tdl] - | "value"; i = a_LIDENT; ":"; t = ctyp -> - Qast.Node "SgVal" [Qast.Loc; i; t] ] ] - ; - module_declaration: - [ RIGHTA - [ ":"; mt = module_type -> mt - | "("; i = a_UIDENT; ":"; t = module_type; ")"; mt = SELF -> - Qast.Node "MtFun" [Qast.Loc; i; t; mt] ] ] - ; - module_rec_declaration: - [ [ m = a_UIDENT; ":"; mt = module_type -> Qast.Tuple [m; mt] ] ] - ; - with_constr: - [ [ "type"; i = mod_ident; tpl = SLIST0 type_parameter; "="; t = ctyp -> - Qast.Node "WcTyp" [Qast.Loc; i; tpl; t] - | "module"; i = mod_ident; "="; me = module_expr -> - Qast.Node "WcMod" [Qast.Loc; i; me] ] ] - ; - expr: - [ "top" RIGHTA - [ "let"; r = SOPT "rec"; l = SLIST1 let_binding SEP "and"; "in"; - x = SELF -> - Qast.Node "ExLet" [Qast.Loc; o2b r; l; x] - | "let"; "module"; m = a_UIDENT; mb = module_binding; "in"; e = SELF -> - Qast.Node "ExLmd" [Qast.Loc; m; mb; e] - | "fun"; "["; l = SLIST0 match_case SEP "|"; "]" -> - Qast.Node "ExFun" [Qast.Loc; l] - | "fun"; p = ipatt; e = fun_def -> - Qast.Node "ExFun" - [Qast.Loc; Qast.List [Qast.Tuple [p; Qast.Option None; e]]] - | "match"; e = SELF; "with"; "["; l = SLIST0 match_case SEP "|"; "]" -> - Qast.Node "ExMat" [Qast.Loc; e; l] - | "match"; e = SELF; "with"; p1 = ipatt; "->"; e1 = SELF -> - Qast.Node "ExMat" - [Qast.Loc; e; Qast.List [Qast.Tuple [p1; Qast.Option None; e1]]] - | "try"; e = SELF; "with"; "["; l = SLIST0 match_case SEP "|"; "]" -> - Qast.Node "ExTry" [Qast.Loc; e; l] - | "try"; e = SELF; "with"; p1 = ipatt; "->"; e1 = SELF -> - Qast.Node "ExTry" - [Qast.Loc; e; Qast.List [Qast.Tuple [p1; Qast.Option None; e1]]] - | "if"; e1 = SELF; "then"; e2 = SELF; "else"; e3 = SELF -> - Qast.Node "ExIfe" [Qast.Loc; e1; e2; e3] - | "do"; "{"; seq = sequence; "}" -> mksequence Qast.Loc seq - | "for"; i = a_LIDENT; "="; e1 = SELF; df = direction_flag; e2 = SELF; - "do"; "{"; seq = sequence; "}" -> - Qast.Node "ExFor" [Qast.Loc; i; e1; e2; df; seq] - | "while"; e = SELF; "do"; "{"; seq = sequence; "}" -> - Qast.Node "ExWhi" [Qast.Loc; e; seq] ] - | "where" - [ e = SELF; "where"; rf = SOPT "rec"; lb = let_binding -> - Qast.Node "ExLet" [Qast.Loc; o2b rf; Qast.List [lb]; e] ] - | ":=" NONA - [ e1 = SELF; ":="; e2 = SELF; dummy -> - Qast.Node "ExAss" [Qast.Loc; e1; e2] ] - | "||" RIGHTA - [ e1 = SELF; "||"; e2 = SELF -> - Qast.Node "ExApp" - [Qast.Loc; - Qast.Node "ExApp" - [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "||"]; e1]; - e2] ] - | "&&" RIGHTA - [ e1 = SELF; "&&"; e2 = SELF -> - Qast.Node "ExApp" - [Qast.Loc; - Qast.Node "ExApp" - [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "&&"]; e1]; - e2] ] - | "<" LEFTA - [ e1 = SELF; "<"; e2 = SELF -> - Qast.Node "ExApp" - [Qast.Loc; - Qast.Node "ExApp" - [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "<"]; e1]; - e2] - | e1 = SELF; ">"; e2 = SELF -> - Qast.Node "ExApp" - [Qast.Loc; - Qast.Node "ExApp" - [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str ">"]; e1]; - e2] - | e1 = SELF; "<="; e2 = SELF -> - Qast.Node "ExApp" - [Qast.Loc; - Qast.Node "ExApp" - [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "<="]; e1]; - e2] - | e1 = SELF; ">="; e2 = SELF -> - Qast.Node "ExApp" - [Qast.Loc; - Qast.Node "ExApp" - [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str ">="]; e1]; - e2] - | e1 = SELF; "="; e2 = SELF -> - Qast.Node "ExApp" - [Qast.Loc; - Qast.Node "ExApp" - [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "="]; e1]; - e2] - | e1 = SELF; "<>"; e2 = SELF -> - Qast.Node "ExApp" - [Qast.Loc; - Qast.Node "ExApp" - [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "<>"]; e1]; - e2] - | e1 = SELF; "=="; e2 = SELF -> - Qast.Node "ExApp" - [Qast.Loc; - Qast.Node "ExApp" - [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "=="]; e1]; - e2] - | e1 = SELF; "!="; e2 = SELF -> - Qast.Node "ExApp" - [Qast.Loc; - Qast.Node "ExApp" - [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "!="]; e1]; - e2] ] - | "^" RIGHTA - [ e1 = SELF; "^"; e2 = SELF -> - Qast.Node "ExApp" - [Qast.Loc; - Qast.Node "ExApp" - [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "^"]; e1]; - e2] - | e1 = SELF; "@"; e2 = SELF -> - Qast.Node "ExApp" - [Qast.Loc; - Qast.Node "ExApp" - [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "@"]; e1]; - e2] ] - | "+" LEFTA - [ e1 = SELF; "+"; e2 = SELF -> - Qast.Node "ExApp" - [Qast.Loc; - Qast.Node "ExApp" - [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "+"]; e1]; - e2] - | e1 = SELF; "-"; e2 = SELF -> - Qast.Node "ExApp" - [Qast.Loc; - Qast.Node "ExApp" - [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "-"]; e1]; - e2] - | e1 = SELF; "+."; e2 = SELF -> - Qast.Node "ExApp" - [Qast.Loc; - Qast.Node "ExApp" - [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "+."]; e1]; - e2] - | e1 = SELF; "-."; e2 = SELF -> - Qast.Node "ExApp" - [Qast.Loc; - Qast.Node "ExApp" - [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "-."]; e1]; - e2] ] - | "*" LEFTA - [ e1 = SELF; "*"; e2 = SELF -> - Qast.Node "ExApp" - [Qast.Loc; - Qast.Node "ExApp" - [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "*"]; e1]; - e2] - | e1 = SELF; "/"; e2 = SELF -> - Qast.Node "ExApp" - [Qast.Loc; - Qast.Node "ExApp" - [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "/"]; e1]; - e2] - | e1 = SELF; "*."; e2 = SELF -> - Qast.Node "ExApp" - [Qast.Loc; - Qast.Node "ExApp" - [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "*."]; e1]; - e2] - | e1 = SELF; "/."; e2 = SELF -> - Qast.Node "ExApp" - [Qast.Loc; - Qast.Node "ExApp" - [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "/."]; e1]; - e2] - | e1 = SELF; "land"; e2 = SELF -> - Qast.Node "ExApp" - [Qast.Loc; - Qast.Node "ExApp" - [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "land"]; e1]; - e2] - | e1 = SELF; "lor"; e2 = SELF -> - Qast.Node "ExApp" - [Qast.Loc; - Qast.Node "ExApp" - [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "lor"]; e1]; - e2] - | e1 = SELF; "lxor"; e2 = SELF -> - Qast.Node "ExApp" - [Qast.Loc; - Qast.Node "ExApp" - [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "lxor"]; e1]; - e2] - | e1 = SELF; "mod"; e2 = SELF -> - Qast.Node "ExApp" - [Qast.Loc; - Qast.Node "ExApp" - [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "mod"]; e1]; - e2] ] - | "**" RIGHTA - [ e1 = SELF; "**"; e2 = SELF -> - Qast.Node "ExApp" - [Qast.Loc; - Qast.Node "ExApp" - [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "**"]; e1]; - e2] - | e1 = SELF; "asr"; e2 = SELF -> - Qast.Node "ExApp" - [Qast.Loc; - Qast.Node "ExApp" - [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "asr"]; e1]; - e2] - | e1 = SELF; "lsl"; e2 = SELF -> - Qast.Node "ExApp" - [Qast.Loc; - Qast.Node "ExApp" - [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "lsl"]; e1]; - e2] - | e1 = SELF; "lsr"; e2 = SELF -> - Qast.Node "ExApp" - [Qast.Loc; - Qast.Node "ExApp" - [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "lsr"]; e1]; - e2] ] - | "unary minus" NONA - [ "-"; e = SELF -> mkumin Qast.Loc (Qast.Str "-") e - | "-."; e = SELF -> mkumin Qast.Loc (Qast.Str "-.") e ] - | "apply" LEFTA - [ e1 = SELF; e2 = SELF -> Qast.Node "ExApp" [Qast.Loc; e1; e2] - | "assert"; e = SELF -> mkassert Qast.Loc e - | "lazy"; e = SELF -> Qast.Node "ExLaz" [Qast.Loc; e] ] - | "." LEFTA - [ e1 = SELF; "."; "("; e2 = SELF; ")" -> - Qast.Node "ExAre" [Qast.Loc; e1; e2] - | e1 = SELF; "."; "["; e2 = SELF; "]" -> - Qast.Node "ExSte" [Qast.Loc; e1; e2] - | e1 = SELF; "."; e2 = SELF -> Qast.Node "ExAcc" [Qast.Loc; e1; e2] ] - | "~-" NONA - [ "~-"; e = SELF -> - Qast.Node "ExApp" - [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "~-"]; e] - | "~-."; e = SELF -> - Qast.Node "ExApp" - [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "~-."]; e] ] - | "simple" - [ s = a_INT -> Qast.Node "ExInt" [Qast.Loc; s] - | s = a_FLOAT -> Qast.Node "ExFlo" [Qast.Loc; s] - | s = a_STRING -> Qast.Node "ExStr" [Qast.Loc; s] - | s = a_CHAR -> Qast.Node "ExChr" [Qast.Loc; s] - | i = expr_ident -> i - | "["; "]" -> Qast.Node "ExUid" [Qast.Loc; Qast.Str "[]"] - | "["; el = SLIST1 expr SEP ";"; last = cons_expr_opt; "]" -> - mklistexp Qast.Loc last el - | "[|"; el = SLIST0 expr SEP ";"; "|]" -> - Qast.Node "ExArr" [Qast.Loc; el] - | "{"; lel = SLIST1 label_expr SEP ";"; "}" -> - Qast.Node "ExRec" [Qast.Loc; lel; Qast.Option None] - | "{"; "("; e = SELF; ")"; "with"; lel = SLIST1 label_expr SEP ";"; - "}" -> - Qast.Node "ExRec" [Qast.Loc; lel; Qast.Option (Some e)] - | "("; ")" -> Qast.Node "ExUid" [Qast.Loc; Qast.Str "()"] - | "("; e = SELF; ":"; t = ctyp; ")" -> - Qast.Node "ExTyc" [Qast.Loc; e; t] - | "("; e = SELF; ","; el = SLIST1 expr SEP ","; ")" -> - Qast.Node "ExTup" [Qast.Loc; Qast.Cons e el] - | "("; e = SELF; ")" -> e ] ] - ; - cons_expr_opt: - [ [ "::"; e = expr -> Qast.Option (Some e) - | -> Qast.Option None ] ] - ; - dummy: - [ [ -> () ] ] - ; - sequence: - [ [ "let"; rf = SOPT "rec"; l = SLIST1 let_binding SEP "and"; - [ "in" | ";" ]; el = SELF -> - Qast.List - [Qast.Node "ExLet" [Qast.Loc; o2b rf; l; mksequence Qast.Loc el]] - | e = expr; ";"; el = SELF -> Qast.Cons e el - | e = expr; ";" -> Qast.List [e] - | e = expr -> Qast.List [e] ] ] - ; - let_binding: - [ [ p = ipatt; e = fun_binding -> Qast.Tuple [p; e] ] ] - ; - fun_binding: - [ RIGHTA - [ p = ipatt; e = SELF -> - Qast.Node "ExFun" - [Qast.Loc; Qast.List [Qast.Tuple [p; Qast.Option None; e]]] - | "="; e = expr -> e - | ":"; t = ctyp; "="; e = expr -> Qast.Node "ExTyc" [Qast.Loc; e; t] ] ] - ; - match_case: - [ [ p = patt; aso = as_patt_opt; w = when_expr_opt; "->"; e = expr -> - mkmatchcase Qast.Loc p aso w e ] ] - ; - as_patt_opt: - [ [ "as"; p = patt -> Qast.Option (Some p) - | -> Qast.Option None ] ] - ; - when_expr_opt: - [ [ "when"; e = expr -> Qast.Option (Some e) - | -> Qast.Option None ] ] - ; - label_expr: - [ [ i = patt_label_ident; e = fun_binding -> Qast.Tuple [i; e] ] ] - ; - expr_ident: - [ RIGHTA - [ i = a_LIDENT -> Qast.Node "ExLid" [Qast.Loc; i] - | i = a_UIDENT -> Qast.Node "ExUid" [Qast.Loc; i] - | i = a_UIDENT; "."; j = SELF -> mkexprident Qast.Loc i j ] ] - ; - fun_def: - [ RIGHTA - [ p = ipatt; e = SELF -> - Qast.Node "ExFun" - [Qast.Loc; Qast.List [Qast.Tuple [p; Qast.Option None; e]]] - | "->"; e = expr -> e ] ] - ; - patt: - [ LEFTA - [ p1 = SELF; "|"; p2 = SELF -> Qast.Node "PaOrp" [Qast.Loc; p1; p2] ] - | NONA - [ p1 = SELF; ".."; p2 = SELF -> Qast.Node "PaRng" [Qast.Loc; p1; p2] ] - | LEFTA - [ p1 = SELF; p2 = SELF -> Qast.Node "PaApp" [Qast.Loc; p1; p2] ] - | LEFTA - [ p1 = SELF; "."; p2 = SELF -> Qast.Node "PaAcc" [Qast.Loc; p1; p2] ] - | "simple" - [ s = a_LIDENT -> Qast.Node "PaLid" [Qast.Loc; s] - | s = a_UIDENT -> Qast.Node "PaUid" [Qast.Loc; s] - | s = a_INT -> Qast.Node "PaInt" [Qast.Loc; s] - | s = a_FLOAT -> Qast.Node "PaFlo" [Qast.Loc; s] - | s = a_STRING -> Qast.Node "PaStr" [Qast.Loc; s] - | s = a_CHAR -> Qast.Node "PaChr" [Qast.Loc; s] - | "-"; s = a_INT -> mkuminpat Qast.Loc (Qast.Str "-") (Qast.Bool True) s - | "-"; s = a_FLOAT -> - mkuminpat Qast.Loc (Qast.Str "-") (Qast.Bool False) s - | "["; "]" -> Qast.Node "PaUid" [Qast.Loc; Qast.Str "[]"] - | "["; pl = SLIST1 patt SEP ";"; last = cons_patt_opt; "]" -> - mklistpat Qast.Loc last pl - | "[|"; pl = SLIST0 patt SEP ";"; "|]" -> - Qast.Node "PaArr" [Qast.Loc; pl] - | "{"; lpl = SLIST1 label_patt SEP ";"; "}" -> - Qast.Node "PaRec" [Qast.Loc; lpl] - | "("; ")" -> Qast.Node "PaUid" [Qast.Loc; Qast.Str "()"] - | "("; p = SELF; ")" -> p - | "("; p = SELF; ":"; t = ctyp; ")" -> - Qast.Node "PaTyc" [Qast.Loc; p; t] - | "("; p = SELF; "as"; p2 = SELF; ")" -> - Qast.Node "PaAli" [Qast.Loc; p; p2] - | "("; p = SELF; ","; pl = SLIST1 patt SEP ","; ")" -> - Qast.Node "PaTup" [Qast.Loc; Qast.Cons p pl] - | "_" -> Qast.Node "PaAny" [Qast.Loc] ] ] - ; - cons_patt_opt: - [ [ "::"; p = patt -> Qast.Option (Some p) - | -> Qast.Option None ] ] - ; - label_patt: - [ [ i = patt_label_ident; "="; p = patt -> Qast.Tuple [i; p] ] ] - ; - patt_label_ident: - [ LEFTA - [ p1 = SELF; "."; p2 = SELF -> Qast.Node "PaAcc" [Qast.Loc; p1; p2] ] - | "simple" RIGHTA - [ i = a_UIDENT -> Qast.Node "PaUid" [Qast.Loc; i] - | i = a_LIDENT -> Qast.Node "PaLid" [Qast.Loc; i] ] ] - ; - ipatt: - [ [ "{"; lpl = SLIST1 label_ipatt SEP ";"; "}" -> - Qast.Node "PaRec" [Qast.Loc; lpl] - | "("; ")" -> Qast.Node "PaUid" [Qast.Loc; Qast.Str "()"] - | "("; p = SELF; ")" -> p - | "("; p = SELF; ":"; t = ctyp; ")" -> - Qast.Node "PaTyc" [Qast.Loc; p; t] - | "("; p = SELF; "as"; p2 = SELF; ")" -> - Qast.Node "PaAli" [Qast.Loc; p; p2] - | "("; p = SELF; ","; pl = SLIST1 ipatt SEP ","; ")" -> - Qast.Node "PaTup" [Qast.Loc; Qast.Cons p pl] - | s = a_LIDENT -> Qast.Node "PaLid" [Qast.Loc; s] - | "_" -> Qast.Node "PaAny" [Qast.Loc] ] ] - ; - label_ipatt: - [ [ i = patt_label_ident; "="; p = ipatt -> Qast.Tuple [i; p] ] ] - ; - type_declaration: - [ [ n = type_patt; tpl = SLIST0 type_parameter; "="; tk = ctyp; - cl = SLIST0 constrain -> - Qast.Tuple [n; tpl; tk; cl] ] ] - ; - type_patt: - [ [ n = a_LIDENT -> Qast.Tuple [Qast.Loc; n] ] ] - ; - constrain: - [ [ "constraint"; t1 = ctyp; "="; t2 = ctyp -> Qast.Tuple [t1; t2] ] ] - ; - type_parameter: - [ [ "'"; i = ident -> - Qast.Tuple [i; Qast.Tuple [Qast.Bool False; Qast.Bool False]] - | "+"; "'"; i = ident -> - Qast.Tuple [i; Qast.Tuple [Qast.Bool True; Qast.Bool False]] - | "-"; "'"; i = ident -> - Qast.Tuple [i; Qast.Tuple [Qast.Bool False; Qast.Bool True]] ] ] - ; - ctyp: - [ LEFTA - [ t1 = SELF; "=="; t2 = SELF -> Qast.Node "TyMan" [Qast.Loc; t1; t2] ] - | LEFTA - [ t1 = SELF; "as"; t2 = SELF -> Qast.Node "TyAli" [Qast.Loc; t1; t2] ] - | LEFTA - [ "!"; pl = SLIST1 typevar; "."; t = SELF -> - Qast.Node "TyPol" [Qast.Loc; pl; t] ] - | "arrow" RIGHTA - [ t1 = SELF; "->"; t2 = SELF -> Qast.Node "TyArr" [Qast.Loc; t1; t2] ] - | "label" NONA - [ i = a_TILDEIDENT; ":"; t = SELF -> Qast.Node "TyLab" [Qast.Loc; i; t] - | i = a_LABEL; t = SELF -> Qast.Node "TyLab" [Qast.Loc; i; t] - | i = a_QUESTIONIDENT; ":"; t = SELF -> - Qast.Node "TyOlb" [Qast.Loc; i; t] - | i = a_OPTLABEL; t = SELF -> - Qast.Node "TyOlb" [Qast.Loc; i; t] ] - | LEFTA - [ t1 = SELF; t2 = SELF -> Qast.Node "TyApp" [Qast.Loc; t1; t2] ] - | LEFTA - [ t1 = SELF; "."; t2 = SELF -> Qast.Node "TyAcc" [Qast.Loc; t1; t2] ] - | "simple" - [ "'"; i = ident -> Qast.Node "TyQuo" [Qast.Loc; i] - | "_" -> Qast.Node "TyAny" [Qast.Loc] - | i = a_LIDENT -> Qast.Node "TyLid" [Qast.Loc; i] - | i = a_UIDENT -> Qast.Node "TyUid" [Qast.Loc; i] - | "("; t = SELF; "*"; tl = SLIST1 ctyp SEP "*"; ")" -> - Qast.Node "TyTup" [Qast.Loc; Qast.Cons t tl] - | "("; t = SELF; ")" -> t - | "private"; "["; cdl = SLIST0 constructor_declaration SEP "|"; "]" -> - Qast.Node "TySum" [Qast.Loc; Qast.Bool True; cdl] - | "private"; "{"; ldl = SLIST1 label_declaration SEP ";"; "}" -> - Qast.Node "TyRec" [Qast.Loc; Qast.Bool True; ldl] - | "["; cdl = SLIST0 constructor_declaration SEP "|"; "]" -> - Qast.Node "TySum" [Qast.Loc; Qast.Bool False; cdl] - | "{"; ldl = SLIST1 label_declaration SEP ";"; "}" -> - Qast.Node "TyRec" [Qast.Loc; Qast.Bool False; ldl] ] ] - ; - constructor_declaration: - [ [ ci = a_UIDENT; "of"; cal = SLIST1 ctyp SEP "and" -> - Qast.Tuple [Qast.Loc; ci; cal] - | ci = a_UIDENT -> Qast.Tuple [Qast.Loc; ci; Qast.List []] ] ] - ; - label_declaration: - [ [ i = a_LIDENT; ":"; mf = SOPT "mutable"; t = ctyp -> - Qast.Tuple [Qast.Loc; i; o2b mf; t] ] ] - ; - ident: - [ [ i = a_LIDENT -> i - | i = a_UIDENT -> i ] ] - ; - mod_ident: - [ RIGHTA - [ i = a_UIDENT -> Qast.List [i] - | i = a_LIDENT -> Qast.List [i] - | i = a_UIDENT; "."; j = SELF -> Qast.Cons i j ] ] - ; - (* Objects and Classes *) - str_item: - [ [ "class"; cd = SLIST1 class_declaration SEP "and" -> - Qast.Node "StCls" [Qast.Loc; cd] - | "class"; "type"; ctd = SLIST1 class_type_declaration SEP "and" -> - Qast.Node "StClt" [Qast.Loc; ctd] ] ] - ; - sig_item: - [ [ "class"; cd = SLIST1 class_description SEP "and" -> - Qast.Node "SgCls" [Qast.Loc; cd] - | "class"; "type"; ctd = SLIST1 class_type_declaration SEP "and" -> - Qast.Node "SgClt" [Qast.Loc; ctd] ] ] - ; - class_declaration: - [ [ vf = SOPT "virtual"; i = a_LIDENT; ctp = class_type_parameters; - cfb = class_fun_binding -> - Qast.Record - [("ciLoc", Qast.Loc); ("ciVir", o2b vf); ("ciPrm", ctp); - ("ciNam", i); ("ciExp", cfb)] ] ] - ; - class_fun_binding: - [ [ "="; ce = class_expr -> ce - | ":"; ct = class_type; "="; ce = class_expr -> - Qast.Node "CeTyc" [Qast.Loc; ce; ct] - | p = ipatt; cfb = SELF -> Qast.Node "CeFun" [Qast.Loc; p; cfb] ] ] - ; - class_type_parameters: - [ [ -> Qast.Tuple [Qast.Loc; Qast.List []] - | "["; tpl = SLIST1 type_parameter SEP ","; "]" -> - Qast.Tuple [Qast.Loc; tpl] ] ] - ; - class_fun_def: - [ [ p = ipatt; ce = SELF -> Qast.Node "CeFun" [Qast.Loc; p; ce] - | "->"; ce = class_expr -> ce ] ] - ; - class_expr: - [ "top" - [ "fun"; p = ipatt; ce = class_fun_def -> - Qast.Node "CeFun" [Qast.Loc; p; ce] - | "let"; rf = SOPT "rec"; lb = SLIST1 let_binding SEP "and"; "in"; - ce = SELF -> - Qast.Node "CeLet" [Qast.Loc; o2b rf; lb; ce] ] - | "apply" NONA - [ ce = SELF; e = expr LEVEL "label" -> - Qast.Node "CeApp" [Qast.Loc; ce; e] ] - | "simple" - [ ci = class_longident; "["; ctcl = SLIST0 ctyp SEP ","; "]" -> - Qast.Node "CeCon" [Qast.Loc; ci; ctcl] - | ci = class_longident -> Qast.Node "CeCon" [Qast.Loc; ci; Qast.List []] - | "object"; cspo = SOPT class_self_patt; cf = class_structure; "end" -> - Qast.Node "CeStr" [Qast.Loc; cspo; cf] - | "("; ce = SELF; ":"; ct = class_type; ")" -> - Qast.Node "CeTyc" [Qast.Loc; ce; ct] - | "("; ce = SELF; ")" -> ce ] ] - ; - class_structure: - [ [ cf = SLIST0 [ cf = class_str_item; ";" -> cf ] -> cf ] ] - ; - class_self_patt: - [ [ "("; p = patt; ")" -> p - | "("; p = patt; ":"; t = ctyp; ")" -> - Qast.Node "PaTyc" [Qast.Loc; p; t] ] ] - ; - class_str_item: - [ [ "declare"; st = SLIST0 [ s = class_str_item; ";" -> s ]; "end" -> - Qast.Node "CrDcl" [Qast.Loc; st] - | "inherit"; ce = class_expr; pb = SOPT as_lident -> - Qast.Node "CrInh" [Qast.Loc; ce; pb] - | "value"; mf = SOPT "mutable"; lab = label; e = cvalue_binding -> - Qast.Node "CrVal" [Qast.Loc; lab; o2b mf; e] - | "method"; "virtual"; pf = SOPT "private"; l = label; ":"; t = ctyp -> - Qast.Node "CrVir" [Qast.Loc; l; o2b pf; t] - | "method"; pf = SOPT "private"; l = label; topt = SOPT polyt; - e = fun_binding -> - Qast.Node "CrMth" [Qast.Loc; l; o2b pf; e; topt] - | "type"; t1 = ctyp; "="; t2 = ctyp -> - Qast.Node "CrCtr" [Qast.Loc; t1; t2] - | "initializer"; se = expr -> Qast.Node "CrIni" [Qast.Loc; se] ] ] - ; - as_lident: - [ [ "as"; i = a_LIDENT -> i ] ] - ; - polyt: - [ [ ":"; t = ctyp -> t ] ] - ; - cvalue_binding: - [ [ "="; e = expr -> e - | ":"; t = ctyp; "="; e = expr -> Qast.Node "ExTyc" [Qast.Loc; e; t] - | ":"; t = ctyp; ":>"; t2 = ctyp; "="; e = expr -> - Qast.Node "ExCoe" [Qast.Loc; e; Qast.Option (Some t); t2] - | ":>"; t = ctyp; "="; e = expr -> - Qast.Node "ExCoe" [Qast.Loc; e; Qast.Option None; t] ] ] - ; - label: - [ [ i = a_LIDENT -> i ] ] - ; - class_type: - [ [ "["; t = ctyp; "]"; "->"; ct = SELF -> - Qast.Node "CtFun" [Qast.Loc; t; ct] - | id = clty_longident; "["; tl = SLIST1 ctyp SEP ","; "]" -> - Qast.Node "CtCon" [Qast.Loc; id; tl] - | id = clty_longident -> Qast.Node "CtCon" [Qast.Loc; id; Qast.List []] - | "object"; cst = SOPT class_self_type; - csf = SLIST0 [ csf = class_sig_item; ";" -> csf ]; "end" -> - Qast.Node "CtSig" [Qast.Loc; cst; csf] ] ] - ; - class_self_type: - [ [ "("; t = ctyp; ")" -> t ] ] - ; - class_sig_item: - [ [ "declare"; st = SLIST0 [ s = class_sig_item; ";" -> s ]; "end" -> - Qast.Node "CgDcl" [Qast.Loc; st] - | "inherit"; cs = class_type -> Qast.Node "CgInh" [Qast.Loc; cs] - | "value"; mf = SOPT "mutable"; l = label; ":"; t = ctyp -> - Qast.Node "CgVal" [Qast.Loc; l; o2b mf; t] - | "method"; "virtual"; pf = SOPT "private"; l = label; ":"; t = ctyp -> - Qast.Node "CgVir" [Qast.Loc; l; o2b pf; t] - | "method"; pf = SOPT "private"; l = label; ":"; t = ctyp -> - Qast.Node "CgMth" [Qast.Loc; l; o2b pf; t] - | "type"; t1 = ctyp; "="; t2 = ctyp -> - Qast.Node "CgCtr" [Qast.Loc; t1; t2] ] ] - ; - class_description: - [ [ vf = SOPT "virtual"; n = a_LIDENT; ctp = class_type_parameters; ":"; - ct = class_type -> - Qast.Record - [("ciLoc", Qast.Loc); ("ciVir", o2b vf); ("ciPrm", ctp); - ("ciNam", n); ("ciExp", ct)] ] ] - ; - class_type_declaration: - [ [ vf = SOPT "virtual"; n = a_LIDENT; ctp = class_type_parameters; "="; - cs = class_type -> - Qast.Record - [("ciLoc", Qast.Loc); ("ciVir", o2b vf); ("ciPrm", ctp); - ("ciNam", n); ("ciExp", cs)] ] ] - ; - expr: LEVEL "apply" - [ LEFTA - [ "new"; i = class_longident -> Qast.Node "ExNew" [Qast.Loc; i] ] ] - ; - expr: LEVEL "." - [ [ e = SELF; "#"; lab = label -> Qast.Node "ExSnd" [Qast.Loc; e; lab] ] ] - ; - expr: LEVEL "simple" - [ [ "("; e = SELF; ":"; t = ctyp; ":>"; t2 = ctyp; ")" -> - Qast.Node "ExCoe" [Qast.Loc; e; Qast.Option (Some t); t2] - | "("; e = SELF; ":>"; t = ctyp; ")" -> - Qast.Node "ExCoe" [Qast.Loc; e; Qast.Option None; t] - | "{<"; fel = SLIST0 field_expr SEP ";"; ">}" -> - Qast.Node "ExOvr" [Qast.Loc; fel] ] ] - ; - field_expr: - [ [ l = label; "="; e = expr -> Qast.Tuple [l; e] ] ] - ; - ctyp: LEVEL "simple" - [ [ "#"; id = class_longident -> Qast.Node "TyCls" [Qast.Loc; id] - | "<"; ml = SLIST0 field SEP ";"; v = SOPT ".."; ">" -> - Qast.Node "TyObj" [Qast.Loc; ml; o2b v] ] ] - ; - field: - [ [ lab = a_LIDENT; ":"; t = ctyp -> Qast.Tuple [lab; t] ] ] - ; - typevar: - [ [ "'"; i = ident -> i ] ] - ; - clty_longident: - [ [ m = a_UIDENT; "."; l = SELF -> Qast.Cons m l - | i = a_LIDENT -> Qast.List [i] ] ] - ; - class_longident: - [ [ m = a_UIDENT; "."; l = SELF -> Qast.Cons m l - | i = a_LIDENT -> Qast.List [i] ] ] - ; - ctyp: LEVEL "simple" - [ [ "["; "="; rfl = row_field_list; "]" -> - Qast.Node "TyVrn" [Qast.Loc; rfl; Qast.Option None] - | "["; ">"; rfl = row_field_list; "]" -> - Qast.Node "TyVrn" - [Qast.Loc; rfl; Qast.Option (Some (Qast.Option None))] - | "["; "<"; rfl = row_field_list; "]" -> - Qast.Node "TyVrn" - [Qast.Loc; rfl; - Qast.Option (Some (Qast.Option (Some (Qast.List []))))] - | "["; "<"; rfl = row_field_list; ">"; ntl = SLIST1 name_tag; "]" -> - Qast.Node "TyVrn" - [Qast.Loc; rfl; Qast.Option (Some (Qast.Option (Some ntl)))] ] ] - ; - row_field_list: - [ [ rfl = SLIST0 row_field SEP "|" -> rfl ] ] - ; - row_field: - [ [ "`"; i = ident -> Qast.Node "RfTag" [i; Qast.Bool True; Qast.List []] - | "`"; i = ident; "of"; ao = SOPT "&"; l = SLIST1 ctyp SEP "&" -> - Qast.Node "RfTag" [i; o2b ao; l] - | t = ctyp -> Qast.Node "RfInh" [t] ] ] - ; - name_tag: - [ [ "`"; i = ident -> i ] ] - ; - patt: LEVEL "simple" - [ [ "`"; s = ident -> Qast.Node "PaVrn" [Qast.Loc; s] - | "#"; sl = mod_ident -> Qast.Node "PaTyp" [Qast.Loc; sl] - | i = a_TILDEIDENT; ":"; p = SELF -> - Qast.Node "PaLab" [Qast.Loc; i; Qast.Option (Some p)] - | i = a_LABEL; p = SELF -> - Qast.Node "PaLab" [Qast.Loc; i; Qast.Option (Some p)] - | i = a_TILDEIDENT -> Qast.Node "PaLab" [Qast.Loc; i; Qast.Option None] - | i = a_QUESTIONIDENT; ":"; "("; p = patt_tcon; eo = SOPT eq_expr; - ")" -> - Qast.Node "PaOlb" - [Qast.Loc; i; Qast.Option (Some (Qast.Tuple [p; eo]))] - | i = a_OPTLABEL; "("; p = patt_tcon; eo = SOPT eq_expr; ")" -> - Qast.Node "PaOlb" - [Qast.Loc; i; Qast.Option (Some (Qast.Tuple [p; eo]))] - | i = a_QUESTIONIDENT -> - Qast.Node "PaOlb" [Qast.Loc; i; Qast.Option None] - | "?"; "("; p = patt_tcon; eo = SOPT eq_expr; ")" -> - Qast.Node "PaOlb" - [Qast.Loc; Qast.Str ""; - Qast.Option (Some (Qast.Tuple [p; eo]))] ] ] - ; - patt_tcon: - [ [ p = patt; ":"; t = ctyp -> Qast.Node "PaTyc" [Qast.Loc; p; t] - | p = patt -> p ] ] - ; - ipatt: - [ [ i = a_TILDEIDENT; ":"; p = SELF -> - Qast.Node "PaLab" [Qast.Loc; i; Qast.Option (Some p)] - | i = a_LABEL; p = SELF -> - Qast.Node "PaLab" [Qast.Loc; i; Qast.Option (Some p)] - | i = a_TILDEIDENT -> Qast.Node "PaLab" [Qast.Loc; i; Qast.Option None] - | i = a_QUESTIONIDENT; ":"; "("; p = ipatt_tcon; eo = SOPT eq_expr; - ")" -> - Qast.Node "PaOlb" - [Qast.Loc; i; Qast.Option (Some (Qast.Tuple [p; eo]))] - | i = a_OPTLABEL; "("; p = ipatt_tcon; eo = SOPT eq_expr; ")" -> - Qast.Node "PaOlb" - [Qast.Loc; i; Qast.Option (Some (Qast.Tuple [p; eo]))] - | i = a_QUESTIONIDENT -> - Qast.Node "PaOlb" [Qast.Loc; i; Qast.Option None] - | "?"; "("; p = ipatt_tcon; eo = SOPT eq_expr; ")" -> - Qast.Node "PaOlb" - [Qast.Loc; Qast.Str ""; - Qast.Option (Some (Qast.Tuple [p; eo]))] ] ] - ; - ipatt_tcon: - [ [ p = ipatt; ":"; t = ctyp -> Qast.Node "PaTyc" [Qast.Loc; p; t] - | p = ipatt -> p ] ] - ; - eq_expr: - [ [ "="; e = expr -> e ] ] - ; - expr: AFTER "apply" - [ "label" NONA - [ i = a_TILDEIDENT; ":"; e = SELF -> - Qast.Node "ExLab" [Qast.Loc; i; Qast.Option (Some e)] - | i = a_LABEL; e = SELF -> - Qast.Node "ExLab" [Qast.Loc; i; Qast.Option (Some e)] - | i = a_TILDEIDENT -> Qast.Node "ExLab" [Qast.Loc; i; Qast.Option None] - | i = a_QUESTIONIDENT; ":"; e = SELF -> - Qast.Node "ExOlb" [Qast.Loc; i; Qast.Option (Some e)] - | i = a_OPTLABEL; e = SELF -> - Qast.Node "ExOlb" [Qast.Loc; i; Qast.Option (Some e)] - | i = a_QUESTIONIDENT -> - Qast.Node "ExOlb" [Qast.Loc; i; Qast.Option None] ] ] - ; - expr: LEVEL "simple" - [ [ "`"; s = ident -> Qast.Node "ExVrn" [Qast.Loc; s] ] ] - ; - direction_flag: - [ [ "to" -> Qast.Bool True - | "downto" -> Qast.Bool False ] ] - ; - (* Compatibility old syntax of variant types definitions *) - ctyp: LEVEL "simple" - [ [ "[|"; warning_variant; rfl = row_field_list; "|]" -> - Qast.Node "TyVrn" [Qast.Loc; rfl; Qast.Option None] - | "[|"; warning_variant; ">"; rfl = row_field_list; "|]" -> - Qast.Node "TyVrn" - [Qast.Loc; rfl; Qast.Option (Some (Qast.Option None))] - | "[|"; warning_variant; "<"; rfl = row_field_list; "|]" -> - Qast.Node "TyVrn" - [Qast.Loc; rfl; - Qast.Option (Some (Qast.Option (Some (Qast.List []))))] - | "[|"; warning_variant; "<"; rfl = row_field_list; ">"; - ntl = SLIST1 name_tag; "|]" -> - Qast.Node "TyVrn" - [Qast.Loc; rfl; Qast.Option (Some (Qast.Option (Some ntl)))] ] ] - ; - warning_variant: - [ [ -> warn_variant Qast.Loc ] ] - ; - (* Compatibility old syntax of sequences *) - expr: LEVEL "top" - [ [ "do"; seq = SLIST0 [ e = expr; ";" -> e ]; "return"; warning_sequence; - e = SELF -> - Qast.Node "ExSeq" [Qast.Loc; append_elem seq e] - | "for"; i = a_LIDENT; "="; e1 = SELF; df = direction_flag; e2 = SELF; - "do"; seq = SLIST0 [ e = expr; ";" -> e ]; warning_sequence; "done" -> - Qast.Node "ExFor" [Qast.Loc; i; e1; e2; df; seq] - | "while"; e = SELF; "do"; seq = SLIST0 [ e = expr; ";" -> e ]; - warning_sequence; "done" -> - Qast.Node "ExWhi" [Qast.Loc; e; seq] ] ] - ; - warning_sequence: - [ [ -> warn_sequence Qast.Loc ] ] - ; - (* Antiquotations for local entries *) - sequence: - [ [ a = ANTIQUOT "list" -> antiquot "list" loc a ] ] - ; - expr_ident: - [ [ a = ANTIQUOT -> antiquot "" loc a ] ] - ; - patt_label_ident: LEVEL "simple" - [ [ a = ANTIQUOT -> antiquot "" loc a ] ] - ; - when_expr_opt: - [ [ a = ANTIQUOT "when" -> antiquot "when" loc a ] ] - ; - mod_ident: - [ [ a = ANTIQUOT -> antiquot "" loc a ] ] - ; - clty_longident: - [ [ a = a_list -> a ] ] - ; - class_longident: - [ [ a = a_list -> a ] ] - ; - direction_flag: - [ [ a = ANTIQUOT "to" -> antiquot "to" loc a ] ] - ; - (* deprecated since version 3.05; code for compatibility *) - class_expr: LEVEL "simple" - [ [ "object"; x = ANTIQUOT; cf = class_structure; "end" -> - let _ = warn_antiq loc "3.05" in - Qast.Node "CeStr" [Qast.Loc; antiquot "" loc x; cf] - | "object"; x = ANTIQUOT; ";"; - csl = SLIST0 [ cf = class_str_item; ";" -> cf ] ; "end" -> - let _ = warn_antiq loc "3.05" in - Qast.Node "CeStr" - [Qast.Loc; Qast.Option None; - Qast.Cons (antiquot "" loc x) csl] ] ] - ; - class_type: - [ [ "object"; x = ANTIQUOT; - csf = SLIST0 [ csf = class_sig_item; ";" -> csf ]; "end" -> - let _ = warn_antiq loc "3.05" in - Qast.Node "CtSig" [Qast.Loc; antiquot "" loc x; csf] - | "object"; x = ANTIQUOT; ";"; - csf = SLIST0 [ csf = class_sig_item; ";" -> csf ]; "end" -> - let _ = warn_antiq loc "3.05" in - Qast.Node "CtSig" - [Qast.Loc; Qast.Option None; - Qast.Cons (antiquot "" loc x) csf] ] ] - ; - (* deprecated since version 3.06+18; code for compatibility *) - expr: LEVEL "top" - [ [ "let"; r = ANTIQUOT "rec"; l = SLIST1 let_binding SEP "and"; "in"; - x = SELF -> - let _ = warn_antiq loc "3.06+18" in - Qast.Node "ExLet" [Qast.Loc; antiquot "rec" loc r; l; x] ] ] - ; - str_item: LEVEL "top" - [ [ "value"; r = ANTIQUOT "rec"; l = SLIST1 let_binding SEP "and" -> - let _ = warn_antiq loc "3.06+18" in - Qast.Node "StVal" [Qast.Loc; antiquot "rec" loc r; l] ] ] - ; - class_expr: LEVEL "top" - [ [ "let"; r = ANTIQUOT "rec"; lb = SLIST1 let_binding SEP "and"; "in"; - ce = SELF -> - let _ = warn_antiq loc "3.06+18" in - Qast.Node "CeLet" [Qast.Loc; antiquot "rec" loc r; lb; ce] ] ] - ; - class_str_item: - [ [ "inherit"; ce = class_expr; pb = ANTIQUOT "as" -> - let _ = warn_antiq loc "3.06+18" in - Qast.Node "CrInh" [Qast.Loc; ce; antiquot "as" loc pb] - | "value"; mf = ANTIQUOT "mut"; lab = label; e = cvalue_binding -> - let _ = warn_antiq loc "3.06+18" in - Qast.Node "CrVal" [Qast.Loc; lab; antiquot "mut" loc mf; e] ] ] - ; - class_sig_item: - [ [ "value"; mf = ANTIQUOT "mut"; l = label; ":"; t = ctyp -> - let _ = warn_antiq loc "3.06+18" in - Qast.Node "CgVal" [Qast.Loc; l; antiquot "mut" loc mf; t] ] ] - ; -END; - -EXTEND - GLOBAL: str_item sig_item; - str_item: - [ [ "#"; n = a_LIDENT; dp = dir_param -> - Qast.Node "StDir" [Qast.Loc; n; dp] ] ] - ; - sig_item: - [ [ "#"; n = a_LIDENT; dp = dir_param -> - Qast.Node "SgDir" [Qast.Loc; n; dp] ] ] - ; - dir_param: - [ [ a = ANTIQUOT "opt" -> antiquot "opt" loc a - | e = expr -> Qast.Option (Some e) - | -> Qast.Option None ] ] - ; -END; - -(* Antiquotations *) - -EXTEND - module_expr: LEVEL "simple" - [ [ a = ANTIQUOT "mexp" -> antiquot "mexp" loc a - | a = ANTIQUOT -> antiquot "" loc a ] ] - ; - str_item: LEVEL "top" - [ [ a = ANTIQUOT "stri" -> antiquot "stri" loc a - | a = ANTIQUOT -> antiquot "" loc a ] ] - ; - module_type: LEVEL "simple" - [ [ a = ANTIQUOT "mtyp" -> antiquot "mtyp" loc a - | a = ANTIQUOT -> antiquot "" loc a ] ] - ; - sig_item: LEVEL "top" - [ [ a = ANTIQUOT "sigi" -> antiquot "sigi" loc a - | a = ANTIQUOT -> antiquot "" loc a ] ] - ; - expr: LEVEL "simple" - [ [ a = ANTIQUOT "exp" -> antiquot "exp" loc a - | a = ANTIQUOT -> antiquot "" loc a - | a = ANTIQUOT "anti" -> - Qast.Node "ExAnt" [Qast.Loc; antiquot "anti" loc a] - | "("; el = a_list; ")" -> Qast.Node "ExTup" [Qast.Loc; el] ] ] - ; - patt: LEVEL "simple" - [ [ a = ANTIQUOT "pat" -> antiquot "pat" loc a - | a = ANTIQUOT -> antiquot "" loc a - | a = ANTIQUOT "anti" -> - Qast.Node "PaAnt" [Qast.Loc; antiquot "anti" loc a] - | "("; pl = a_list; ")" -> Qast.Node "PaTup" [Qast.Loc; pl] ] ] - ; - ipatt: - [ [ a = ANTIQUOT "pat" -> antiquot "pat" loc a - | a = ANTIQUOT -> antiquot "" loc a - | a = ANTIQUOT "anti" -> - Qast.Node "PaAnt" [Qast.Loc; antiquot "anti" loc a] - | "("; pl = a_list; ")" -> Qast.Node "PaTup" [Qast.Loc; pl] ] ] - ; - ctyp: LEVEL "simple" - [ [ a = ANTIQUOT "typ" -> antiquot "typ" loc a - | a = ANTIQUOT -> antiquot "" loc a - | "("; tl = a_list; ")" -> Qast.Node "TyTup" [Qast.Loc; tl] ] ] - ; - class_expr: LEVEL "simple" - [ [ a = ANTIQUOT -> antiquot "" loc a ] ] - ; - class_str_item: - [ [ a = ANTIQUOT -> antiquot "" loc a ] ] - ; - class_sig_item: - [ [ a = ANTIQUOT -> antiquot "" loc a ] ] - ; - class_type: - [ [ a = ANTIQUOT -> antiquot "" loc a ] ] - ; - expr: LEVEL "simple" - [ [ "{<"; fel = a_list; ">}" -> Qast.Node "ExOvr" [Qast.Loc; fel] ] ] - ; - patt: LEVEL "simple" - [ [ "#"; a = a_list -> Qast.Node "PaTyp" [Qast.Loc; a] ] ] - ; - a_list: - [ [ a = ANTIQUOT "list" -> antiquot "list" loc a ] ] - ; - a_opt: - [ [ a = ANTIQUOT "opt" -> antiquot "opt" loc a ] ] - ; - a_UIDENT: - [ [ a = ANTIQUOT "uid" -> antiquot "uid" loc a - | a = ANTIQUOT -> antiquot "" loc a - | i = UIDENT -> Qast.Str i ] ] - ; - a_LIDENT: - [ [ a = ANTIQUOT "lid" -> antiquot "lid" loc a - | a = ANTIQUOT -> antiquot "" loc a - | i = LIDENT -> Qast.Str i ] ] - ; - a_INT: - [ [ a = ANTIQUOT "int" -> antiquot "int" loc a - | a = ANTIQUOT -> antiquot "" loc a - | s = INT -> Qast.Str s ] ] - ; - a_FLOAT: - [ [ a = ANTIQUOT "flo" -> antiquot "flo" loc a - | a = ANTIQUOT -> antiquot "" loc a - | s = FLOAT -> Qast.Str s ] ] - ; - a_STRING: - [ [ a = ANTIQUOT "str" -> antiquot "str" loc a - | a = ANTIQUOT -> antiquot "" loc a - | s = STRING -> Qast.Str s ] ] - ; - a_CHAR: - [ [ a = ANTIQUOT "chr" -> antiquot "chr" loc a - | a = ANTIQUOT -> antiquot "" loc a - | s = CHAR -> Qast.Str s ] ] - ; - a_TILDEIDENT: - [ [ "~"; a = ANTIQUOT -> antiquot "" loc a - | s = TILDEIDENT -> Qast.Str s ] ] - ; - a_LABEL: - [ [ s = LABEL -> Qast.Str s ] ] - ; - a_QUESTIONIDENT: - [ [ "?"; a = ANTIQUOT -> antiquot "" loc a - | s = QUESTIONIDENT -> Qast.Str s ] ] - ; - a_OPTLABEL: - [ [ s = OPTLABEL -> Qast.Str s ] ] - ; -END; - -value apply_entry e = - let f s = Grammar.Entry.parse e (Stream.of_string s) in - let expr s = Qast.to_expr (f s) in - let patt s = Qast.to_patt (f s) in - Quotation.ExAst (expr, patt) -; - -let sig_item_eoi = Grammar.Entry.create gram "signature item" in -do { - EXTEND - sig_item_eoi: - [ [ x = sig_item; EOI -> x ] ] - ; - END; - Quotation.add "sig_item" (apply_entry sig_item_eoi) -}; - -let str_item_eoi = Grammar.Entry.create gram "structure item" in -do { - EXTEND - str_item_eoi: - [ [ x = str_item; EOI -> x ] ] - ; - END; - Quotation.add "str_item" (apply_entry str_item_eoi) -}; - -let ctyp_eoi = Grammar.Entry.create gram "type" in -do { - EXTEND - ctyp_eoi: - [ [ x = ctyp; EOI -> x ] ] - ; - END; - Quotation.add "ctyp" (apply_entry ctyp_eoi) -}; - -let patt_eoi = Grammar.Entry.create gram "pattern" in -do { - EXTEND - patt_eoi: - [ [ x = patt; EOI -> x ] ] - ; - END; - Quotation.add "patt" (apply_entry patt_eoi) -}; - -let expr_eoi = Grammar.Entry.create gram "expression" in -do { - EXTEND - expr_eoi: - [ [ x = expr; EOI -> x ] ] - ; - END; - Quotation.add "expr" (apply_entry expr_eoi) -}; - -let module_type_eoi = Grammar.Entry.create gram "module type" in -do { - EXTEND - module_type_eoi: - [ [ x = module_type; EOI -> x ] ] - ; - END; - Quotation.add "module_type" (apply_entry module_type_eoi) -}; - -let module_expr_eoi = Grammar.Entry.create gram "module expression" in -do { - EXTEND - module_expr_eoi: - [ [ x = module_expr; EOI -> x ] ] - ; - END; - Quotation.add "module_expr" (apply_entry module_expr_eoi) -}; - -let class_type_eoi = Grammar.Entry.create gram "class_type" in -do { - EXTEND - class_type_eoi: - [ [ x = class_type; EOI -> x ] ] - ; - END; - Quotation.add "class_type" (apply_entry class_type_eoi) -}; - -let class_expr_eoi = Grammar.Entry.create gram "class_expr" in -do { - EXTEND - class_expr_eoi: - [ [ x = class_expr; EOI -> x ] ] - ; - END; - Quotation.add "class_expr" (apply_entry class_expr_eoi) -}; - -let class_sig_item_eoi = Grammar.Entry.create gram "class_sig_item" in -do { - EXTEND - class_sig_item_eoi: - [ [ x = class_sig_item; EOI -> x ] ] - ; - END; - Quotation.add "class_sig_item" (apply_entry class_sig_item_eoi) -}; - -let class_str_item_eoi = Grammar.Entry.create gram "class_str_item" in -do { - EXTEND - class_str_item_eoi: - [ [ x = class_str_item; EOI -> x ] ] - ; - END; - Quotation.add "class_str_item" (apply_entry class_str_item_eoi) -}; - -let with_constr_eoi = Grammar.Entry.create gram "with constr" in -do { - EXTEND - with_constr_eoi: - [ [ x = with_constr; EOI -> x ] ] - ; - END; - Quotation.add "with_constr" (apply_entry with_constr_eoi) -}; - -let row_field_eoi = Grammar.Entry.create gram "row_field" in -do { - EXTEND - row_field_eoi: - [ [ x = row_field; EOI -> x ] ] - ; - END; - Quotation.add "row_field" (apply_entry row_field_eoi) -}; diff --git a/camlp4/ocaml_src/.cvsignore b/camlp4/ocaml_src/.cvsignore deleted file mode 100644 index 2551b02453..0000000000 --- a/camlp4/ocaml_src/.cvsignore +++ /dev/null @@ -1 +0,0 @@ -SAVED diff --git a/camlp4/ocaml_src/camlp4/.cvsignore b/camlp4/ocaml_src/camlp4/.cvsignore deleted file mode 100644 index eb4bb86b20..0000000000 --- a/camlp4/ocaml_src/camlp4/.cvsignore +++ /dev/null @@ -1,3 +0,0 @@ -camlp4 -crc.ml -extract_crc diff --git a/camlp4/ocaml_src/camlp4/.depend b/camlp4/ocaml_src/camlp4/.depend deleted file mode 100644 index bf82065403..0000000000 --- a/camlp4/ocaml_src/camlp4/.depend +++ /dev/null @@ -1,21 +0,0 @@ -ast2pt.cmi: $(OTOP)/parsing/location.cmi $(OTOP)/parsing/longident.cmi mLast.cmi \ - $(OTOP)/parsing/parsetree.cmi -pcaml.cmi: mLast.cmi spretty.cmi -quotation.cmi: mLast.cmi -reloc.cmi: mLast.cmi -argl.cmo: ast2pt.cmi mLast.cmi ../odyl/odyl_main.cmi pcaml.cmi -argl.cmx: ast2pt.cmx mLast.cmi ../odyl/odyl_main.cmx pcaml.cmx -ast2pt.cmo: $(OTOP)/parsing/asttypes.cmi $(OTOP)/parsing/location.cmi \ - $(OTOP)/parsing/longident.cmi mLast.cmi $(OTOP)/parsing/parsetree.cmi \ - ast2pt.cmi -ast2pt.cmx: $(OTOP)/parsing/asttypes.cmi $(OTOP)/parsing/location.cmx \ - $(OTOP)/parsing/longident.cmx mLast.cmi $(OTOP)/parsing/parsetree.cmi \ - ast2pt.cmi -pcaml.cmo: ast2pt.cmi mLast.cmi quotation.cmi reloc.cmi spretty.cmi pcaml.cmi -pcaml.cmx: ast2pt.cmx mLast.cmi quotation.cmx reloc.cmx spretty.cmx pcaml.cmi -quotation.cmo: mLast.cmi quotation.cmi -quotation.cmx: mLast.cmi quotation.cmi -reloc.cmo: mLast.cmi reloc.cmi -reloc.cmx: mLast.cmi reloc.cmi -spretty.cmo: spretty.cmi -spretty.cmx: spretty.cmi diff --git a/camlp4/ocaml_src/camlp4/Makefile b/camlp4/ocaml_src/camlp4/Makefile deleted file mode 100644 index 0e5d05762d..0000000000 --- a/camlp4/ocaml_src/camlp4/Makefile +++ /dev/null @@ -1,71 +0,0 @@ -# This file has been generated by program: do not edit! - -include ../../config/Makefile - -SHELL=/bin/sh - -INCLUDES=-I ../odyl -I ../../boot -I $(OTOP)/utils -I $(OTOP)/parsing -I $(OTOP)/otherlibs/dynlink -OCAMLCFLAGS= $(INCLUDES) -warn-error A $(INCLUDES) -LINKFLAGS=$(INCLUDES) -INTERFACES=-I $(OLIBDIR) Arg Array ArrayLabels Buffer Callback CamlinternalOO Char Complex Digest Filename Format Gc Genlex Hashtbl Int32 Int64 Lazy Lexing List ListLabels Map Marshal MoreLabels Nativeint Obj Oo Parsing Pervasives Printexc Printf Queue Random Scanf Set Sort Stack StdLabels Stream String StringLabels Sys Weak -I ../../boot Extfold Extfun Fstream Gramext Grammar Plexer Stdpp Token -I $(OTOP)/utils Config Warnings -I $(OTOP)/parsing Asttypes Location Longident Parsetree -I . Ast2pt MLast Pcaml Quotation Spretty -CAMLP4_INTF=$(OTOP)/utils/config.cmi $(OTOP)/utils/warnings.cmi $(OTOP)/parsing/asttypes.cmi $(OTOP)/parsing/location.cmi $(OTOP)/parsing/longident.cmi $(OTOP)/parsing/parsetree.cmi ast2pt.cmi mLast.cmi pcaml.cmi spretty.cmi quotation.cmi -CAMLP4_OBJS=../../boot/stdpp.cmo ../../boot/token.cmo ../../boot/plexer.cmo ../../boot/gramext.cmo ../../boot/grammar.cmo ../../boot/extfold.cmo ../../boot/extfun.cmo ../../boot/fstream.cmo $(OTOP)/utils/config.cmo quotation.cmo ast2pt.cmo spretty.cmo reloc.cmo pcaml.cmo argl.cmo -CAMLP4_XOBJS=../lib/stdpp.cmx ../lib/token.cmx ../lib/plexer.cmx ../lib/gramext.cmx ../lib/grammar.cmx ../lib/extfold.cmx ../lib/extfun.cmx ../lib/fstream.cmx $(OTOP)/utils/config.cmx quotation.cmx ast2pt.cmx spretty.cmx reloc.cmx pcaml.cmx argl.cmx -OBJS=../odyl/odyl.cma camlp4.cma -CAMLP4M= - -CAMLP4=camlp4$(EXE) -CAMLP4OPT=phony - -all: $(CAMLP4) -opt: $(OBJS:.cma=.cmxa) -optp4: $(CAMLP4OPT) - -$(CAMLP4): $(OBJS) ../odyl/odyl.cmo - $(OCAMLC) $(OBJS) $(CAMLP4M) ../odyl/odyl.cmo -linkall -o $(CAMLP4) - -$(CAMLP4OPT): $(OBJS:.cma=.cmxa) ../odyl/odyl.cmx - $(OCAMLOPT) $(OBJS:.cma=.cmxa) $(CAMLP4M) ../odyl/odyl.cmx -linkall -o $(CAMLP4OPT) - -$(OTOP)/utils/config.cmx: $(OTOP)/utils/config.ml - $(OCAMLOPT) -c $(OTOP)/utils/config.ml - -camlp4.cma: $(CAMLP4_OBJS) - $(OCAMLC) $(LINKFLAGS) $(CAMLP4_OBJS) -a -o camlp4.cma - -camlp4.cmxa: $(CAMLP4_XOBJS) - $(OCAMLOPT) $(LINKFLAGS) $(CAMLP4_XOBJS) -a -o camlp4.cmxa - -clean:: - rm -f *.cm* *.pp[io] *.$(O) *.$(A) *.bak .*.bak *.out *.opt - rm -f $(CAMLP4) - -depend: - cp .depend .depend.bak - > .depend - @for i in *.mli *.ml; do \ - ../tools/apply.sh pr_depend.cmo -- $(INCLUDES) $$i | \ - sed -e 's| \.\./\.\.| $$(OTOP)|g' >> .depend; \ - done - -promote: - cp $(CAMLP4) ../../boot/. - -compare: - @for j in $(CAMLP4); do \ - if cmp $$j ../../boot/$$j; then :; else exit 1; fi; \ - done - -install: - -$(MKDIR) "$(BINDIR)" - -$(MKDIR) "$(LIBDIR)/camlp4" - cp $(CAMLP4) "$(BINDIR)/." - cp mLast.mli quotation.mli ast2pt.mli pcaml.mli spretty.mli "$(LIBDIR)/camlp4/." - cp mLast.cmi quotation.cmi ast2pt.cmi pcaml.cmi spretty.cmi "$(LIBDIR)/camlp4/." - cp camlp4.cma $(LIBDIR)/camlp4/. - if [ -f camlp4.cmxa ]; \ - then cp camlp4.cmxa camlp4.$(A) $(LIBDIR)/camlp4/.; \ - else : ; \ - fi - -include .depend diff --git a/camlp4/ocaml_src/camlp4/Makefile.Mac b/camlp4/ocaml_src/camlp4/Makefile.Mac deleted file mode 100644 index b7561d8cb5..0000000000 --- a/camlp4/ocaml_src/camlp4/Makefile.Mac +++ /dev/null @@ -1,69 +0,0 @@ -####################################################################### -# # -# Camlp4 # -# # -# Damien Doligez, projet Para, INRIA Rocquencourt # -# # -# Copyright 1999 Institut National de Recherche en Informatique et # -# en Automatique. Distributed only by permission. # -# # -####################################################################### - -# This file has been generated by program: do not edit! - -INCLUDES = -I ::odyl: -I :::boot: -I "{OTOP}utils:" -I "{OTOP}parsing:" ¶ - -I "{OTOP}otherlibs:dynlink:" -OCAMLCFLAGS = {INCLUDES} -LINKFLAGS = {INCLUDES} -INTERFACES = -I "{OLIBDIR}" Arg Array ArrayLabels Buffer Callback CamlinternalOO Char Complex Digest Filename Format Gc Genlex Hashtbl Int32 Int64 Lazy Lexing List ListLabels Map Marshal MoreLabels Nativeint Obj Oo Parsing Pervasives Printexc Printf Queue Random Scanf Set Sort Stack StdLabels Stream String StringLabels Sys Weak ¶ - -I :::boot: Extfold Extfun Fstream ¶ - Gramext Grammar Plexer ¶ - Stdpp Token -I "{OTOP}utils:" Config Warnings ¶ - -I "{OTOP}parsing:" Asttypes Location Longident Parsetree ¶ - -I : Ast2pt MLast Pcaml Quotation Spretty -CAMLP4_INTF = "{OTOP}utils:config.cmi" "{OTOP}utils:warnings.cmi" ¶ - "{OTOP}parsing:asttypes.cmi" "{OTOP}parsing:location.cmi" ¶ - "{OTOP}parsing:longident.cmi" "{OTOP}parsing:parsetree.cmi" ¶ - ast2pt.cmo mLast.cmi pcaml.cmi spretty.cmi ¶ - quotation.cmi -CAMLP4_OBJS = :::boot:stdpp.cmo :::boot:token.cmo :::boot:plexer.cmo ¶ - :::boot:gramext.cmo :::boot:grammar.cmo :::boot:extfold.cmo :::boot:extfun.cmo ¶ - :::boot:fstream.cmo "{OTOP}utils:config.cmo" ¶ - quotation.cmo ast2pt.cmo spretty.cmo reloc.cmo pcaml.cmo ¶ - argl.cmo crc.cmo -OBJS = ::odyl:odyl.cma camlp4.cma -XOBJS = camlp4.cmxa -CAMLP4M = - -CAMLP4 = camlp4 - -all Ä {CAMLP4} - -{CAMLP4} Ä {OBJS} ::odyl:odyl.cmo - {OCAMLC} {OBJS} {CAMLP4M} ::odyl:odyl.cmo -linkall -o {CAMLP4} - -camlp4.cma Ä {CAMLP4_OBJS} - {OCAMLC} {LINKFLAGS} {CAMLP4_OBJS} -a -o camlp4.cma - -clean ÄÄ - delete -i {CAMLP4} - -{dependrule} - -promote Ä - duplicate -y {CAMLP4} :::boot: - -compare Ä - for i in {CAMLP4} - equal -s {i} :::boot:{i} || exit 1 - end - -install Ä - (newfolder "{BINDIR}" || set status 0) ³ dev:null - duplicate -y {CAMLP4} "{BINDIR}" - duplicate -y mLast.mli quotation.mli pcaml.mli spretty.mli "{P4LIBDIR}" - duplicate -y mLast.cmi quotation.cmi ast2pt.cmi pcaml.cmi spretty.cmi ¶ - "{P4LIBDIR}" - duplicate -y camlp4.cma "{P4LIBDIR}" - -{defrules} diff --git a/camlp4/ocaml_src/camlp4/Makefile.Mac.depend b/camlp4/ocaml_src/camlp4/Makefile.Mac.depend deleted file mode 100644 index 3665195f77..0000000000 --- a/camlp4/ocaml_src/camlp4/Makefile.Mac.depend +++ /dev/null @@ -1,15 +0,0 @@ -pcaml.cmiÄ mLast.cmi spretty.cmi -quotation.cmiÄ mLast.cmi -reloc.cmiÄ mLast.cmi -argl.cmoÄ ast2pt.cmo mLast.cmi pcaml.cmi -argl.cmxÄ ast2pt.cmx mLast.cmi pcaml.cmx -ast2pt.cmoÄ mLast.cmi -ast2pt.cmxÄ mLast.cmi -pcaml.cmoÄ ast2pt.cmo mLast.cmi quotation.cmi reloc.cmi spretty.cmi pcaml.cmi -pcaml.cmxÄ ast2pt.cmx mLast.cmi quotation.cmx reloc.cmx spretty.cmx pcaml.cmi -quotation.cmoÄ mLast.cmi quotation.cmi -quotation.cmxÄ mLast.cmi quotation.cmi -reloc.cmoÄ mLast.cmi reloc.cmi -reloc.cmxÄ mLast.cmi reloc.cmi -spretty.cmoÄ spretty.cmi -spretty.cmxÄ spretty.cmi diff --git a/camlp4/ocaml_src/camlp4/argl.ml b/camlp4/ocaml_src/camlp4/argl.ml deleted file mode 100644 index 0f6ac98ced..0000000000 --- a/camlp4/ocaml_src/camlp4/argl.ml +++ /dev/null @@ -1,406 +0,0 @@ -(* camlp4r q_MLast.cmo *) -(* This file has been generated by program: do not edit! *) - -open Printf;; - -let rec action_arg s sl = - function - Arg.Unit f -> if s = "" then begin f (); Some sl end else None - | Arg.Bool f -> - if s = "" then - match sl with - s :: sl -> - begin try f (bool_of_string s); Some sl with - Invalid_argument "bool_of_string" -> None - end - | [] -> None - else - begin try f (bool_of_string s); Some sl with - Invalid_argument "bool_of_string" -> None - end - | Arg.Set r -> if s = "" then begin r := true; Some sl end else None - | Arg.Clear r -> if s = "" then begin r := false; Some sl end else None - | Arg.Rest f -> List.iter f (s :: sl); Some [] - | Arg.String f -> - if s = "" then - match sl with - s :: sl -> f s; Some sl - | [] -> None - else begin f s; Some sl end - | Arg.Set_string r -> - if s = "" then - match sl with - s :: sl -> r := s; Some sl - | [] -> None - else begin r := s; Some sl end - | Arg.Int f -> - if s = "" then - match sl with - s :: sl -> - begin try f (int_of_string s); Some sl with - Failure "int_of_string" -> None - end - | [] -> None - else - begin try f (int_of_string s); Some sl with - Failure "int_of_string" -> None - end - | Arg.Set_int r -> - if s = "" then - match sl with - s :: sl -> - begin try r := int_of_string s; Some sl with - Failure "int_of_string" -> None - end - | [] -> None - else - begin try r := int_of_string s; Some sl with - Failure "int_of_string" -> None - end - | Arg.Float f -> - if s = "" then - match sl with - s :: sl -> f (float_of_string s); Some sl - | [] -> None - else begin f (float_of_string s); Some sl end - | Arg.Set_float r -> - if s = "" then - match sl with - s :: sl -> r := float_of_string s; Some sl - | [] -> None - else begin r := float_of_string s; Some sl end - | Arg.Tuple specs -> - let rec action_args s sl = - function - [] -> 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 -> f s; Some sl - | _ -> None -;; - -let common_start s1 s2 = - let 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 - in - loop 0 -;; - -let rec parse_arg s sl = - function - (name, action, _) :: spec_list -> - 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 _ -> parse_arg s sl spec_list - else parse_arg s sl spec_list - | [] -> None -;; - -let rec parse_aux spec_list anon_fun = - function - [] -> [] - | s :: sl -> - if String.length s > 1 && s.[0] = '-' then - match parse_arg s sl spec_list with - Some sl -> parse_aux spec_list anon_fun sl - | None -> s :: parse_aux spec_list anon_fun sl - else begin (anon_fun s : unit); parse_aux spec_list anon_fun sl end -;; - -let loc_fmt = - match Sys.os_type with - "MacOS" -> - format_of_string "File \"%s\"; line %d; characters %d to %d\n### " - | _ -> format_of_string "File \"%s\", line %d, characters %d-%d:\n" -;; - -let print_location loc = - if !(Pcaml.input_file) <> "-" then - let (fname, line, bp, ep) = Stdpp.line_of_loc !(Pcaml.input_file) loc in - eprintf loc_fmt !(Pcaml.input_file) line bp ep - else eprintf "At location %d-%d\n" (fst loc) (snd loc) -;; - -let print_warning loc s = print_location loc; eprintf "%s\n" s;; - -let rec parse_file pa getdir useast = - let name = !(Pcaml.input_file) in - Pcaml.warning := print_warning; - let ic = if name = "-" then stdin else open_in_bin name in - let cs = Stream.of_channel ic in - let clear () = if name = "-" then () else close_in ic in - let phr = - try - let rec loop () = - let (pl, stopped_at_directive) = pa cs in - if stopped_at_directive then - let pl = - let rpl = List.rev pl in - match getdir rpl with - Some x -> - begin match x with - loc, "load", Some (MLast.ExStr (_, s)) -> - Odyl_main.loadfile s; pl - | loc, "directory", Some (MLast.ExStr (_, s)) -> - Odyl_main.directory s; pl - | loc, "use", Some (MLast.ExStr (_, s)) -> - List.rev_append rpl - [useast loc s (use_file pa getdir useast s), loc] - | loc, _, _ -> - Stdpp.raise_with_loc loc (Stream.Error "bad directive") - end - | None -> pl - in - pl @ loop () - else pl - in - loop () - with - x -> clear (); raise x - in - clear (); phr -and use_file pa getdir useast s = - let clear = - let v_input_file = !(Pcaml.input_file) in - fun () -> Pcaml.input_file := v_input_file - in - Pcaml.input_file := s; - try let r = parse_file pa getdir useast in clear (); r with - e -> clear (); raise e -;; - -let process pa pr getdir useast = pr (parse_file pa getdir useast);; - - -let gind = - function - (MLast.SgDir (loc, n, dp), _) :: _ -> Some (loc, n, dp) - | _ -> None -;; - -let gimd = - function - (MLast.StDir (loc, n, dp), _) :: _ -> Some (loc, n, dp) - | _ -> None -;; - -let usesig loc fname ast = MLast.SgUse (loc, fname, ast);; -let usestr loc fname ast = MLast.StUse (loc, fname, ast);; - -let process_intf () = - process !(Pcaml.parse_interf) !(Pcaml.print_interf) gind usesig -;; -let process_impl () = - process !(Pcaml.parse_implem) !(Pcaml.print_implem) gimd usestr -;; - -type file_kind = - Intf - | Impl -;; -let file_kind = ref Intf;; -let file_kind_of_name name = - if Filename.check_suffix name ".mli" then Intf - else if Filename.check_suffix name ".ml" then Impl - else raise (Arg.Bad ("don't know what to do with " ^ name)) -;; - -let print_version () = - eprintf "Camlp4 version %s\n" Pcaml.version; flush stderr; exit 0 -;; - -let align_doc key s = - let s = - let 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 - loop 0 - in - let (p, s) = - if String.length s > 0 then - if s.[0] = '<' then - let 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 - let 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) - in - loop (i + 1) - in - loop 0 - else "", s - else "", "" - in - let tab = - String.make (max 1 (13 - String.length key - String.length p)) ' ' - in - p ^ tab ^ s -;; - -let make_symlist l = - match l with - [] -> "" - | h :: t -> List.fold_left (fun x y -> x ^ "|" ^ y) ("{" ^ h) t ^ "}" -;; - -let 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 -;; - -let make_symlist l = - match l with - [] -> "" - | h :: t -> List.fold_left (fun x y -> x ^ "|" ^ y) ("{" ^ h) t ^ "}" -;; - -let 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 -;; - -let usage ini_sl ext_sl = - eprintf "\ -Usage: camlp4 [load-options] [--] [other-options] -Load options: - -I directory Add directory in search patch for object files. - -where Print camlp4 library directory and exit. - -nolib No automatic search for object files in library directory. - Load this file in Camlp4 core. -Other options: - Parse this file.\n"; - print_usage_list ini_sl; - begin - let rec loop = - function - (y, _, _) :: _ when y = "-help" -> () - | _ :: sl -> loop sl - | [] -> eprintf " -help Display this list of options.\n" - in - loop (ini_sl @ ext_sl) - end; - if ext_sl <> [] then - begin - eprintf "Options added by loaded object files:\n"; - print_usage_list ext_sl - end -;; - -let warn_noassert () = - eprintf "\ -camlp4 warning: option -noassert is obsolete -You should give the -noassert option to the ocaml compiler instead. -" -;; - -let initial_spec_list = - ["-intf", Arg.String (fun x -> file_kind := Intf; Pcaml.input_file := x), - " Parse as an interface, whatever its extension."; - "-impl", Arg.String (fun x -> file_kind := Impl; Pcaml.input_file := x), - " Parse as an implementation, whatever its extension."; - "-unsafe", Arg.Set Ast2pt.fast, - "Generate unsafe accesses to array and strings."; - "-noassert", Arg.Unit warn_noassert, "Obsolete, do not use this option."; - "-verbose", Arg.Set Grammar.error_verbose, - "More verbose in parsing errors."; - "-loc", Arg.String (fun x -> Stdpp.loc_name := x), - " Name of the location variable (default: " ^ !(Stdpp.loc_name) ^ - ")"; - "-QD", Arg.String (fun x -> Pcaml.quotation_dump_file := Some x), - " Dump quotation expander result in case of syntax error."; - "-o", Arg.String (fun x -> Pcaml.output_file := Some x), - " Output on instead of standard output."; - "-v", Arg.Unit print_version, "Print Camlp4 version and exit."] -;; - -let anon_fun x = Pcaml.input_file := x; file_kind := file_kind_of_name x;; - -let parse spec_list anon_fun remaining_args = - let spec_list = - Sort.list (fun (k1, _, _) (k2, _, _) -> k1 >= k2) spec_list - in - try parse_aux spec_list anon_fun remaining_args with - Arg.Bad s -> - eprintf "Error: %s\n" s; - eprintf "Use option -help for usage\n"; - flush stderr; - exit 2 -;; - -let remaining_args = - let rec loop l i = - if i == Array.length Sys.argv then l else loop (Sys.argv.(i) :: l) (i + 1) - in - List.rev (loop [] (!(Arg.current) + 1)) -;; - -let report_error = - function - Odyl_main.Error (fname, msg) -> - Format.print_string "Error while loading \""; - Format.print_string fname; - Format.print_string "\": "; - Format.print_string msg - | exc -> Pcaml.report_error exc -;; - -let go () = - let ext_spec_list = Pcaml.arg_spec_list () in - let arg_spec_list = initial_spec_list @ ext_spec_list in - begin match parse arg_spec_list anon_fun remaining_args with - [] -> () - | "-help" :: sl -> usage initial_spec_list ext_spec_list; exit 0 - | s :: sl -> - eprintf "%s: unknown or misused option\n" s; - eprintf "Use option -help for usage\n"; - exit 2 - end; - try - if !(Pcaml.input_file) <> "" then - match !file_kind with - Intf -> process_intf () - | Impl -> process_impl () - with - exc -> - Format.set_formatter_out_channel stderr; - Format.open_vbox 0; - let exc = - match exc with - Stdpp.Exc_located ((bp, ep), exc) -> print_location (bp, ep); exc - | _ -> exc - in - report_error exc; Format.close_box (); Format.print_newline (); exit 2 -;; - -Odyl_main.name := "camlp4";; -Odyl_main.go := go;; diff --git a/camlp4/ocaml_src/camlp4/ast2pt.ml b/camlp4/ocaml_src/camlp4/ast2pt.ml deleted file mode 100644 index b243109b73..0000000000 --- a/camlp4/ocaml_src/camlp4/ast2pt.ml +++ /dev/null @@ -1,880 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* This file has been generated by program: do not edit! *) - -open Stdpp;; -open MLast;; -open Parsetree;; -open Longident;; -open Asttypes;; - -let fast = ref false;; -let no_constructors_arity = ref false;; - -let get_tag x = - if Obj.is_block (Obj.repr x) then Obj.tag (Obj.repr x) else Obj.magic x -;; - -let error loc str = raise_with_loc loc (Failure str);; - -let char_of_char_token loc s = - try Token.eval_char s with - Failure _ as exn -> raise_with_loc loc exn -;; - -let string_of_string_token loc s = - try Token.eval_string loc s with - Failure _ as exn -> raise_with_loc loc exn -;; - -let glob_fname = ref "";; - -let mkloc (bp, ep) = - let loc_at n = - {Lexing.pos_fname = !glob_fname; Lexing.pos_lnum = 1; Lexing.pos_bol = 0; - Lexing.pos_cnum = n} - in - {Location.loc_start = loc_at bp; Location.loc_end = loc_at ep; - Location.loc_ghost = false} -;; - -let mkghloc (bp, ep) = - let loc_at n = - {Lexing.pos_fname = ""; Lexing.pos_lnum = 1; Lexing.pos_bol = 0; - Lexing.pos_cnum = n} - in - {Location.loc_start = loc_at bp; Location.loc_end = loc_at ep; - Location.loc_ghost = true} -;; - -let mktyp loc d = {ptyp_desc = d; ptyp_loc = mkloc loc};; -let mkpat loc d = {ppat_desc = d; ppat_loc = mkloc loc};; -let mkghpat loc d = {ppat_desc = d; ppat_loc = mkghloc loc};; -let mkexp loc d = {pexp_desc = d; pexp_loc = mkloc loc};; -let mkmty loc d = {pmty_desc = d; pmty_loc = mkloc loc};; -let mksig loc d = {psig_desc = d; psig_loc = mkloc loc};; -let mkmod loc d = {pmod_desc = d; pmod_loc = mkloc loc};; -let mkstr loc d = {pstr_desc = d; pstr_loc = mkloc loc};; -let mkfield loc d = {pfield_desc = d; pfield_loc = mkloc loc};; -let mkcty loc d = {pcty_desc = d; pcty_loc = mkloc loc};; -let mkpcl loc d = {pcl_desc = d; pcl_loc = mkloc loc};; -let mkpolytype t = - match t with - TyPol (_, _, _) -> t - | _ -> TyPol (MLast.loc_of_ctyp t, [], t) -;; - -let lident s = Lident s;; -let ldot l s = Ldot (l, s);; - -let conv_con = - let t = Hashtbl.create 73 in - List.iter (fun (s, s') -> Hashtbl.add t s s') - ["True", "true"; "False", "false"; " True", "True"; " False", "False"]; - fun s -> - try Hashtbl.find t s with - Not_found -> s -;; - -let conv_lab = - let t = Hashtbl.create 73 in - List.iter (fun (s, s') -> Hashtbl.add t s s') ["val", "contents"]; - fun s -> - try Hashtbl.find t s with - Not_found -> s -;; - -let array_function str name = - ldot (lident str) (if !fast then "unsafe_" ^ name else name) -;; - -let mkrf = - function - true -> Recursive - | false -> Nonrecursive -;; - -let mkli s = - let rec loop f = - function - i :: il -> loop (fun s -> ldot (f i) s) il - | [] -> f s - in - loop (fun s -> lident s) -;; - -let long_id_of_string_list loc sl = - match List.rev sl with - [] -> error loc "bad ast" - | s :: sl -> mkli s (List.rev sl) -;; - -let rec ctyp_fa al = - function - TyApp (_, f, a) -> ctyp_fa (a :: al) f - | f -> f, al -;; - -let rec ctyp_long_id = - function - TyAcc (_, m, TyLid (_, s)) -> - let (is_cls, li) = ctyp_long_id m in is_cls, ldot li s - | TyAcc (_, m, TyUid (_, s)) -> - let (is_cls, li) = ctyp_long_id m in is_cls, ldot li s - | TyApp (_, m1, m2) -> - let (is_cls, li1) = ctyp_long_id m1 in - let (_, li2) = ctyp_long_id m2 in is_cls, Lapply (li1, li2) - | TyUid (_, s) -> false, lident s - | TyLid (_, s) -> false, lident s - | TyCls (loc, sl) -> true, long_id_of_string_list loc sl - | t -> error (loc_of_ctyp t) "incorrect type" -;; - -let rec ctyp = - function - TyAcc (loc, _, _) as f -> - let (is_cls, li) = ctyp_long_id f in - if is_cls then mktyp loc (Ptyp_class (li, [], [])) - else mktyp loc (Ptyp_constr (li, [])) - | TyAli (loc, t1, t2) -> - let (t, i) = - match t1, t2 with - t, TyQuo (_, s) -> t, s - | TyQuo (_, s), t -> t, s - | _ -> error loc "incorrect alias type" - in - mktyp loc (Ptyp_alias (ctyp t, i)) - | TyAny loc -> mktyp loc Ptyp_any - | TyApp (loc, _, _) as f -> - let (f, al) = ctyp_fa [] f in - let (is_cls, li) = ctyp_long_id f in - if is_cls then mktyp loc (Ptyp_class (li, List.map ctyp al, [])) - else mktyp loc (Ptyp_constr (li, List.map ctyp al)) - | TyArr (loc, TyLab (loc1, lab, t1), t2) -> - mktyp loc (Ptyp_arrow (lab, ctyp t1, ctyp t2)) - | TyArr (loc, TyOlb (loc1, lab, t1), t2) -> - let t1 = TyApp (loc1, TyLid (loc1, "option"), t1) in - mktyp loc (Ptyp_arrow (("?" ^ lab), ctyp t1, ctyp t2)) - | TyArr (loc, t1, t2) -> mktyp loc (Ptyp_arrow ("", ctyp t1, ctyp t2)) - | TyObj (loc, fl, v) -> mktyp loc (Ptyp_object (meth_list loc fl v)) - | TyCls (loc, id) -> - mktyp loc (Ptyp_class (long_id_of_string_list loc id, [], [])) - | TyLab (loc, _, _) -> error loc "labelled type not allowed here" - | TyLid (loc, s) -> mktyp loc (Ptyp_constr (lident s, [])) - | TyMan (loc, _, _) -> error loc "manifest type not allowed here" - | TyOlb (loc, lab, _) -> error loc "labelled type not allowed here" - | TyPol (loc, pl, t) -> mktyp loc (Ptyp_poly (pl, ctyp t)) - | TyQuo (loc, s) -> mktyp loc (Ptyp_var s) - | TyRec (loc, _, _) -> error loc "record type not allowed here" - | TySum (loc, _, _) -> error loc "sum type not allowed here" - | TyTup (loc, tl) -> mktyp loc (Ptyp_tuple (List.map ctyp tl)) - | TyUid (loc, s) -> mktyp loc (Ptyp_constr (lident s, [])) - | TyVrn (loc, catl, ool) -> - let catl = - List.map - (function - RfTag (c, a, t) -> Rtag (c, a, List.map ctyp t) - | RfInh t -> Rinherit (ctyp t)) - catl - in - let (clos, sl) = - match ool with - None -> true, None - | Some None -> false, None - | Some (Some sl) -> true, Some sl - in - mktyp loc (Ptyp_variant (catl, clos, sl)) -and meth_list loc fl v = - match fl with - [] -> if v then [mkfield loc Pfield_var] else [] - | (lab, t) :: fl -> - mkfield loc (Pfield (lab, ctyp (mkpolytype t))) :: meth_list loc fl v -;; - -let mktype loc tl cl tk tm = - let (params, variance) = List.split tl in - {ptype_params = params; ptype_cstrs = cl; ptype_kind = tk; - ptype_manifest = tm; ptype_loc = mkloc loc; ptype_variance = variance} -;; -let mkmutable m = if m then Mutable else Immutable;; -let mkprivate m = if m then Private else Public;; -let mktrecord (_, n, m, t) = n, mkmutable m, ctyp (mkpolytype t);; -let mkvariant (_, c, tl) = c, List.map ctyp tl;; -let type_decl tl cl = - function - TyMan (loc, t, TyRec (_, pflag, ltl)) -> - mktype loc tl cl - (Ptype_record (List.map mktrecord ltl, mkprivate pflag)) - (Some (ctyp t)) - | TyMan (loc, t, TySum (_, pflag, ctl)) -> - mktype loc tl cl - (Ptype_variant (List.map mkvariant ctl, mkprivate pflag)) - (Some (ctyp t)) - | TyRec (loc, pflag, ltl) -> - mktype loc tl cl - (Ptype_record (List.map mktrecord ltl, mkprivate pflag)) None - | TySum (loc, pflag, ctl) -> - mktype loc tl cl - (Ptype_variant (List.map mkvariant ctl, mkprivate pflag)) None - | t -> - let m = - match t with - TyQuo (_, s) -> if List.mem_assoc s tl then Some (ctyp t) else None - | _ -> Some (ctyp t) - in - mktype (loc_of_ctyp t) tl cl Ptype_abstract m -;; - -let mkvalue_desc t p = {pval_type = ctyp t; pval_prim = p};; - -let option f = - function - Some x -> Some (f x) - | None -> None -;; - -let expr_of_lab loc lab = - function - Some e -> e - | None -> ExLid (loc, lab) -;; - -let patt_of_lab loc lab = - function - Some p -> p - | None -> PaLid (loc, lab) -;; - -let paolab loc lab peoo = - let lab = - match lab, peoo with - "", Some ((PaLid (_, i) | PaTyc (_, PaLid (_, i), _)), _) -> i - | "", _ -> error loc "bad ast" - | _ -> lab - in - let (p, eo) = - match peoo with - Some peo -> peo - | None -> PaLid (loc, lab), None - in - lab, p, eo -;; - -let rec same_type_expr ct ce = - match ct, ce with - TyLid (_, s1), ExLid (_, s2) -> s1 = s2 - | TyUid (_, s1), ExUid (_, s2) -> s1 = s2 - | TyAcc (_, t1, t2), ExAcc (_, e1, e2) -> - same_type_expr t1 e1 && same_type_expr t2 e2 - | _ -> false -;; - -let rec common_id loc t e = - match t, e with - TyLid (_, s1), ExLid (_, s2) when s1 = s2 -> lident s1 - | TyUid (_, s1), ExUid (_, s2) when s1 = s2 -> lident s1 - | TyAcc (_, t1, TyLid (_, s1)), ExAcc (_, e1, ExLid (_, s2)) when s1 = s2 -> - ldot (common_id loc t1 e1) s1 - | TyAcc (_, t1, TyUid (_, s1)), ExAcc (_, e1, ExUid (_, s2)) when s1 = s2 -> - ldot (common_id loc t1 e1) s1 - | _ -> error loc "this expression should repeat the class id inherited" -;; - -let rec type_id loc t = - match t with - TyLid (_, s1) -> lident s1 - | TyUid (_, s1) -> lident s1 - | TyAcc (_, t1, TyLid (_, s1)) -> ldot (type_id loc t1) s1 - | TyAcc (_, t1, TyUid (_, s1)) -> ldot (type_id loc t1) s1 - | _ -> error loc "type identifier expected" -;; - -let rec module_type_long_id = - function - MtAcc (_, m, MtUid (_, s)) -> ldot (module_type_long_id m) s - | MtAcc (_, m, MtLid (_, s)) -> ldot (module_type_long_id m) s - | MtApp (_, m1, m2) -> - Lapply (module_type_long_id m1, module_type_long_id m2) - | MtLid (_, s) -> lident s - | MtUid (_, s) -> lident s - | t -> error (loc_of_module_type t) "bad module type long ident" -;; - -let rec module_expr_long_id = - function - MeAcc (_, m, MeUid (_, s)) -> ldot (module_expr_long_id m) s - | MeUid (_, s) -> lident s - | t -> error (loc_of_module_expr t) "bad module expr long ident" -;; - -let mkwithc = - function - WcTyp (loc, id, tpl, ct) -> - let (params, variance) = List.split tpl in - long_id_of_string_list loc id, - Pwith_type - {ptype_params = params; ptype_cstrs = []; ptype_kind = Ptype_abstract; - ptype_manifest = Some (ctyp ct); ptype_loc = mkloc loc; - ptype_variance = variance} - | WcMod (loc, id, m) -> - long_id_of_string_list loc id, Pwith_module (module_expr_long_id m) -;; - -let rec patt_fa al = - function - PaApp (_, f, a) -> patt_fa (a :: al) f - | f -> f, al -;; - -let rec deep_mkrangepat loc c1 c2 = - if c1 = c2 then mkghpat loc (Ppat_constant (Const_char c1)) - else - mkghpat loc - (Ppat_or - (mkghpat loc (Ppat_constant (Const_char c1)), - deep_mkrangepat loc (Char.chr (Char.code c1 + 1)) c2)) -;; - -let rec mkrangepat loc c1 c2 = - if c1 > c2 then mkrangepat loc c2 c1 - else if c1 = c2 then mkpat loc (Ppat_constant (Const_char c1)) - else - mkpat loc - (Ppat_or - (mkghpat loc (Ppat_constant (Const_char c1)), - deep_mkrangepat loc (Char.chr (Char.code c1 + 1)) c2)) -;; - -let rec patt_long_id il = - function - PaAcc (_, p, PaUid (_, i)) -> patt_long_id (i :: il) p - | p -> p, il -;; - -let rec patt_label_long_id = - function - PaAcc (_, m, PaLid (_, s)) -> ldot (patt_label_long_id m) (conv_lab s) - | PaAcc (_, m, PaUid (_, s)) -> ldot (patt_label_long_id m) s - | PaUid (_, s) -> lident s - | PaLid (_, s) -> lident (conv_lab s) - | p -> error (loc_of_patt p) "bad label" -;; - -let rec patt = - function - PaAcc (loc, p1, p2) -> - let p = - match patt_long_id [] p1 with - PaUid (_, i), il -> - begin match p2 with - PaUid (_, s) -> - Ppat_construct - (mkli (conv_con s) (i :: il), None, - not !no_constructors_arity) - | _ -> error (loc_of_patt p2) "uppercase identifier expected" - end - | _ -> error (loc_of_patt p2) "bad pattern" - in - mkpat loc p - | PaAli (loc, p1, p2) -> - let (p, i) = - match p1, p2 with - p, PaLid (_, s) -> p, s - | PaLid (_, s), p -> p, s - | _ -> error loc "incorrect alias pattern" - in - mkpat loc (Ppat_alias (patt p, i)) - | PaAnt (_, p) -> patt p - | PaAny loc -> mkpat loc Ppat_any - | PaApp (loc, _, _) as f -> - let (f, al) = patt_fa [] f in - let al = List.map patt al in - begin match (patt f).ppat_desc with - Ppat_construct (li, None, _) -> - if !no_constructors_arity then - let a = - match al with - [a] -> a - | _ -> mkpat loc (Ppat_tuple al) - in - mkpat loc (Ppat_construct (li, Some a, false)) - else - let a = mkpat loc (Ppat_tuple al) in - mkpat loc (Ppat_construct (li, Some a, true)) - | Ppat_variant (s, None) -> - let a = - match al with - [a] -> a - | _ -> mkpat loc (Ppat_tuple al) - in - mkpat loc (Ppat_variant (s, Some a)) - | _ -> - error (loc_of_patt f) - "this is not a constructor, it cannot be applied in a pattern" - end - | PaArr (loc, pl) -> mkpat loc (Ppat_array (List.map patt pl)) - | PaChr (loc, s) -> - mkpat loc (Ppat_constant (Const_char (char_of_char_token loc s))) - | PaInt (loc, s) -> mkpat loc (Ppat_constant (Const_int (int_of_string s))) - | PaInt32 (loc, s) -> - mkpat loc (Ppat_constant (Const_int32 (Int32.of_string s))) - | PaInt64 (loc, s) -> - mkpat loc (Ppat_constant (Const_int64 (Int64.of_string s))) - | PaNativeInt (loc, s) -> - mkpat loc (Ppat_constant (Const_nativeint (Nativeint.of_string s))) - | PaFlo (loc, s) -> mkpat loc (Ppat_constant (Const_float s)) - | PaLab (loc, _, _) -> error loc "labeled pattern not allowed here" - | PaLid (loc, s) -> mkpat loc (Ppat_var s) - | PaOlb (loc, _, _) -> error loc "labeled pattern not allowed here" - | PaOrp (loc, p1, p2) -> mkpat loc (Ppat_or (patt p1, patt p2)) - | PaRng (loc, p1, p2) -> - begin match p1, p2 with - PaChr (loc1, c1), PaChr (loc2, c2) -> - let c1 = char_of_char_token loc1 c1 in - let c2 = char_of_char_token loc2 c2 in mkrangepat loc c1 c2 - | _ -> error loc "range pattern allowed only for characters" - end - | PaRec (loc, lpl) -> mkpat loc (Ppat_record (List.map mklabpat lpl)) - | PaStr (loc, s) -> - mkpat loc (Ppat_constant (Const_string (string_of_string_token loc s))) - | PaTup (loc, pl) -> mkpat loc (Ppat_tuple (List.map patt pl)) - | PaTyc (loc, p, t) -> mkpat loc (Ppat_constraint (patt p, ctyp t)) - | PaTyp (loc, sl) -> mkpat loc (Ppat_type (long_id_of_string_list loc sl)) - | PaUid (loc, s) -> - let ca = not !no_constructors_arity in - mkpat loc (Ppat_construct (lident (conv_con s), None, ca)) - | PaVrn (loc, s) -> mkpat loc (Ppat_variant (s, None)) -and mklabpat (lab, p) = patt_label_long_id lab, patt p;; - -let rec expr_fa al = - function - ExApp (_, f, a) -> expr_fa (a :: al) f - | f -> f, al -;; - -let rec class_expr_fa al = - function - CeApp (_, ce, a) -> class_expr_fa (a :: al) ce - | ce -> ce, al -;; - -let rec sep_expr_acc l = - function - ExAcc (_, e1, e2) -> sep_expr_acc (sep_expr_acc l e2) e1 - | ExUid ((bp, _ as loc), s) as e -> - begin match l with - [] -> [loc, [], e] - | ((_, ep), sl, e) :: l -> ((bp, ep), s :: sl, e) :: l - end - | e -> (loc_of_expr e, [], e) :: l -;; - -(* -value expr_label_long_id e = - match sep_expr_acc [] e with - [ [(_, ml, ExLid _ s)] -> mkli (conv_lab s) ml - | _ -> error (loc_of_expr e) "invalid label" ] -; -*) - -let class_info class_expr ci = - let (params, variance) = List.split (snd ci.ciPrm) in - {pci_virt = if ci.ciVir then Virtual else Concrete; - pci_params = params, mkloc (fst ci.ciPrm); pci_name = ci.ciNam; - pci_expr = class_expr ci.ciExp; pci_loc = mkloc ci.ciLoc; - pci_variance = variance} -;; - -let apply_with_var v x f = - let vx = !v in - try v := x; let r = f () in v := vx; r with - e -> v := vx; raise e -;; - -let rec expr = - function - ExAcc (loc, x, ExLid (_, "val")) -> - mkexp loc - (Pexp_apply (mkexp loc (Pexp_ident (Lident "!")), ["", expr x])) - | ExAcc (loc, _, _) as e -> - let (e, l) = - match sep_expr_acc [] e with - (loc, ml, ExUid (_, s)) :: l -> - let ca = not !no_constructors_arity in - mkexp loc (Pexp_construct (mkli s ml, None, ca)), l - | (loc, ml, ExLid (_, s)) :: l -> - mkexp loc (Pexp_ident (mkli s ml)), l - | (_, [], e) :: l -> expr e, l - | _ -> error loc "bad ast" - in - let (_, e) = - List.fold_left - (fun ((bp, _), e1) ((_, ep), ml, e2) -> - match e2 with - ExLid (_, s) -> - let loc = bp, ep in - loc, mkexp loc (Pexp_field (e1, mkli (conv_lab s) ml)) - | _ -> error (loc_of_expr e2) "lowercase identifier expected") - (loc, e) l - in - e - | ExAnt (_, e) -> expr e - | ExApp (loc, _, _) as f -> - let (f, al) = expr_fa [] f in - let al = List.map label_expr al in - begin match (expr f).pexp_desc with - Pexp_construct (li, None, _) -> - let al = List.map snd al in - if !no_constructors_arity then - let a = - match al with - [a] -> a - | _ -> mkexp loc (Pexp_tuple al) - in - mkexp loc (Pexp_construct (li, Some a, false)) - else - let a = mkexp loc (Pexp_tuple al) in - mkexp loc (Pexp_construct (li, Some a, true)) - | Pexp_variant (s, None) -> - let al = List.map snd al in - let a = - match al with - [a] -> a - | _ -> mkexp loc (Pexp_tuple al) - in - mkexp loc (Pexp_variant (s, Some a)) - | _ -> mkexp loc (Pexp_apply (expr f, al)) - end - | ExAre (loc, e1, e2) -> - mkexp loc - (Pexp_apply - (mkexp loc (Pexp_ident (array_function "Array" "get")), - ["", expr e1; "", expr e2])) - | ExArr (loc, el) -> mkexp loc (Pexp_array (List.map expr el)) - | ExAsf loc -> mkexp loc Pexp_assertfalse - | ExAss (loc, e, v) -> - let e = - match e with - ExAcc (loc, x, ExLid (_, "val")) -> - Pexp_apply - (mkexp loc (Pexp_ident (Lident ":=")), ["", expr x; "", expr v]) - | ExAcc (loc, _, _) -> - begin match (expr e).pexp_desc with - Pexp_field (e, lab) -> Pexp_setfield (e, lab, expr v) - | _ -> error loc "bad record access" - end - | ExAre (_, e1, e2) -> - Pexp_apply - (mkexp loc (Pexp_ident (array_function "Array" "set")), - ["", expr e1; "", expr e2; "", expr v]) - | ExLid (_, lab) -> Pexp_setinstvar (lab, expr v) - | ExSte (_, e1, e2) -> - Pexp_apply - (mkexp loc (Pexp_ident (array_function "String" "set")), - ["", expr e1; "", expr e2; "", expr v]) - | _ -> error loc "bad left part of assignment" - in - mkexp loc e - | ExAsr (loc, e) -> mkexp loc (Pexp_assert (expr e)) - | ExChr (loc, s) -> - mkexp loc (Pexp_constant (Const_char (char_of_char_token loc s))) - | ExCoe (loc, e, t1, t2) -> - mkexp loc (Pexp_constraint (expr e, option ctyp t1, Some (ctyp t2))) - | ExFlo (loc, s) -> mkexp loc (Pexp_constant (Const_float s)) - | ExFor (loc, i, e1, e2, df, el) -> - let e3 = ExSeq (loc, el) in - let df = if df then Upto else Downto in - mkexp loc (Pexp_for (i, expr e1, expr e2, df, expr e3)) - | ExFun (loc, [PaLab (_, lab, po), w, e]) -> - mkexp loc - (Pexp_function - (lab, None, [patt (patt_of_lab loc lab po), when_expr e w])) - | ExFun (loc, [PaOlb (_, lab, peoo), w, e]) -> - let (lab, p, eo) = paolab loc lab peoo in - mkexp loc - (Pexp_function (("?" ^ lab), option expr eo, [patt p, when_expr e w])) - | ExFun (loc, pel) -> - mkexp loc (Pexp_function ("", None, List.map mkpwe pel)) - | ExIfe (loc, e1, e2, e3) -> - mkexp loc (Pexp_ifthenelse (expr e1, expr e2, Some (expr e3))) - | ExInt (loc, s) -> mkexp loc (Pexp_constant (Const_int (int_of_string s))) - | ExInt32 (loc, s) -> - mkexp loc (Pexp_constant (Const_int32 (Int32.of_string s))) - | ExInt64 (loc, s) -> - mkexp loc (Pexp_constant (Const_int64 (Int64.of_string s))) - | ExNativeInt (loc, s) -> - mkexp loc (Pexp_constant (Const_nativeint (Nativeint.of_string s))) - | ExLab (loc, _, _) -> error loc "labeled expression not allowed here" - | ExLaz (loc, e) -> mkexp loc (Pexp_lazy (expr e)) - | ExLet (loc, rf, pel, e) -> - mkexp loc (Pexp_let (mkrf rf, List.map mkpe pel, expr e)) - | ExLid (loc, s) -> mkexp loc (Pexp_ident (lident s)) - | ExLmd (loc, i, me, e) -> - mkexp loc (Pexp_letmodule (i, module_expr me, expr e)) - | ExMat (loc, e, pel) -> mkexp loc (Pexp_match (expr e, List.map mkpwe pel)) - | ExNew (loc, id) -> mkexp loc (Pexp_new (long_id_of_string_list loc id)) - | ExOlb (loc, _, _) -> error loc "labeled expression not allowed here" - | ExOvr (loc, iel) -> mkexp loc (Pexp_override (List.map mkideexp iel)) - | ExRec (loc, lel, eo) -> - if lel = [] then error loc "empty record" - else - let eo = - match eo with - Some e -> Some (expr e) - | None -> None - in - mkexp loc (Pexp_record (List.map mklabexp lel, eo)) - | ExSeq (loc, el) -> - let rec loop = - function - [] -> expr (ExUid (loc, "()")) - | [e] -> expr e - | e :: el -> - let loc = fst (loc_of_expr e), snd loc in - mkexp loc (Pexp_sequence (expr e, loop el)) - in - loop el - | ExSnd (loc, e, s) -> mkexp loc (Pexp_send (expr e, s)) - | ExSte (loc, e1, e2) -> - mkexp loc - (Pexp_apply - (mkexp loc (Pexp_ident (array_function "String" "get")), - ["", expr e1; "", expr e2])) - | ExStr (loc, s) -> - mkexp loc (Pexp_constant (Const_string (string_of_string_token loc s))) - | ExTry (loc, e, pel) -> mkexp loc (Pexp_try (expr e, List.map mkpwe pel)) - | ExTup (loc, el) -> mkexp loc (Pexp_tuple (List.map expr el)) - | ExTyc (loc, e, t) -> - mkexp loc (Pexp_constraint (expr e, Some (ctyp t), None)) - | ExUid (loc, s) -> - let ca = not !no_constructors_arity in - mkexp loc (Pexp_construct (lident (conv_con s), None, ca)) - | ExVrn (loc, s) -> mkexp loc (Pexp_variant (s, None)) - | ExWhi (loc, e1, el) -> - let e2 = ExSeq (loc, el) in mkexp loc (Pexp_while (expr e1, expr e2)) -and label_expr = - function - ExLab (loc, lab, eo) -> lab, expr (expr_of_lab loc lab eo) - | ExOlb (loc, lab, eo) -> "?" ^ lab, expr (expr_of_lab loc lab eo) - | e -> "", expr e -and mkpe (p, e) = patt p, expr e -and mkpwe (p, w, e) = patt p, when_expr e w -and when_expr e = - function - Some w -> mkexp (loc_of_expr e) (Pexp_when (expr w, expr e)) - | None -> expr e -and mklabexp (lab, e) = patt_label_long_id lab, expr e -and mkideexp (ide, e) = ide, expr e -and mktype_decl ((loc, c), tl, td, cl) = - let cl = - List.map - (fun (t1, t2) -> - let loc = fst (loc_of_ctyp t1), snd (loc_of_ctyp t2) in - ctyp t1, ctyp t2, mkloc loc) - cl - in - c, type_decl tl cl td -and module_type = - function - MtAcc (loc, _, _) as f -> mkmty loc (Pmty_ident (module_type_long_id f)) - | MtApp (loc, _, _) as f -> mkmty loc (Pmty_ident (module_type_long_id f)) - | MtFun (loc, n, nt, mt) -> - mkmty loc (Pmty_functor (n, module_type nt, module_type mt)) - | MtLid (loc, s) -> mkmty loc (Pmty_ident (lident s)) - | MtQuo (loc, _) -> error loc "abstract module type not allowed here" - | MtSig (loc, sl) -> - mkmty loc (Pmty_signature (List.fold_right sig_item sl [])) - | MtUid (loc, s) -> mkmty loc (Pmty_ident (lident s)) - | MtWit (loc, mt, wcl) -> - mkmty loc (Pmty_with (module_type mt, List.map mkwithc wcl)) -and sig_item s l = - match s with - SgCls (loc, cd) -> - mksig loc (Psig_class (List.map (class_info class_type) cd)) :: l - | SgClt (loc, ctd) -> - mksig loc (Psig_class_type (List.map (class_info class_type) ctd)) :: l - | SgDcl (loc, sl) -> List.fold_right sig_item sl l - | SgDir (loc, _, _) -> l - | SgExc (loc, n, tl) -> - mksig loc (Psig_exception (n, List.map ctyp tl)) :: l - | SgExt (loc, n, t, p) -> mksig loc (Psig_value (n, mkvalue_desc t p)) :: l - | SgInc (loc, mt) -> mksig loc (Psig_include (module_type mt)) :: l - | SgMod (loc, n, mt) -> mksig loc (Psig_module (n, module_type mt)) :: l - | SgRecMod (loc, nmts) -> - mksig loc - (Psig_recmodule (List.map (fun (n, mt) -> n, module_type mt) nmts)) :: - l - | SgMty (loc, n, mt) -> - let si = - match mt with - MtQuo (_, _) -> Pmodtype_abstract - | _ -> Pmodtype_manifest (module_type mt) - in - mksig loc (Psig_modtype (n, si)) :: l - | SgOpn (loc, id) -> - mksig loc (Psig_open (long_id_of_string_list loc id)) :: l - | SgTyp (loc, tdl) -> mksig loc (Psig_type (List.map mktype_decl tdl)) :: l - | SgUse (loc, fn, sl) -> - apply_with_var glob_fname fn - (fun () -> List.fold_right (fun (si, _) -> sig_item si) sl l) - | SgVal (loc, n, t) -> mksig loc (Psig_value (n, mkvalue_desc t [])) :: l -and module_expr = - function - MeAcc (loc, _, _) as f -> mkmod loc (Pmod_ident (module_expr_long_id f)) - | MeApp (loc, me1, me2) -> - mkmod loc (Pmod_apply (module_expr me1, module_expr me2)) - | MeFun (loc, n, mt, me) -> - mkmod loc (Pmod_functor (n, module_type mt, module_expr me)) - | MeStr (loc, sl) -> - mkmod loc (Pmod_structure (List.fold_right str_item sl [])) - | MeTyc (loc, me, mt) -> - mkmod loc (Pmod_constraint (module_expr me, module_type mt)) - | MeUid (loc, s) -> mkmod loc (Pmod_ident (lident s)) -and str_item s l = - match s with - StCls (loc, cd) -> - mkstr loc (Pstr_class (List.map (class_info class_expr) cd)) :: l - | StClt (loc, ctd) -> - mkstr loc (Pstr_class_type (List.map (class_info class_type) ctd)) :: l - | StDcl (loc, sl) -> List.fold_right str_item sl l - | StDir (loc, _, _) -> l - | StExc (loc, n, tl, sl) -> - let si = - match tl, sl with - tl, [] -> Pstr_exception (n, List.map ctyp tl) - | [], sl -> Pstr_exn_rebind (n, long_id_of_string_list loc sl) - | _ -> error loc "bad exception declaration" - in - mkstr loc si :: l - | StExp (loc, e) -> mkstr loc (Pstr_eval (expr e)) :: l - | StExt (loc, n, t, p) -> - mkstr loc (Pstr_primitive (n, mkvalue_desc t p)) :: l - | StInc (loc, me) -> mkstr loc (Pstr_include (module_expr me)) :: l - | StMod (loc, n, me) -> mkstr loc (Pstr_module (n, module_expr me)) :: l - | StRecMod (loc, nmes) -> - mkstr loc - (Pstr_recmodule - (List.map (fun (n, mt, me) -> n, module_type mt, module_expr me) - nmes)) :: - l - | StMty (loc, n, mt) -> mkstr loc (Pstr_modtype (n, module_type mt)) :: l - | StOpn (loc, id) -> - mkstr loc (Pstr_open (long_id_of_string_list loc id)) :: l - | StTyp (loc, tdl) -> mkstr loc (Pstr_type (List.map mktype_decl tdl)) :: l - | StUse (loc, fn, sl) -> - apply_with_var glob_fname fn - (fun () -> List.fold_right (fun (si, _) -> str_item si) sl l) - | StVal (loc, rf, pel) -> - mkstr loc (Pstr_value (mkrf rf, List.map mkpe pel)) :: l -and class_type = - function - CtCon (loc, id, tl) -> - mkcty loc - (Pcty_constr (long_id_of_string_list loc id, List.map ctyp tl)) - | CtFun (loc, TyLab (_, lab, t), ct) -> - mkcty loc (Pcty_fun (lab, ctyp t, class_type ct)) - | CtFun (loc, TyOlb (loc1, lab, t), ct) -> - let t = TyApp (loc1, TyLid (loc1, "option"), t) in - mkcty loc (Pcty_fun (("?" ^ lab), ctyp t, class_type ct)) - | CtFun (loc, t, ct) -> mkcty loc (Pcty_fun ("", ctyp t, class_type ct)) - | CtSig (loc, t_o, ctfl) -> - let t = - match t_o with - Some t -> t - | None -> TyAny loc - in - let cil = List.fold_right class_sig_item ctfl [] in - mkcty loc (Pcty_signature (ctyp t, cil)) -and class_sig_item c l = - match c with - CgCtr (loc, t1, t2) -> Pctf_cstr (ctyp t1, ctyp t2, mkloc loc) :: l - | CgDcl (loc, cl) -> List.fold_right class_sig_item cl l - | CgInh (loc, ct) -> Pctf_inher (class_type ct) :: l - | CgMth (loc, s, pf, t) -> - Pctf_meth (s, mkprivate pf, ctyp (mkpolytype t), mkloc loc) :: l - | CgVal (loc, s, b, t) -> - Pctf_val (s, mkmutable b, Some (ctyp t), mkloc loc) :: l - | CgVir (loc, s, b, t) -> - Pctf_virt (s, mkprivate b, ctyp (mkpolytype t), mkloc loc) :: l -and class_expr = - function - CeApp (loc, _, _) as c -> - let (ce, el) = class_expr_fa [] c in - let el = List.map label_expr el in - mkpcl loc (Pcl_apply (class_expr ce, el)) - | CeCon (loc, id, tl) -> - mkpcl loc (Pcl_constr (long_id_of_string_list loc id, List.map ctyp tl)) - | CeFun (loc, PaLab (_, lab, po), ce) -> - mkpcl loc - (Pcl_fun (lab, None, patt (patt_of_lab loc lab po), class_expr ce)) - | CeFun (loc, PaOlb (_, lab, peoo), ce) -> - let (lab, p, eo) = paolab loc lab peoo in - mkpcl loc (Pcl_fun (("?" ^ lab), option expr eo, patt p, class_expr ce)) - | CeFun (loc, p, ce) -> - mkpcl loc (Pcl_fun ("", None, patt p, class_expr ce)) - | CeLet (loc, rf, pel, ce) -> - mkpcl loc (Pcl_let (mkrf rf, List.map mkpe pel, class_expr ce)) - | CeStr (loc, po, cfl) -> - let p = - match po with - Some p -> p - | None -> PaAny loc - in - let cil = List.fold_right class_str_item cfl [] in - mkpcl loc (Pcl_structure (patt p, cil)) - | CeTyc (loc, ce, ct) -> - mkpcl loc (Pcl_constraint (class_expr ce, class_type ct)) -and class_str_item c l = - match c with - CrCtr (loc, t1, t2) -> Pcf_cstr (ctyp t1, ctyp t2, mkloc loc) :: l - | CrDcl (loc, cl) -> List.fold_right class_str_item cl l - | CrInh (loc, ce, pb) -> Pcf_inher (class_expr ce, pb) :: l - | CrIni (loc, e) -> Pcf_init (expr e) :: l - | CrMth (loc, s, b, e, t) -> - let t = option (fun t -> ctyp (mkpolytype t)) t in - let e = mkexp loc (Pexp_poly (expr e, t)) in - Pcf_meth (s, mkprivate b, e, mkloc loc) :: l - | CrVal (loc, s, b, e) -> Pcf_val (s, mkmutable b, expr e, mkloc loc) :: l - | CrVir (loc, s, b, t) -> - Pcf_virt (s, mkprivate b, ctyp (mkpolytype t), mkloc loc) :: l -;; - -let interf ast = List.fold_right sig_item ast [];; -let implem ast = List.fold_right str_item ast [];; - -let directive loc = - function - None -> Pdir_none - | Some (ExStr (_, s)) -> Pdir_string s - | Some (ExInt (_, i)) -> Pdir_int (int_of_string i) - | Some (ExUid (_, "True")) -> Pdir_bool true - | Some (ExUid (_, "False")) -> Pdir_bool false - | Some e -> - let sl = - let rec loop = - function - ExLid (_, i) | ExUid (_, i) -> [i] - | ExAcc (_, e, ExLid (_, i)) | ExAcc (_, e, ExUid (_, i)) -> - loop e @ [i] - | e -> raise_with_loc (loc_of_expr e) (Failure "bad ast") - in - loop e - in - Pdir_ident (long_id_of_string_list loc sl) -;; - -let phrase = - function - StDir (loc, d, dp) -> Ptop_dir (d, directive loc dp) - | si -> Ptop_def (str_item si []) -;; diff --git a/camlp4/ocaml_src/camlp4/ast2pt.mli b/camlp4/ocaml_src/camlp4/ast2pt.mli deleted file mode 100644 index d64fb6e370..0000000000 --- a/camlp4/ocaml_src/camlp4/ast2pt.mli +++ /dev/null @@ -1,23 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* This file has been generated by program: do not edit! *) - -val fast : bool ref;; -val no_constructors_arity : bool ref;; -val mkloc : int * int -> Location.t;; -val long_id_of_string_list : int * int -> string list -> Longident.t;; - -val str_item : MLast.str_item -> Parsetree.structure -> Parsetree.structure;; -val interf : MLast.sig_item list -> Parsetree.signature;; -val implem : MLast.str_item list -> Parsetree.structure;; -val phrase : MLast.str_item -> Parsetree.toplevel_phrase;; diff --git a/camlp4/ocaml_src/camlp4/mLast.mli b/camlp4/ocaml_src/camlp4/mLast.mli deleted file mode 100644 index 54a66b9c65..0000000000 --- a/camlp4/ocaml_src/camlp4/mLast.mli +++ /dev/null @@ -1,211 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* This file has been generated by program: do not edit! *) - -(* Module [MLast]: abstract syntax tree - - This is undocumented because the AST is not supposed to be used - directly; the good usage is to use the quotations representing - these values in concrete syntax (see the Camlp4 documentation). - See also the file q_MLast.ml in Camlp4 sources. *) - -type loc = int * int;; - -type ctyp = - TyAcc of loc * ctyp * ctyp - | TyAli of loc * ctyp * ctyp - | TyAny of loc - | TyApp of loc * ctyp * ctyp - | TyArr of loc * ctyp * ctyp - | TyCls of loc * string list - | TyLab of loc * string * ctyp - | TyLid of loc * string - | TyMan of loc * ctyp * ctyp - | TyObj of loc * (string * ctyp) list * bool - | TyOlb of loc * string * ctyp - | TyPol of loc * string list * ctyp - | TyQuo of loc * string - | TyRec of loc * bool * (loc * string * bool * ctyp) list - | TySum of loc * bool * (loc * string * ctyp list) list - | TyTup of loc * ctyp list - | TyUid of loc * string - | TyVrn of loc * row_field list * string list option option -and row_field = - RfTag of string * bool * ctyp list - | RfInh of ctyp -;; - -type 'a class_infos = - { ciLoc : loc; - ciVir : bool; - ciPrm : loc * (string * (bool * bool)) list; - ciNam : string; - ciExp : 'a } -;; - -type patt = - PaAcc of loc * patt * patt - | PaAli of loc * patt * patt - | PaAnt of loc * patt - | PaAny of loc - | PaApp of loc * patt * patt - | PaArr of loc * patt list - | PaChr of loc * string - | PaInt of loc * string - | PaInt32 of loc * string - | PaInt64 of loc * string - | PaNativeInt of loc * string - | PaFlo of loc * string - | PaLab of loc * string * patt option - | PaLid of loc * string - | PaOlb of loc * string * (patt * expr option) option - | PaOrp of loc * patt * patt - | PaRng of loc * patt * patt - | PaRec of loc * (patt * patt) list - | PaStr of loc * string - | PaTup of loc * patt list - | PaTyc of loc * patt * ctyp - | PaTyp of loc * string list - | PaUid of loc * string - | PaVrn of loc * string -and expr = - ExAcc of loc * expr * expr - | ExAnt of loc * expr - | ExApp of loc * expr * expr - | ExAre of loc * expr * expr - | ExArr of loc * expr list - | ExAsf of loc - | ExAsr of loc * expr - | ExAss of loc * expr * expr - | ExChr of loc * string - | ExCoe of loc * expr * ctyp option * ctyp - | ExFlo of loc * string - | ExFor of loc * string * expr * expr * bool * expr list - | ExFun of loc * (patt * expr option * expr) list - | ExIfe of loc * expr * expr * expr - | ExInt of loc * string - | ExInt32 of loc * string - | ExInt64 of loc * string - | ExNativeInt of loc * string - | ExLab of loc * string * expr option - | ExLaz of loc * expr - | ExLet of loc * bool * (patt * expr) list * expr - | ExLid of loc * string - | ExLmd of loc * string * module_expr * expr - | ExMat of loc * expr * (patt * expr option * expr) list - | ExNew of loc * string list - | ExOlb of loc * string * expr option - | ExOvr of loc * (string * expr) list - | ExRec of loc * (patt * expr) list * expr option - | ExSeq of loc * expr list - | ExSnd of loc * expr * string - | ExSte of loc * expr * expr - | ExStr of loc * string - | ExTry of loc * expr * (patt * expr option * expr) list - | ExTup of loc * expr list - | ExTyc of loc * expr * ctyp - | ExUid of loc * string - | ExVrn of loc * string - | ExWhi of loc * expr * expr list -and module_type = - MtAcc of loc * module_type * module_type - | MtApp of loc * module_type * module_type - | MtFun of loc * string * module_type * module_type - | MtLid of loc * string - | MtQuo of loc * string - | MtSig of loc * sig_item list - | MtUid of loc * string - | MtWit of loc * module_type * with_constr list -and sig_item = - SgCls of loc * class_type class_infos list - | SgClt of loc * class_type class_infos list - | SgDcl of loc * sig_item list - | SgDir of loc * string * expr option - | SgExc of loc * string * ctyp list - | SgExt of loc * string * ctyp * string list - | SgInc of loc * module_type - | SgMod of loc * string * module_type - | SgRecMod of loc * (string * module_type) list - | SgMty of loc * string * module_type - | SgOpn of loc * string list - | SgTyp of loc * type_decl list - | SgUse of loc * string * (sig_item * loc) list - | SgVal of loc * string * ctyp -and with_constr = - WcTyp of loc * string list * (string * (bool * bool)) list * ctyp - | WcMod of loc * string list * module_expr -and module_expr = - MeAcc of loc * module_expr * module_expr - | MeApp of loc * module_expr * module_expr - | MeFun of loc * string * module_type * module_expr - | MeStr of loc * str_item list - | MeTyc of loc * module_expr * module_type - | MeUid of loc * string -and str_item = - StCls of loc * class_expr class_infos list - | StClt of loc * class_type class_infos list - | StDcl of loc * str_item list - | StDir of loc * string * expr option - | StExc of loc * string * ctyp list * string list - | StExp of loc * expr - | StExt of loc * string * ctyp * string list - | StInc of loc * module_expr - | StMod of loc * string * module_expr - | StRecMod of loc * (string * module_type * module_expr) list - | StMty of loc * string * module_type - | StOpn of loc * string list - | StTyp of loc * type_decl list - | StUse of loc * string * (str_item * loc) list - | StVal of loc * bool * (patt * expr) list -and type_decl = - (loc * string) * (string * (bool * bool)) list * ctyp * (ctyp * ctyp) list -and class_type = - CtCon of loc * string list * ctyp list - | CtFun of loc * ctyp * class_type - | CtSig of loc * ctyp option * class_sig_item list -and class_sig_item = - CgCtr of loc * ctyp * ctyp - | CgDcl of loc * class_sig_item list - | CgInh of loc * class_type - | CgMth of loc * string * bool * ctyp - | CgVal of loc * string * bool * ctyp - | CgVir of loc * string * bool * ctyp -and class_expr = - CeApp of loc * class_expr * expr - | CeCon of loc * string list * ctyp list - | CeFun of loc * patt * class_expr - | CeLet of loc * bool * (patt * expr) list * class_expr - | CeStr of loc * patt option * class_str_item list - | CeTyc of loc * class_expr * class_type -and class_str_item = - CrCtr of loc * ctyp * ctyp - | CrDcl of loc * class_str_item list - | CrInh of loc * class_expr * string option - | CrIni of loc * expr - | CrMth of loc * string * bool * expr * ctyp option - | CrVal of loc * string * bool * expr - | CrVir of loc * string * bool * ctyp -;; - -external loc_of_ctyp : ctyp -> loc = "%field0";; -external loc_of_patt : patt -> loc = "%field0";; -external loc_of_expr : expr -> loc = "%field0";; -external loc_of_module_type : module_type -> loc = "%field0";; -external loc_of_module_expr : module_expr -> loc = "%field0";; -external loc_of_sig_item : sig_item -> loc = "%field0";; -external loc_of_str_item : str_item -> loc = "%field0";; - -external loc_of_class_type : class_type -> loc = "%field0";; -external loc_of_class_sig_item : class_sig_item -> loc = "%field0";; -external loc_of_class_expr : class_expr -> loc = "%field0";; -external loc_of_class_str_item : class_str_item -> loc = "%field0";; diff --git a/camlp4/ocaml_src/camlp4/pcaml.ml b/camlp4/ocaml_src/camlp4/pcaml.ml deleted file mode 100644 index 7258fa070e..0000000000 --- a/camlp4/ocaml_src/camlp4/pcaml.ml +++ /dev/null @@ -1,464 +0,0 @@ -(* camlp4r pa_extend.cmo *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* This file has been generated by program: do not edit! *) - -let version = Sys.ocaml_version;; - -let syntax_name = ref "";; - -let gram = - Grammar.gcreate - {Token.tok_func = (fun _ -> failwith "no loaded parsing module"); - Token.tok_using = (fun _ -> ()); Token.tok_removing = (fun _ -> ()); - Token.tok_match = (fun _ -> raise (Match_failure ("pcaml.ml", 23, 23))); - Token.tok_text = (fun _ -> ""); Token.tok_comm = None} -;; - -let interf = Grammar.Entry.create gram "interf";; -let implem = Grammar.Entry.create gram "implem";; -let top_phrase = Grammar.Entry.create gram "top_phrase";; -let use_file = Grammar.Entry.create gram "use_file";; -let sig_item = Grammar.Entry.create gram "sig_item";; -let str_item = Grammar.Entry.create gram "str_item";; -let module_type = Grammar.Entry.create gram "module_type";; -let module_expr = Grammar.Entry.create gram "module_expr";; -let expr = Grammar.Entry.create gram "expr";; -let patt = Grammar.Entry.create gram "patt";; -let ctyp = Grammar.Entry.create gram "type";; -let let_binding = Grammar.Entry.create gram "let_binding";; -let type_declaration = Grammar.Entry.create gram "type_declaration";; - -let class_sig_item = Grammar.Entry.create gram "class_sig_item";; -let class_str_item = Grammar.Entry.create gram "class_str_item";; -let class_type = Grammar.Entry.create gram "class_type";; -let class_expr = Grammar.Entry.create gram "class_expr";; - -let parse_interf = ref (Grammar.Entry.parse interf);; -let parse_implem = ref (Grammar.Entry.parse implem);; - -let rec skip_to_eol cs = - match Stream.peek cs with - Some '\n' -> () - | Some c -> Stream.junk cs; skip_to_eol cs - | _ -> () -;; -let sync = ref skip_to_eol;; - -let input_file = ref "";; -let output_file = ref None;; - -let warning_default_function (bp, ep) txt = - Printf.eprintf " loc %d %d: %s\n" bp ep txt; flush stderr -;; - -let warning = ref warning_default_function;; - -let apply_with_var v x f = - let vx = !v in - try v := x; let r = f () in v := vx; r with - e -> v := vx; raise e -;; - -List.iter (fun (n, f) -> Quotation.add n f) - ["id", Quotation.ExStr (fun _ s -> "$0:" ^ s ^ "$"); - "string", Quotation.ExStr (fun _ s -> "\"" ^ String.escaped s ^ "\"")];; - -let quotation_dump_file = ref (None : string option);; - -type err_ctx = - Finding - | Expanding - | ParsingResult of (int * int) * string - | Locating -;; -exception Qerror of string * err_ctx * exn;; - -let expand_quotation loc expander shift name str = - let new_warning = - let warn = !warning in - fun (bp, ep) txt -> warn (shift + bp, shift + ep) txt - in - apply_with_var warning new_warning - (fun () -> - try expander str with - Stdpp.Exc_located ((p1, p2), exc) -> - let exc1 = Qerror (name, Expanding, exc) in - raise (Stdpp.Exc_located ((shift + p1, shift + p2), exc1)) - | exc -> - let exc1 = Qerror (name, Expanding, exc) in - raise (Stdpp.Exc_located (loc, exc1))) -;; - -let parse_quotation_result entry loc shift name str = - let cs = Stream.of_string str in - try Grammar.Entry.parse entry cs with - Stdpp.Exc_located (iloc, (Qerror (_, Locating, _) as exc)) -> - raise (Stdpp.Exc_located ((shift + fst iloc, shift + snd iloc), exc)) - | Stdpp.Exc_located (iloc, Qerror (_, Expanding, exc)) -> - let ctx = ParsingResult (iloc, str) in - let exc1 = Qerror (name, ctx, exc) in - raise (Stdpp.Exc_located (loc, exc1)) - | Stdpp.Exc_located (_, (Qerror (_, _, _) as exc)) -> - raise (Stdpp.Exc_located (loc, exc)) - | Stdpp.Exc_located (iloc, exc) -> - let ctx = ParsingResult (iloc, str) in - let exc1 = Qerror (name, ctx, exc) in - raise (Stdpp.Exc_located (loc, exc1)) -;; - -let handle_quotation loc proj in_expr entry reloc (name, str) = - let shift = - match name with - "" -> String.length "<<" - | _ -> String.length "<:" + String.length name + String.length "<" - in - let shift = fst loc + shift in - let expander = - try Quotation.find name with - exc -> - let exc1 = Qerror (name, Finding, exc) in - let loc = fst loc, shift in raise (Stdpp.Exc_located (loc, exc1)) - in - let ast = - match expander with - Quotation.ExStr f -> - let new_str = expand_quotation loc (f in_expr) shift name str in - parse_quotation_result entry loc shift name new_str - | Quotation.ExAst fe_fp -> - expand_quotation loc (proj fe_fp) shift name str - in - reloc (fun _ -> loc) shift ast -;; - -let parse_locate entry shift str = - let cs = Stream.of_string str in - try Grammar.Entry.parse entry cs with - Stdpp.Exc_located ((p1, p2), exc) -> - let ctx = Locating in - let exc1 = Qerror (Grammar.Entry.name entry, ctx, exc) in - raise (Stdpp.Exc_located ((shift + p1, shift + p2), exc1)) -;; - -let handle_locate loc entry ast_f (pos, str) = - let s = str in - let loc = pos, pos + String.length s in - let x = parse_locate entry (fst loc) s in ast_f loc x -;; - -let expr_anti loc e = MLast.ExAnt (loc, e);; -let patt_anti loc p = MLast.PaAnt (loc, p);; -let expr_eoi = Grammar.Entry.create gram "expression";; -let patt_eoi = Grammar.Entry.create gram "pattern";; -Grammar.extend - [Grammar.Entry.obj (expr_eoi : 'expr_eoi Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e)); - Gramext.Stoken ("EOI", "")], - Gramext.action - (fun _ (x : 'expr) (loc : int * int) -> (x : 'expr_eoi))]]; - Grammar.Entry.obj (patt_eoi : 'patt_eoi Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e)); - Gramext.Stoken ("EOI", "")], - Gramext.action - (fun _ (x : 'patt) (loc : int * int) -> (x : 'patt_eoi))]]];; - -let handle_expr_quotation loc x = - handle_quotation loc fst true expr_eoi Reloc.expr x -;; - -let handle_expr_locate loc x = handle_locate loc expr_eoi expr_anti x;; - -let handle_patt_quotation loc x = - handle_quotation loc snd false patt_eoi Reloc.patt x -;; - -let handle_patt_locate loc x = handle_locate loc patt_eoi patt_anti x;; - -let expr_reloc = Reloc.expr;; -let patt_reloc = Reloc.patt;; - -let rename_id = ref (fun x -> x);; - -let find_line (bp, ep) str = - let rec find i line col = - if i == String.length str then line, 0, col - else if i == bp then line, col, col + ep - bp - else if str.[i] == '\n' then find (succ i) (succ line) 0 - else find (succ i) line (succ col) - in - find 0 1 0 -;; - -let loc_fmt = - match Sys.os_type with - "MacOS" -> - format_of_string "File \"%s\"; line %d; characters %d to %d\n### " - | _ -> format_of_string "File \"%s\", line %d, characters %d-%d:\n" -;; - -let report_quotation_error name ctx = - let name = if name = "" then !(Quotation.default) else name in - Format.print_flush (); - Format.open_hovbox 2; - Printf.eprintf "While %s \"%s\":" - (match ctx with - Finding -> "finding quotation" - | Expanding -> "expanding quotation" - | ParsingResult (_, _) -> "parsing result of quotation" - | Locating -> "parsing") - name; - match ctx with - ParsingResult ((bp, ep), str) -> - begin match !quotation_dump_file with - Some dump_file -> - Printf.eprintf " dumping result...\n"; - flush stderr; - begin try - let (line, c1, c2) = find_line (bp, ep) str in - let oc = open_out_bin dump_file in - output_string oc str; - output_string oc "\n"; - flush oc; - close_out oc; - Printf.eprintf loc_fmt dump_file line c1 c2; - flush stderr - with - _ -> - Printf.eprintf "Error while dumping result in file \"%s\"" - dump_file; - Printf.eprintf "; dump aborted.\n"; - flush stderr - end - | None -> - if !input_file = "" then - Printf.eprintf - "\n(consider setting variable Pcaml.quotation_dump_file)\n" - else Printf.eprintf " (consider using option -QD)\n"; - flush stderr - end - | _ -> Printf.eprintf "\n"; flush stderr -;; - -let print_format str = - let rec flush ini cnt = - if cnt > ini then Format.print_string (String.sub str ini (cnt - ini)) - in - let rec loop ini cnt = - if cnt == String.length str then flush ini cnt - else - match str.[cnt] with - '\n' -> - flush ini cnt; - Format.close_box (); - Format.force_newline (); - Format.open_box 2; - loop (cnt + 1) (cnt + 1) - | ' ' -> flush ini cnt; Format.print_space (); loop (cnt + 1) (cnt + 1) - | _ -> loop ini (cnt + 1) - in - Format.open_box 2; loop 0 0; Format.close_box () -;; - -let print_file_failed file line char = - Format.print_string ", file \""; - Format.print_string file; - Format.print_string "\", line "; - Format.print_int line; - Format.print_string ", char "; - Format.print_int char -;; - -let print_exn = - function - Out_of_memory -> Format.print_string "Out of memory\n" - | Assert_failure (file, line, char) -> - Format.print_string "Assertion failed"; print_file_failed file line char - | Match_failure (file, line, char) -> - Format.print_string "Pattern matching failed"; - print_file_failed file line char - | Stream.Error str -> print_format ("Parse error: " ^ str) - | Stream.Failure -> Format.print_string "Parse failure" - | Token.Error str -> - Format.print_string "Lexing error: "; Format.print_string str - | Failure str -> Format.print_string "Failure: "; Format.print_string str - | Invalid_argument str -> - Format.print_string "Invalid argument: "; Format.print_string str - | Sys_error msg -> - Format.print_string "I/O error: "; Format.print_string msg - | x -> - Format.print_string "Uncaught exception: "; - Format.print_string - (Obj.magic (Obj.field (Obj.field (Obj.repr x) 0) 0)); - if Obj.size (Obj.repr x) > 1 then - begin - Format.print_string " ("; - for i = 1 to Obj.size (Obj.repr x) - 1 do - if i > 1 then Format.print_string ", "; - let arg = Obj.field (Obj.repr x) i in - if not (Obj.is_block arg) then - Format.print_int (Obj.magic arg : int) - else if Obj.tag arg = Obj.tag (Obj.repr "a") then - begin - Format.print_char '\"'; - Format.print_string (Obj.magic arg : string); - Format.print_char '\"' - end - else Format.print_char '_' - done; - Format.print_char ')' - end -;; - -let report_error exn = - match exn with - Qerror (name, Finding, Not_found) -> - let name = if name = "" then !(Quotation.default) else name in - Format.print_flush (); - Format.open_hovbox 2; - Format.printf "Unbound quotation: \"%s\"" name; - Format.close_box () - | Qerror (name, ctx, exn) -> report_quotation_error name ctx; print_exn exn - | e -> print_exn exn -;; - -let no_constructors_arity = Ast2pt.no_constructors_arity;; -(*value no_assert = ref False;*) - -let arg_spec_list_ref = ref [];; -let arg_spec_list () = !arg_spec_list_ref;; -let add_option name spec descr = - arg_spec_list_ref := !arg_spec_list_ref @ [name, spec, descr] -;; - -(* Printers *) - -open Spretty;; - -type 'a printer_t = - { mutable pr_fun : string -> 'a -> string -> kont -> pretty; - mutable pr_levels : 'a pr_level list } -and 'a pr_level = - { pr_label : string; - pr_box : 'a -> pretty Stream.t -> pretty; - mutable pr_rules : 'a pr_rule } -and 'a pr_rule = - ('a, ('a curr -> 'a next -> string -> kont -> pretty Stream.t)) Extfun.t -and 'a curr = 'a -> string -> kont -> pretty Stream.t -and 'a next = 'a -> string -> kont -> pretty -and kont = pretty Stream.t -;; - -let pr_str_item = - {pr_fun = (fun _ -> raise (Match_failure ("pcaml.ml", 385, 30))); - pr_levels = []} -;; -let pr_sig_item = - {pr_fun = (fun _ -> raise (Match_failure ("pcaml.ml", 386, 30))); - pr_levels = []} -;; -let pr_module_type = - {pr_fun = (fun _ -> raise (Match_failure ("pcaml.ml", 387, 33))); - pr_levels = []} -;; -let pr_module_expr = - {pr_fun = (fun _ -> raise (Match_failure ("pcaml.ml", 388, 33))); - pr_levels = []} -;; -let pr_expr = - {pr_fun = (fun _ -> raise (Match_failure ("pcaml.ml", 389, 26))); - pr_levels = []} -;; -let pr_patt = - {pr_fun = (fun _ -> raise (Match_failure ("pcaml.ml", 390, 26))); - pr_levels = []} -;; -let pr_ctyp = - {pr_fun = (fun _ -> raise (Match_failure ("pcaml.ml", 391, 26))); - pr_levels = []} -;; -let pr_class_sig_item = - {pr_fun = (fun _ -> raise (Match_failure ("pcaml.ml", 392, 36))); - pr_levels = []} -;; -let pr_class_str_item = - {pr_fun = (fun _ -> raise (Match_failure ("pcaml.ml", 393, 36))); - pr_levels = []} -;; -let pr_class_type = - {pr_fun = (fun _ -> raise (Match_failure ("pcaml.ml", 394, 32))); - pr_levels = []} -;; -let pr_class_expr = - {pr_fun = (fun _ -> raise (Match_failure ("pcaml.ml", 395, 32))); - pr_levels = []} -;; -let pr_expr_fun_args = ref Extfun.empty;; - -let pr_fun name pr lab = - let rec loop app = - function - [] -> (fun x dg k -> failwith ("unable to print " ^ name)) - | lev :: levl -> - if app || lev.pr_label = lab then - let next = loop true levl in - let rec curr x dg k = Extfun.apply lev.pr_rules x curr next dg k in - fun x dg k -> lev.pr_box x (curr x dg k) - else loop app levl - in - loop false pr.pr_levels -;; - -pr_str_item.pr_fun <- pr_fun "str_item" pr_str_item;; -pr_sig_item.pr_fun <- pr_fun "sig_item" pr_sig_item;; -pr_module_type.pr_fun <- pr_fun "module_type" pr_module_type;; -pr_module_expr.pr_fun <- pr_fun "module_expr" pr_module_expr;; -pr_expr.pr_fun <- pr_fun "expr" pr_expr;; -pr_patt.pr_fun <- pr_fun "patt" pr_patt;; -pr_ctyp.pr_fun <- pr_fun "ctyp" pr_ctyp;; -pr_class_sig_item.pr_fun <- pr_fun "class_sig_item" pr_class_sig_item;; -pr_class_str_item.pr_fun <- pr_fun "class_str_item" pr_class_str_item;; -pr_class_type.pr_fun <- pr_fun "class_type" pr_class_type;; -pr_class_expr.pr_fun <- pr_fun "class_expr" pr_class_expr;; - -let rec find_pr_level lab = - function - [] -> failwith ("level " ^ lab ^ " not found") - | lev :: levl -> if lev.pr_label = lab then lev else find_pr_level lab levl -;; - -let undef x = ref (fun _ -> failwith x);; -let print_interf = undef "no printer";; -let print_implem = undef "no printer";; - -let top_printer pr x = - Format.force_newline (); - Spretty.print_pretty Format.print_char Format.print_string - Format.print_newline "<< " " " 78 (fun _ _ -> "", 0, 0, 0) 0 - (pr.pr_fun "top" x "" Stream.sempty); - Format.print_string " >>" -;; - -let buff = Buffer.create 73;; -let buffer_char = Buffer.add_char buff;; -let buffer_string = Buffer.add_string buff;; -let buffer_newline () = Buffer.add_char buff '\n';; - -let string_of pr x = - Buffer.clear buff; - Spretty.print_pretty buffer_char buffer_string buffer_newline "" "" 78 - (fun _ _ -> "", 0, 0, 0) 0 (pr.pr_fun "top" x "" Stream.sempty); - Buffer.contents buff -;; - -let inter_phrases = ref None;; diff --git a/camlp4/ocaml_src/camlp4/pcaml.mli b/camlp4/ocaml_src/camlp4/pcaml.mli deleted file mode 100644 index 8f8eacaf24..0000000000 --- a/camlp4/ocaml_src/camlp4/pcaml.mli +++ /dev/null @@ -1,158 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2001 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* This file has been generated by program: do not edit! *) - -(** Language grammar, entries and printers. - - Hold variables to be set by language syntax extensions. Some of them - are provided for quotations management. *) - -val syntax_name : string ref;; - -(** {6 Parsers} *) - -val parse_interf : - (char Stream.t -> (MLast.sig_item * MLast.loc) list * bool) ref;; -val parse_implem : - (char Stream.t -> (MLast.str_item * MLast.loc) list * bool) ref;; - (** Called when parsing an interface (mli file) or an implementation - (ml file) to build the syntax tree; the returned list contains the - phrases (signature items or structure items) and their locations; - the boolean tells that the parser has encountered a directive; in - this case, since the directive may change the syntax, the parsing - stops, the directive is evaluated, and this function is called - again. - These functions are references, because they can be changed to - use another technology than the Camlp4 extended grammars. By - default, they use the grammars entries [implem] and [interf] - defined below. *) - -val gram : Grammar.g;; - (** Grammar variable of the OCaml language *) - -val interf : ((MLast.sig_item * MLast.loc) list * bool) Grammar.Entry.e;; -val implem : ((MLast.str_item * MLast.loc) list * bool) Grammar.Entry.e;; -val top_phrase : MLast.str_item option Grammar.Entry.e;; -val use_file : (MLast.str_item list * bool) Grammar.Entry.e;; -val module_type : MLast.module_type Grammar.Entry.e;; -val module_expr : MLast.module_expr Grammar.Entry.e;; -val sig_item : MLast.sig_item Grammar.Entry.e;; -val str_item : MLast.str_item Grammar.Entry.e;; -val expr : MLast.expr Grammar.Entry.e;; -val patt : MLast.patt Grammar.Entry.e;; -val ctyp : MLast.ctyp Grammar.Entry.e;; -val let_binding : (MLast.patt * MLast.expr) Grammar.Entry.e;; -val type_declaration : MLast.type_decl Grammar.Entry.e;; -val class_sig_item : MLast.class_sig_item Grammar.Entry.e;; -val class_str_item : MLast.class_str_item Grammar.Entry.e;; -val class_expr : MLast.class_expr Grammar.Entry.e;; -val class_type : MLast.class_type Grammar.Entry.e;; - (** Some entries of the language, set by [pa_o.cmo] and [pa_r.cmo]. *) - -val input_file : string ref;; - (** The file currently being parsed. *) -val output_file : string option ref;; - (** The output file, stdout if None (default) *) -val report_error : exn -> unit;; - (** Prints an error message, using the module [Format]. *) -val quotation_dump_file : string option ref;; - (** [quotation_dump_file] optionally tells the compiler to dump the - result of an expander if this result is syntactically incorrect. - If [None] (default), this result is not dumped. If [Some fname], the - result is dumped in the file [fname]. *) -val version : string;; - (** The current version of Camlp4. *) -val add_option : string -> Arg.spec -> string -> unit;; - (** Add an option to the command line options. *) -val no_constructors_arity : bool ref;; - (** [True]: dont generate constructor arity. *) -(*value no_assert : ref bool; - (** [True]: dont generate assertion checks. *) -*) - -val sync : (char Stream.t -> unit) ref;; - -val handle_expr_quotation : MLast.loc -> string * string -> MLast.expr;; -val handle_expr_locate : MLast.loc -> int * string -> MLast.expr;; - -val handle_patt_quotation : MLast.loc -> string * string -> MLast.patt;; -val handle_patt_locate : MLast.loc -> int * string -> MLast.patt;; - -val expr_reloc : (MLast.loc -> MLast.loc) -> int -> MLast.expr -> MLast.expr;; -val patt_reloc : (MLast.loc -> MLast.loc) -> int -> MLast.patt -> MLast.patt;; - -(** To possibly rename identifiers; parsers may call this function - when generating their identifiers; default = identity *) -val rename_id : (string -> string) ref;; - -(** Allow user to catch exceptions in quotations *) -type err_ctx = - Finding - | Expanding - | ParsingResult of (int * int) * string - | Locating -;; -exception Qerror of string * err_ctx * exn;; - -(** {6 Printers} *) - -open Spretty;; - -val print_interf : ((MLast.sig_item * MLast.loc) list -> unit) ref;; -val print_implem : ((MLast.str_item * MLast.loc) list -> unit) ref;; - (** Some printers, set by [pr_dump.cmo], [pr_o.cmo] and [pr_r.cmo]. *) - -type 'a printer_t = - { mutable pr_fun : string -> 'a -> string -> kont -> pretty; - mutable pr_levels : 'a pr_level list } -and 'a pr_level = - { pr_label : string; - pr_box : 'a -> pretty Stream.t -> pretty; - mutable pr_rules : 'a pr_rule } -and 'a pr_rule = - ('a, ('a curr -> 'a next -> string -> kont -> pretty Stream.t)) Extfun.t -and 'a curr = 'a -> string -> kont -> pretty Stream.t -and 'a next = 'a -> string -> kont -> pretty -and kont = pretty Stream.t -;; - -val pr_sig_item : MLast.sig_item printer_t;; -val pr_str_item : MLast.str_item printer_t;; -val pr_module_type : MLast.module_type printer_t;; -val pr_module_expr : MLast.module_expr printer_t;; -val pr_expr : MLast.expr printer_t;; -val pr_patt : MLast.patt printer_t;; -val pr_ctyp : MLast.ctyp printer_t;; -val pr_class_sig_item : MLast.class_sig_item printer_t;; -val pr_class_str_item : MLast.class_str_item printer_t;; -val pr_class_type : MLast.class_type printer_t;; -val pr_class_expr : MLast.class_expr printer_t;; - -val pr_expr_fun_args : - (MLast.expr, (MLast.patt list * MLast.expr)) Extfun.t ref;; - -val find_pr_level : string -> 'a pr_level list -> 'a pr_level;; - -val top_printer : 'a printer_t -> 'a -> unit;; -val string_of : 'a printer_t -> 'a -> string;; - -val inter_phrases : string option ref;; - -(**/**) - -(* for system use *) - -val warning : (int * int -> string -> unit) ref;; -val expr_eoi : MLast.expr Grammar.Entry.e;; -val patt_eoi : MLast.patt Grammar.Entry.e;; -val arg_spec_list : unit -> (string * Arg.spec * string) list;; diff --git a/camlp4/ocaml_src/camlp4/quotation.ml b/camlp4/ocaml_src/camlp4/quotation.ml deleted file mode 100644 index 07057c968b..0000000000 --- a/camlp4/ocaml_src/camlp4/quotation.ml +++ /dev/null @@ -1,33 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* This file has been generated by program: do not edit! *) - -type expander = - ExStr of (bool -> string -> string) - | ExAst of ((string -> MLast.expr) * (string -> MLast.patt)) -;; - -let expanders_table = ref [];; - -let default = ref "";; -let translate = ref (fun x -> x);; - -let expander_name name = - match !translate name with - "" -> !default - | name -> name -;; - -let find name = List.assoc (expander_name name) !expanders_table;; - -let add name f = expanders_table := (name, f) :: !expanders_table;; diff --git a/camlp4/ocaml_src/camlp4/quotation.mli b/camlp4/ocaml_src/camlp4/quotation.mli deleted file mode 100644 index aba963d705..0000000000 --- a/camlp4/ocaml_src/camlp4/quotation.mli +++ /dev/null @@ -1,48 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1998 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* This file has been generated by program: do not edit! *) - -(** Quotation operations. *) - -type expander = - ExStr of (bool -> string -> string) - | ExAst of ((string -> MLast.expr) * (string -> MLast.patt)) -;; - -(** The type for quotation expanders kind: -- [ExStr exp] for an expander [exp] returning a string which - can be parsed to create a syntax tree. Its boolean parameter - tells whether the quotation is in position of an expression - (True) or in position of a pattern (False). Quotations expanders - created with this way may work for some particular language syntax, - and not for another one (e.g. may work when used with Revised - syntax and not when used with Ocaml syntax, and conversely). -- [ExAst (expr_exp, patt_exp)] for expanders returning directly - syntax trees, therefore not necessiting to be parsed afterwards. - The function [expr_exp] is called when the quotation is in - position of an expression, and [patt_exp] when the quotation is - in position of a pattern. Quotation expanders created with this - way are independant from the language syntax. *) - -val add : string -> expander -> unit;; - (** [add name exp] adds the quotation [name] associated with the - expander [exp]. *) - -val find : string -> expander;; - (** [find name] returns the expander of the given quotation name. *) - -val default : string ref;; - (** [default] holds the default quotation name. *) - -val translate : (string -> string) ref;; - (** function translating quotation names; default = identity *) diff --git a/camlp4/ocaml_src/camlp4/reloc.ml b/camlp4/ocaml_src/camlp4/reloc.ml deleted file mode 100644 index 980d6ce786..0000000000 --- a/camlp4/ocaml_src/camlp4/reloc.ml +++ /dev/null @@ -1,337 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1998 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* This file has been generated by program: do not edit! *) - -open MLast;; - -let option_map f = - function - Some x -> Some (f x) - | None -> None -;; - -let rec ctyp floc sh = - let rec self = - function - TyAcc (loc, x1, x2) -> TyAcc (floc loc, self x1, self x2) - | TyAli (loc, x1, x2) -> TyAli (floc loc, self x1, self x2) - | TyAny loc -> TyAny (floc loc) - | TyApp (loc, x1, x2) -> TyApp (floc loc, self x1, self x2) - | TyArr (loc, x1, x2) -> TyArr (floc loc, self x1, self x2) - | TyCls (loc, x1) -> TyCls (floc loc, x1) - | TyLab (loc, x1, x2) -> TyLab (floc loc, x1, self x2) - | TyLid (loc, x1) -> TyLid (floc loc, x1) - | TyMan (loc, x1, x2) -> TyMan (floc loc, self x1, self x2) - | TyObj (loc, x1, x2) -> - TyObj (floc loc, List.map (fun (x1, x2) -> x1, self x2) x1, x2) - | TyOlb (loc, x1, x2) -> TyOlb (floc loc, x1, self x2) - | TyPol (loc, x1, x2) -> TyPol (floc loc, x1, self x2) - | TyQuo (loc, x1) -> TyQuo (floc loc, x1) - | TyRec (loc, pflag, x1) -> - TyRec - (floc loc, pflag, - List.map (fun (loc, x1, x2, x3) -> floc loc, x1, x2, self x3) x1) - | TySum (loc, pflag, x1) -> - TySum - (floc loc, pflag, - List.map (fun (loc, x1, x2) -> floc loc, x1, List.map self x2) x1) - | TyTup (loc, x1) -> TyTup (floc loc, List.map self x1) - | TyUid (loc, x1) -> TyUid (floc loc, x1) - | TyVrn (loc, x1, x2) -> - TyVrn (floc loc, List.map (row_field floc sh) x1, x2) - in - self -and row_field floc sh = - function - RfTag (x1, x2, x3) -> RfTag (x1, x2, List.map (ctyp floc sh) x3) - | RfInh x1 -> RfInh (ctyp floc sh x1) -;; - -let class_infos a floc sh x = - {ciLoc = floc x.ciLoc; ciVir = x.ciVir; - ciPrm = begin let (x1, x2) = x.ciPrm in floc x1, x2 end; ciNam = x.ciNam; - ciExp = a floc sh x.ciExp} -;; - -let rec patt floc sh = - let rec self = - function - PaAcc (loc, x1, x2) -> PaAcc (floc loc, self x1, self x2) - | PaAli (loc, x1, x2) -> PaAli (floc loc, self x1, self x2) - | PaAnt (loc, x1) -> - patt (fun (p1, p2) -> sh + fst loc + p1, sh + fst loc + p2) 0 x1 - | PaAny loc -> PaAny (floc loc) - | PaApp (loc, x1, x2) -> PaApp (floc loc, self x1, self x2) - | PaArr (loc, x1) -> PaArr (floc loc, List.map self x1) - | PaChr (loc, x1) -> PaChr (floc loc, x1) - | PaInt (loc, x1) -> PaInt (floc loc, x1) - | PaInt32 (loc, x1) -> PaInt32 (floc loc, x1) - | PaInt64 (loc, x1) -> PaInt64 (floc loc, x1) - | PaNativeInt (loc, x1) -> PaNativeInt (floc loc, x1) - | PaFlo (loc, x1) -> PaFlo (floc loc, x1) - | PaLab (loc, x1, x2) -> PaLab (floc loc, x1, option_map self x2) - | PaLid (loc, x1) -> PaLid (floc loc, x1) - | PaOlb (loc, x1, x2) -> - PaOlb - (floc loc, x1, - option_map (fun (x1, x2) -> self x1, option_map (expr floc sh) x2) - x2) - | PaOrp (loc, x1, x2) -> PaOrp (floc loc, self x1, self x2) - | PaRng (loc, x1, x2) -> PaRng (floc loc, self x1, self x2) - | PaRec (loc, x1) -> - PaRec (floc loc, List.map (fun (x1, x2) -> self x1, self x2) x1) - | PaStr (loc, x1) -> PaStr (floc loc, x1) - | PaTup (loc, x1) -> PaTup (floc loc, List.map self x1) - | PaTyc (loc, x1, x2) -> PaTyc (floc loc, self x1, ctyp floc sh x2) - | PaTyp (loc, x1) -> PaTyp (floc loc, x1) - | PaUid (loc, x1) -> PaUid (floc loc, x1) - | PaVrn (loc, x1) -> PaVrn (floc loc, x1) - in - self -and expr floc sh = - let rec self = - function - ExAcc (loc, x1, x2) -> ExAcc (floc loc, self x1, self x2) - | ExAnt (loc, x1) -> - expr (fun (p1, p2) -> sh + fst loc + p1, sh + fst loc + p2) 0 x1 - | ExApp (loc, x1, x2) -> ExApp (floc loc, self x1, self x2) - | ExAre (loc, x1, x2) -> ExAre (floc loc, self x1, self x2) - | ExArr (loc, x1) -> ExArr (floc loc, List.map self x1) - | ExAsf loc -> ExAsf (floc loc) - | ExAsr (loc, x1) -> ExAsr (floc loc, self x1) - | ExAss (loc, x1, x2) -> ExAss (floc loc, self x1, self x2) - | ExChr (loc, x1) -> ExChr (floc loc, x1) - | ExCoe (loc, x1, x2, x3) -> - ExCoe - (floc loc, self x1, option_map (ctyp floc sh) x2, ctyp floc sh x3) - | ExFlo (loc, x1) -> ExFlo (floc loc, x1) - | ExFor (loc, x1, x2, x3, x4, x5) -> - ExFor (floc loc, x1, self x2, self x3, x4, List.map self x5) - | ExFun (loc, x1) -> - ExFun - (floc loc, - List.map - (fun (x1, x2, x3) -> - patt floc sh x1, option_map self x2, self x3) - x1) - | ExIfe (loc, x1, x2, x3) -> ExIfe (floc loc, self x1, self x2, self x3) - | ExInt (loc, x1) -> ExInt (floc loc, x1) - | ExInt32 (loc, x1) -> ExInt32 (floc loc, x1) - | ExInt64 (loc, x1) -> ExInt64 (floc loc, x1) - | ExNativeInt (loc, x1) -> ExNativeInt (floc loc, x1) - | ExLab (loc, x1, x2) -> ExLab (floc loc, x1, option_map self x2) - | ExLaz (loc, x1) -> ExLaz (floc loc, self x1) - | ExLet (loc, x1, x2, x3) -> - ExLet - (floc loc, x1, - List.map (fun (x1, x2) -> patt floc sh x1, self x2) x2, self x3) - | ExLid (loc, x1) -> ExLid (floc loc, x1) - | ExLmd (loc, x1, x2, x3) -> - ExLmd (floc loc, x1, module_expr floc sh x2, self x3) - | ExMat (loc, x1, x2) -> - ExMat - (floc loc, self x1, - List.map - (fun (x1, x2, x3) -> - patt floc sh x1, option_map self x2, self x3) - x2) - | ExNew (loc, x1) -> ExNew (floc loc, x1) - | ExOlb (loc, x1, x2) -> ExOlb (floc loc, x1, option_map self x2) - | ExOvr (loc, x1) -> - ExOvr (floc loc, List.map (fun (x1, x2) -> x1, self x2) x1) - | ExRec (loc, x1, x2) -> - ExRec - (floc loc, List.map (fun (x1, x2) -> patt floc sh x1, self x2) x1, - option_map self x2) - | ExSeq (loc, x1) -> ExSeq (floc loc, List.map self x1) - | ExSnd (loc, x1, x2) -> ExSnd (floc loc, self x1, x2) - | ExSte (loc, x1, x2) -> ExSte (floc loc, self x1, self x2) - | ExStr (loc, x1) -> ExStr (floc loc, x1) - | ExTry (loc, x1, x2) -> - ExTry - (floc loc, self x1, - List.map - (fun (x1, x2, x3) -> - patt floc sh x1, option_map self x2, self x3) - x2) - | ExTup (loc, x1) -> ExTup (floc loc, List.map self x1) - | ExTyc (loc, x1, x2) -> ExTyc (floc loc, self x1, ctyp floc sh x2) - | ExUid (loc, x1) -> ExUid (floc loc, x1) - | ExVrn (loc, x1) -> ExVrn (floc loc, x1) - | ExWhi (loc, x1, x2) -> ExWhi (floc loc, self x1, List.map self x2) - in - self -and module_type floc sh = - let rec self = - function - MtAcc (loc, x1, x2) -> MtAcc (floc loc, self x1, self x2) - | MtApp (loc, x1, x2) -> MtApp (floc loc, self x1, self x2) - | MtFun (loc, x1, x2, x3) -> MtFun (floc loc, x1, self x2, self x3) - | MtLid (loc, x1) -> MtLid (floc loc, x1) - | MtQuo (loc, x1) -> MtQuo (floc loc, x1) - | MtSig (loc, x1) -> MtSig (floc loc, List.map (sig_item floc sh) x1) - | MtUid (loc, x1) -> MtUid (floc loc, x1) - | MtWit (loc, x1, x2) -> - MtWit (floc loc, self x1, List.map (with_constr floc sh) x2) - in - self -and sig_item floc sh = - let rec self = - function - SgCls (loc, x1) -> - SgCls (floc loc, List.map (class_infos class_type floc sh) x1) - | SgClt (loc, x1) -> - SgClt (floc loc, List.map (class_infos class_type floc sh) x1) - | SgDcl (loc, x1) -> SgDcl (floc loc, List.map self x1) - | SgDir (loc, x1, x2) -> SgDir (floc loc, x1, x2) - | SgExc (loc, x1, x2) -> SgExc (floc loc, x1, List.map (ctyp floc sh) x2) - | SgExt (loc, x1, x2, x3) -> SgExt (floc loc, x1, ctyp floc sh x2, x3) - | SgInc (loc, x1) -> SgInc (floc loc, module_type floc sh x1) - | SgMod (loc, x1, x2) -> SgMod (floc loc, x1, module_type floc sh x2) - | SgRecMod (loc, xxs) -> - SgRecMod - (floc loc, - List.map (fun (x1, x2) -> x1, module_type floc sh x2) xxs) - | SgMty (loc, x1, x2) -> SgMty (floc loc, x1, module_type floc sh x2) - | SgOpn (loc, x1) -> SgOpn (floc loc, x1) - | SgTyp (loc, x1) -> - SgTyp - (floc loc, - List.map - (fun ((loc, x1), x2, x3, x4) -> - (floc loc, x1), x2, ctyp floc sh x3, - List.map (fun (x1, x2) -> ctyp floc sh x1, ctyp floc sh x2) - x4) - x1) - | SgUse (loc, x1, x2) -> SgUse (loc, x1, x2) - | SgVal (loc, x1, x2) -> SgVal (floc loc, x1, ctyp floc sh x2) - in - self -and with_constr floc sh = - let rec self = - function - WcTyp (loc, x1, x2, x3) -> WcTyp (floc loc, x1, x2, ctyp floc sh x3) - | WcMod (loc, x1, x2) -> WcMod (floc loc, x1, module_expr floc sh x2) - in - self -and module_expr floc sh = - let rec self = - function - MeAcc (loc, x1, x2) -> MeAcc (floc loc, self x1, self x2) - | MeApp (loc, x1, x2) -> MeApp (floc loc, self x1, self x2) - | MeFun (loc, x1, x2, x3) -> - MeFun (floc loc, x1, module_type floc sh x2, self x3) - | MeStr (loc, x1) -> MeStr (floc loc, List.map (str_item floc sh) x1) - | MeTyc (loc, x1, x2) -> MeTyc (floc loc, self x1, module_type floc sh x2) - | MeUid (loc, x1) -> MeUid (floc loc, x1) - in - self -and str_item floc sh = - let rec self = - function - StCls (loc, x1) -> - StCls (floc loc, List.map (class_infos class_expr floc sh) x1) - | StClt (loc, x1) -> - StClt (floc loc, List.map (class_infos class_type floc sh) x1) - | StDcl (loc, x1) -> StDcl (floc loc, List.map self x1) - | StDir (loc, x1, x2) -> StDir (floc loc, x1, x2) - | StExc (loc, x1, x2, x3) -> - StExc (floc loc, x1, List.map (ctyp floc sh) x2, x3) - | StExp (loc, x1) -> StExp (floc loc, expr floc sh x1) - | StExt (loc, x1, x2, x3) -> StExt (floc loc, x1, ctyp floc sh x2, x3) - | StInc (loc, x1) -> StInc (floc loc, module_expr floc sh x1) - | StMod (loc, x1, x2) -> StMod (floc loc, x1, module_expr floc sh x2) - | StRecMod (loc, nmtmes) -> - StRecMod - (floc loc, - List.map - (fun (n, mt, me) -> - n, module_type floc sh mt, module_expr floc sh me) - nmtmes) - | StMty (loc, x1, x2) -> StMty (floc loc, x1, module_type floc sh x2) - | StOpn (loc, x1) -> StOpn (floc loc, x1) - | StTyp (loc, x1) -> - StTyp - (floc loc, - List.map - (fun ((loc, x1), x2, x3, x4) -> - (floc loc, x1), x2, ctyp floc sh x3, - List.map (fun (x1, x2) -> ctyp floc sh x1, ctyp floc sh x2) - x4) - x1) - | StUse (loc, x1, x2) -> StUse (loc, x1, x2) - | StVal (loc, x1, x2) -> - StVal - (floc loc, x1, - List.map (fun (x1, x2) -> patt floc sh x1, expr floc sh x2) x2) - in - self -and class_type floc sh = - let rec self = - function - CtCon (loc, x1, x2) -> CtCon (floc loc, x1, List.map (ctyp floc sh) x2) - | CtFun (loc, x1, x2) -> CtFun (floc loc, ctyp floc sh x1, self x2) - | CtSig (loc, x1, x2) -> - CtSig - (floc loc, option_map (ctyp floc sh) x1, - List.map (class_sig_item floc sh) x2) - in - self -and class_sig_item floc sh = - let rec self = - function - CgCtr (loc, x1, x2) -> - CgCtr (floc loc, ctyp floc sh x1, ctyp floc sh x2) - | CgDcl (loc, x1) -> - CgDcl (floc loc, List.map (class_sig_item floc sh) x1) - | CgInh (loc, x1) -> CgInh (floc loc, class_type floc sh x1) - | CgMth (loc, x1, x2, x3) -> CgMth (floc loc, x1, x2, ctyp floc sh x3) - | CgVal (loc, x1, x2, x3) -> CgVal (floc loc, x1, x2, ctyp floc sh x3) - | CgVir (loc, x1, x2, x3) -> CgVir (floc loc, x1, x2, ctyp floc sh x3) - in - self -and class_expr floc sh = - let rec self = - function - CeApp (loc, x1, x2) -> CeApp (floc loc, self x1, expr floc sh x2) - | CeCon (loc, x1, x2) -> CeCon (floc loc, x1, List.map (ctyp floc sh) x2) - | CeFun (loc, x1, x2) -> CeFun (floc loc, patt floc sh x1, self x2) - | CeLet (loc, x1, x2, x3) -> - CeLet - (floc loc, x1, - List.map (fun (x1, x2) -> patt floc sh x1, expr floc sh x2) x2, - self x3) - | CeStr (loc, x1, x2) -> - CeStr - (floc loc, option_map (patt floc sh) x1, - List.map (class_str_item floc sh) x2) - | CeTyc (loc, x1, x2) -> CeTyc (floc loc, self x1, class_type floc sh x2) - in - self -and class_str_item floc sh = - let rec self = - function - CrCtr (loc, x1, x2) -> - CrCtr (floc loc, ctyp floc sh x1, ctyp floc sh x2) - | CrDcl (loc, x1) -> - CrDcl (floc loc, List.map (class_str_item floc sh) x1) - | CrInh (loc, x1, x2) -> CrInh (floc loc, class_expr floc sh x1, x2) - | CrIni (loc, x1) -> CrIni (floc loc, expr floc sh x1) - | CrMth (loc, x1, x2, x3, x4) -> - CrMth - (floc loc, x1, x2, expr floc sh x3, option_map (ctyp floc sh) x4) - | CrVal (loc, x1, x2, x3) -> CrVal (floc loc, x1, x2, expr floc sh x3) - | CrVir (loc, x1, x2, x3) -> CrVir (floc loc, x1, x2, ctyp floc sh x3) - in - self -;; diff --git a/camlp4/ocaml_src/camlp4/reloc.mli b/camlp4/ocaml_src/camlp4/reloc.mli deleted file mode 100644 index 21018b52af..0000000000 --- a/camlp4/ocaml_src/camlp4/reloc.mli +++ /dev/null @@ -1,16 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1998 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* This file has been generated by program: do not edit! *) - -val patt : (MLast.loc -> MLast.loc) -> int -> MLast.patt -> MLast.patt;; -val expr : (MLast.loc -> MLast.loc) -> int -> MLast.expr -> MLast.expr;; diff --git a/camlp4/ocaml_src/camlp4/spretty.ml b/camlp4/ocaml_src/camlp4/spretty.ml deleted file mode 100644 index ada592b604..0000000000 --- a/camlp4/ocaml_src/camlp4/spretty.ml +++ /dev/null @@ -1,465 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* This file has been generated by program: do not edit! *) - -type glue = - LO - | RO - | LR - | NO -;; -type pretty = - S of glue * string - | Hbox of pretty Stream.t - | HVbox of pretty Stream.t - | HOVbox of pretty Stream.t - | HOVCbox of pretty Stream.t - | Vbox of pretty Stream.t - | BEbox of pretty Stream.t - | BEVbox of pretty Stream.t - | LocInfo of (int * int) * pretty -;; -type prettyL = - SL of int * glue * string - | HL of prettyL list - | BL of prettyL list - | PL of prettyL list - | QL of prettyL list - | VL of prettyL list - | BE of prettyL list - | BV of prettyL list - | LI of (string * int * int) * prettyL -;; -type getcomm = int -> int -> string * int * int * int;; - -let quiet = ref true;; -let maxl = ref 20;; -let dt = ref 2;; -let tol = ref 1;; -let sp = ref ' ';; -let last_ep = ref 0;; -let getcomm = ref (fun _ _ -> "", 0, 0, 0);; -let prompt = ref "";; -let print_char_fun = ref (output_char stdout);; -let print_string_fun = ref (output_string stdout);; -let print_newline_fun = ref (fun () -> output_char stdout '\n');; -let lazy_tab = ref (-1);; - -let flush_tab () = - if !lazy_tab >= 0 then - begin - !print_newline_fun (); - !print_string_fun !prompt; - for i = 1 to !lazy_tab do !print_char_fun !sp done; - lazy_tab := -1 - end -;; -let print_newline_and_tab tab = lazy_tab := tab;; -let print_char c = flush_tab (); !print_char_fun c;; -let print_string s = flush_tab (); !print_string_fun s;; - -let rec print_spaces nsp = for i = 1 to nsp do print_char !sp done;; - -let end_with_tab s = - let rec loop i = - if i >= 0 then if s.[i] = ' ' then loop (i - 1) else s.[i] = '\n' - else false - in - loop (String.length s - 1) -;; - -let print_comment tab s nl_bef tab_bef empty_stmt = - if s = "" then () - else - let (tab_aft, i_bef_tab) = - let rec loop tab_aft i = - if i >= 0 && s.[i] = ' ' then loop (tab_aft + 1) (i - 1) - else tab_aft, i - in - loop 0 (String.length s - 1) - in - let tab_bef = if nl_bef > 0 then tab_bef else tab in - let len = if empty_stmt then i_bef_tab else String.length s in - let rec loop i = - if i = len then () - else - begin - !print_char_fun s.[i]; - let i = - if s.[i] = '\n' && (i + 1 = len || s.[i + 1] <> '\n') then - let delta_ind = - if i = i_bef_tab then tab - tab_aft else tab - tab_bef - in - if delta_ind >= 0 then - begin - for i = 1 to delta_ind do !print_char_fun ' ' done; i + 1 - end - else - let rec loop cnt i = - if cnt = 0 then i - else if i = len then i - else if s.[i] = ' ' then loop (cnt + 1) (i + 1) - else i - in - loop delta_ind (i + 1) - else i + 1 - in - loop i - end - in - loop 0 -;; - -let string_np pos np = pos + np;; - -let trace_ov pos = - if not !quiet && pos > !maxl then - begin - prerr_string " prettych: overflow (length = "; - prerr_int pos; - prerr_endline ")" - end -;; - -let tolerate tab pos spc = pos + spc <= tab + !dt + !tol;; - -let h_print_string pos spc np x = - let npos = string_np (pos + spc) np in - print_spaces spc; print_string x; npos -;; - -let n_print_string pos spc np x = - print_spaces spc; print_string x; string_np (pos + spc) np -;; - -let rec hnps (pos, spc as ps) = - function - SL (np, RO, _) -> string_np pos np, 1 - | SL (np, LO, _) -> string_np (pos + spc) np, 0 - | SL (np, NO, _) -> string_np pos np, 0 - | SL (np, LR, _) -> string_np (pos + spc) np, 1 - | HL x -> hnps_list ps x - | BL x -> hnps_list ps x - | PL x -> hnps_list ps x - | QL x -> hnps_list ps x - | VL [x] -> hnps ps x - | VL [] -> ps - | VL x -> !maxl + 1, 0 - | BE x -> hnps_list ps x - | BV x -> !maxl + 1, 0 - | LI (_, x) -> hnps ps x -and hnps_list (pos, _ as ps) pl = - if pos > !maxl then !maxl + 1, 0 - else - match pl with - p :: pl -> hnps_list (hnps ps p) pl - | [] -> ps -;; - -let rec first = - function - SL (_, _, s) -> Some s - | HL x -> first_in_list x - | BL x -> first_in_list x - | PL x -> first_in_list x - | QL x -> first_in_list x - | VL x -> first_in_list x - | BE x -> first_in_list x - | BV x -> first_in_list x - | LI (_, x) -> first x -and first_in_list = - function - p :: pl -> - begin match first p with - Some p -> Some p - | None -> first_in_list pl - end - | [] -> None -;; - -let first_is_too_big tab p = - match first p with - Some s -> tab + String.length s >= !maxl - | None -> false -;; - -let too_long tab x p = - if first_is_too_big tab p then false - else let (pos, spc) = hnps x p in pos > !maxl -;; - -let rec has_comment = - function - LI ((comm, nl_bef, tab_bef), x) :: pl -> - comm <> "" || has_comment (x :: pl) - | (HL x | BL x | PL x | QL x | VL x | BE x | BV x) :: pl -> - has_comment x || has_comment pl - | SL (_, _, _) :: pl -> has_comment pl - | [] -> false -;; - -let rec hprint_pretty tab pos spc = - function - SL (np, RO, x) -> h_print_string pos 0 np x, 1 - | SL (np, LO, x) -> h_print_string pos spc np x, 0 - | SL (np, NO, x) -> h_print_string pos 0 np x, 0 - | SL (np, LR, x) -> h_print_string pos spc np x, 1 - | HL x -> hprint_box tab pos spc x - | BL x -> hprint_box tab pos spc x - | PL x -> hprint_box tab pos spc x - | QL x -> hprint_box tab pos spc x - | VL [x] -> hprint_pretty tab pos spc x - | VL [] -> pos, spc - | VL x -> hprint_box tab pos spc x - | BE x -> hprint_box tab pos spc x - | BV x -> hprint_box tab pos spc x - | LI ((comm, nl_bef, tab_bef), x) -> - if !lazy_tab >= 0 then - begin - for i = 2 to nl_bef do !print_char_fun '\n' done; flush_tab () - end; - print_comment tab comm nl_bef tab_bef false; - hprint_pretty tab pos spc x -and hprint_box tab pos spc = - function - p :: pl -> - let (pos, spc) = hprint_pretty tab pos spc p in - hprint_box tab pos spc pl - | [] -> pos, spc -;; - -let rec print_pretty tab pos spc = - function - SL (np, RO, x) -> n_print_string pos 0 np x, 1 - | SL (np, LO, x) -> n_print_string pos spc np x, 0 - | SL (np, NO, x) -> n_print_string pos 0 np x, 0 - | SL (np, LR, x) -> n_print_string pos spc np x, 1 - | HL x as p -> print_horiz tab pos spc x - | BL x as p -> print_horiz_vertic tab pos spc (too_long tab (pos, spc) p) x - | PL x as p -> print_paragraph tab pos spc (too_long tab (pos, spc) p) x - | QL x as p -> print_sparagraph tab pos spc (too_long tab (pos, spc) p) x - | VL x -> print_vertic tab pos spc x - | BE x as p -> print_begin_end tab pos spc (too_long tab (pos, spc) p) x - | BV x -> print_beg_end tab pos spc x - | LI ((comm, nl_bef, tab_bef), x) -> - if !lazy_tab >= 0 then - begin - for i = 2 to nl_bef do !print_char_fun '\n' done; - if comm <> "" && nl_bef = 0 then - for i = 1 to tab_bef do !print_char_fun ' ' done - else if comm = "" && x = BL [] then lazy_tab := -1 - else flush_tab () - end; - print_comment tab comm nl_bef tab_bef (x = BL []); - if comm <> "" && nl_bef = 0 then - if end_with_tab comm then lazy_tab := -1 else flush_tab (); - print_pretty tab pos spc x -and print_horiz tab pos spc = - function - p :: pl -> - let (npos, nspc) = print_pretty tab pos spc p in - if match pl with - [] -> true - | _ -> false - then - npos, nspc - else print_horiz tab npos nspc pl - | [] -> pos, spc -and print_horiz_vertic tab pos spc ov pl = - if ov || has_comment pl then print_vertic tab pos spc pl - else hprint_box tab pos spc pl -and print_vertic tab pos spc = - function - p :: pl -> - let (npos, nspc) = print_pretty tab pos spc p in - if match pl with - [] -> true - | _ -> false - then - npos, nspc - else if tolerate tab npos nspc then - begin print_spaces nspc; print_vertic_rest (npos + nspc) pl end - else - begin - print_newline_and_tab (tab + !dt); print_vertic_rest (tab + !dt) pl - end - | [] -> pos, spc -and print_vertic_rest tab = - function - p :: pl -> - let (pos, spc) = print_pretty tab tab 0 p in - if match pl with - [] -> true - | _ -> false - then - pos, spc - else begin print_newline_and_tab tab; print_vertic_rest tab pl end - | [] -> tab, 0 -and print_paragraph tab pos spc ov pl = - if has_comment pl then print_vertic tab pos spc pl - else if ov then print_parag tab pos spc pl - else hprint_box tab pos spc pl -and print_parag tab pos spc = - function - p :: pl -> - let (npos, nspc) = print_pretty tab pos spc p in - if match pl with - [] -> true - | _ -> false - then - npos, nspc - else if npos == tab then print_parag_rest tab tab 0 pl - else if too_long tab (pos, spc) p then - begin - print_newline_and_tab (tab + !dt); - print_parag_rest (tab + !dt) (tab + !dt) 0 pl - end - else if tolerate tab npos nspc then - begin - print_spaces nspc; print_parag_rest (npos + nspc) (npos + nspc) 0 pl - end - else print_parag_rest (tab + !dt) npos nspc pl - | [] -> pos, spc -and print_parag_rest tab pos spc = - function - p :: pl -> - let (pos, spc) = - if pos > tab && too_long tab (pos, spc) p then - begin print_newline_and_tab tab; tab, 0 end - else pos, spc - in - let (npos, nspc) = print_pretty tab pos spc p in - if match pl with - [] -> true - | _ -> false - then - npos, nspc - else - let (pos, spc) = - if npos > tab && too_long tab (pos, spc) p then - begin print_newline_and_tab tab; tab, 0 end - else npos, nspc - in - print_parag_rest tab pos spc pl - | [] -> pos, spc -and print_sparagraph tab pos spc ov pl = - if has_comment pl then print_vertic tab pos spc pl - else if ov then print_sparag tab pos spc pl - else hprint_box tab pos spc pl -and print_sparag tab pos spc = - function - p :: pl -> - let (npos, nspc) = print_pretty tab pos spc p in - if match pl with - [] -> true - | _ -> false - then - npos, nspc - else if tolerate tab npos nspc then - begin - print_spaces nspc; - print_sparag_rest (npos + nspc) (npos + nspc) 0 pl - end - else print_sparag_rest (tab + !dt) npos nspc pl - | [] -> pos, spc -and print_sparag_rest tab pos spc = - function - p :: pl -> - let (pos, spc) = - if pos > tab && too_long tab (pos, spc) p then - begin print_newline_and_tab tab; tab, 0 end - else pos, spc - in - let (npos, nspc) = print_pretty tab pos spc p in - if match pl with - [] -> true - | _ -> false - then - npos, nspc - else print_sparag_rest tab npos nspc pl - | [] -> pos, spc -and print_begin_end tab pos spc ov pl = - if ov || has_comment pl then print_beg_end tab pos spc pl - else hprint_box tab pos spc pl -and print_beg_end tab pos spc = - function - p :: pl -> - let (npos, nspc) = print_pretty tab pos spc p in - if match pl with - [] -> true - | _ -> false - then - npos, nspc - else if tolerate tab npos nspc then - let nspc = if npos == tab then nspc + !dt else nspc in - print_spaces nspc; print_beg_end_rest tab (npos + nspc) pl - else - begin - print_newline_and_tab (tab + !dt); - print_beg_end_rest tab (tab + !dt) pl - end - | [] -> pos, spc -and print_beg_end_rest tab pos = - function - p :: pl -> - let (pos, spc) = print_pretty (tab + !dt) pos 0 p in - if match pl with - [] -> true - | _ -> false - then - pos, spc - else begin print_newline_and_tab tab; print_beg_end_rest tab tab pl end - | [] -> pos, 0 -;; - -let string_npos s = String.length s;; - -let rec conv = - function - S (g, s) -> SL (string_npos s, g, s) - | Hbox x -> HL (conv_stream x) - | HVbox x -> BL (conv_stream x) - | HOVbox x -> - begin match conv_stream x with - [PL _ as x] -> x - | x -> PL x - end - | HOVCbox x -> QL (conv_stream x) - | Vbox x -> VL (conv_stream x) - | BEbox x -> BE (conv_stream x) - | BEVbox x -> BV (conv_stream x) - | LocInfo ((bp, ep), x) -> - let (comm, nl_bef, tab_bef, cnt) = - let len = bp - !last_ep in - if len > 0 then !getcomm !last_ep len else "", 0, 0, 0 - in - last_ep := !last_ep + cnt; - let v = conv x in - last_ep := max ep !last_ep; LI ((comm, nl_bef, tab_bef), v) -and conv_stream (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some p -> Stream.junk strm__; let x = conv p in x :: conv_stream strm__ - | _ -> [] -;; - -let print_pretty pr_ch pr_str pr_nl pr pr2 m lf bp p = - maxl := m; - print_char_fun := pr_ch; - print_string_fun := pr_str; - print_newline_fun := pr_nl; - prompt := pr2; - getcomm := lf; - last_ep := bp; - print_string pr; - let _ = print_pretty 0 0 0 (conv p) in () -;; diff --git a/camlp4/ocaml_src/camlp4/spretty.mli b/camlp4/ocaml_src/camlp4/spretty.mli deleted file mode 100644 index 5c62d3f6cd..0000000000 --- a/camlp4/ocaml_src/camlp4/spretty.mli +++ /dev/null @@ -1,59 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1998 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* This file has been generated by program: do not edit! *) - -(* Hbox: horizontal box - HVbox: horizontal-vertical box - HOVbox and HOVCbox: fill maximum of elements horizontally, line by line; - in HOVbox, if an element has to be displayed vertically (need several - lines), the next element is displayed next line; in HOVCbox, this next - element may be displayed same line if it holds. - Vbox: vertical box - BEbox: begin-end box: horizontal or 2nd element indented, 3rd element not - BEVbox: begin-end box always vertical - LocInfo: call back with location to allow inserting comments *) - -(* In case of box displayed vertically, 2nd line and following are indented - by dt.val spaces, except if first element of the box is empty: to not - indent, put HVbox [: :] as first element *) - -type glue = - LO - | RO - | LR - | NO -;; -type pretty = - S of glue * string - | Hbox of pretty Stream.t - | HVbox of pretty Stream.t - | HOVbox of pretty Stream.t - | HOVCbox of pretty Stream.t - | Vbox of pretty Stream.t - | BEbox of pretty Stream.t - | BEVbox of pretty Stream.t - | LocInfo of (int * int) * pretty -;; -type getcomm = int -> int -> string * int * int * int;; - -val print_pretty : - (char -> unit) -> (string -> unit) -> (unit -> unit) -> string -> string -> - int -> getcomm -> int -> pretty -> unit;; -val quiet : bool ref;; - -val dt : int ref;; - -(*--*) - -val tol : int ref;; -val sp : char ref;; diff --git a/camlp4/ocaml_src/lib/.depend b/camlp4/ocaml_src/lib/.depend deleted file mode 100644 index 0d5adc691f..0000000000 --- a/camlp4/ocaml_src/lib/.depend +++ /dev/null @@ -1,20 +0,0 @@ -extfold.cmi: gramext.cmi -gramext.cmi: token.cmi -grammar.cmi: gramext.cmi token.cmi -plexer.cmi: token.cmi -extfold.cmo: gramext.cmi grammar.cmi extfold.cmi -extfold.cmx: gramext.cmx grammar.cmx extfold.cmi -extfun.cmo: extfun.cmi -extfun.cmx: extfun.cmi -fstream.cmo: fstream.cmi -fstream.cmx: fstream.cmi -gramext.cmo: token.cmi gramext.cmi -gramext.cmx: token.cmx gramext.cmi -grammar.cmo: gramext.cmi stdpp.cmi token.cmi grammar.cmi -grammar.cmx: gramext.cmx stdpp.cmx token.cmx grammar.cmi -plexer.cmo: stdpp.cmi token.cmi plexer.cmi -plexer.cmx: stdpp.cmx token.cmx plexer.cmi -stdpp.cmo: stdpp.cmi -stdpp.cmx: stdpp.cmi -token.cmo: token.cmi -token.cmx: token.cmi diff --git a/camlp4/ocaml_src/lib/Makefile b/camlp4/ocaml_src/lib/Makefile deleted file mode 100644 index e19e52052b..0000000000 --- a/camlp4/ocaml_src/lib/Makefile +++ /dev/null @@ -1,48 +0,0 @@ -# This file has been generated by program: do not edit! - -include ../../config/Makefile - -INCLUDES= -OCAMLCFLAGS=-warn-error A $(INCLUDES) -OBJS=stdpp.cmo token.cmo plexer.cmo gramext.cmo grammar.cmo extfold.cmo extfun.cmo fstream.cmo -SHELL=/bin/sh -TARGET=gramlib.cma - -all: $(TARGET) -opt: $(TARGET:.cma=.cmxa) - -$(TARGET): $(OBJS) - $(OCAMLC) $(OBJS) -a -o $(TARGET) - -$(TARGET:.cma=.cmxa): $(OBJS:.cmo=.cmx) - $(OCAMLOPT) $(OBJS:.cmo=.cmx) -a -o $(TARGET:.cma=.cmxa) - -clean:: - rm -f *.cm[ioax] *.cmxa *.pp[io] *.$(O) *.$(A) *.bak .*.bak $(TARGET) - -depend: - cp .depend .depend.bak - > .depend - @for i in *.mli *.ml; do \ - ../tools/apply.sh pr_depend.cmo -- $(INCLUDES) $$i >> .depend; \ - done - -promote: - cp $(OBJS) $(OBJS:.cmo=.cmi) ../../boot/. - -compare: - @for j in $(OBJS) $(OBJS:.cmo=.cmi); do \ - if cmp $$j ../../boot/$$j; then :; else exit 1; fi; \ - done - -install: - -$(MKDIR) "$(LIBDIR)/camlp4" - cp $(TARGET) *.mli "$(LIBDIR)/camlp4/." - cp *.cmi "$(LIBDIR)/camlp4/." - if test -f $(TARGET:.cma=.cmxa); then $(MAKE) installopt LIBDIR="$(LIBDIR)"; fi - -installopt: - cp $(TARGET:.cma=.cmxa) *.cmx "$(LIBDIR)/camlp4/." - tar cf - $(TARGET:.cma=.$(A)) | (cd "$(LIBDIR)/camlp4/."; tar xf -) - -include .depend diff --git a/camlp4/ocaml_src/lib/Makefile.Mac b/camlp4/ocaml_src/lib/Makefile.Mac deleted file mode 100644 index 2fc15c630d..0000000000 --- a/camlp4/ocaml_src/lib/Makefile.Mac +++ /dev/null @@ -1,46 +0,0 @@ -####################################################################### -# # -# Camlp4 # -# # -# Damien Doligez, projet Para, INRIA Rocquencourt # -# # -# Copyright 1999 Institut National de Recherche en Informatique et # -# en Automatique. Distributed only by permission. # -# # -####################################################################### - -# This file has been generated by program: do not edit! - -INCLUDES = -OCAMLCFLAGS = {INCLUDES} -OBJS = stdpp.cmo token.cmo plexer.cmo gramext.cmo grammar.cmo extfun.cmo fstream.cmo -INTF = stdpp.cmi token.cmi plexer.cmi gramext.cmi grammar.cmi extfun.cmi fstream.cmi -TARGETS = gramlib.cma - -all Ä {TARGETS} - -{TARGETS} Ä {OBJS} - {OCAMLC} {OBJS} -a -o {TARGETS} - -steal Ä - -compare_stolen Ä - -clean ÄÄ - delete -i {TARGETS} - -{dependrule} - -promote Ä - duplicate -y {OBJS} {INTF} :::boot: - -compare Ä - for i in {OBJS} {INTF} - equal -s :::boot:{i} || exit 1 - end - -install Ä - (newfolder "{P4LIBDIR}" || set status 0) ³ dev:null - duplicate -y {TARGETS} Å.mli Å.cmi "{P4LIBDIR}" - -{defrules} diff --git a/camlp4/ocaml_src/lib/Makefile.Mac.depend b/camlp4/ocaml_src/lib/Makefile.Mac.depend deleted file mode 100644 index 8d12e3e08a..0000000000 --- a/camlp4/ocaml_src/lib/Makefile.Mac.depend +++ /dev/null @@ -1,13 +0,0 @@ -gramext.cmoÄ token.cmi gramext.cmi -gramext.cmxÄ token.cmx gramext.cmi -gramext.cmiÄ token.cmi -grammar.cmoÄ gramext.cmi stdpp.cmi token.cmi grammar.cmi -grammar.cmxÄ gramext.cmx stdpp.cmx token.cmx grammar.cmi -grammar.cmiÄ gramext.cmi token.cmi -plexer.cmoÄ stdpp.cmi token.cmi plexer.cmi -plexer.cmxÄ stdpp.cmx token.cmx plexer.cmi -plexer.cmiÄ token.cmi -stdpp.cmoÄ stdpp.cmi -stdpp.cmxÄ stdpp.cmi -token.cmoÄ token.cmi -token.cmxÄ token.cmi diff --git a/camlp4/ocaml_src/lib/extfold.ml b/camlp4/ocaml_src/lib/extfold.ml deleted file mode 100644 index 0411497f02..0000000000 --- a/camlp4/ocaml_src/lib/extfold.ml +++ /dev/null @@ -1,124 +0,0 @@ -(* camlp4r *) -(* This file has been generated by program: do not edit! *) - -type ('te, 'a, 'b) t = - 'te Gramext.g_entry -> 'te Gramext.g_symbol list -> ('te Stream.t -> 'a) -> - 'te Stream.t -> 'b -;; - -type ('te, 'a, 'b) tsep = - 'te Gramext.g_entry -> 'te Gramext.g_symbol list -> ('te Stream.t -> 'a) -> - ('te Stream.t -> unit) -> 'te Stream.t -> 'b -;; - -let gen_fold0 final f e entry symbl psymb = - let rec fold accu (strm__ : _ Stream.t) = - match - try Some (psymb strm__) with - Stream.Failure -> None - with - Some a -> fold (f a accu) strm__ - | _ -> accu - in - fun (strm__ : _ Stream.t) -> let a = fold e strm__ in final a -;; - -let gen_fold1 final f e entry symbl psymb = - let rec fold accu (strm__ : _ Stream.t) = - match - try Some (psymb strm__) with - Stream.Failure -> None - with - Some a -> fold (f a accu) strm__ - | _ -> accu - in - fun (strm__ : _ Stream.t) -> - let a = psymb strm__ in - let a = - try fold (f a e) strm__ with - Stream.Failure -> raise (Stream.Error "") - in - final a -;; - -let gen_fold0sep final f e entry symbl psymb psep = - let failed = - function - [symb; sep] -> Grammar.symb_failed_txt entry sep symb - | _ -> "failed" - in - let rec kont accu (strm__ : _ Stream.t) = - match - try Some (psep strm__) with - Stream.Failure -> None - with - Some v -> - let a = - try psymb strm__ with - Stream.Failure -> raise (Stream.Error (failed symbl)) - in - kont (f a accu) strm__ - | _ -> accu - in - fun (strm__ : _ Stream.t) -> - match - try Some (psymb strm__) with - Stream.Failure -> None - with - Some a -> final (kont (f a e) strm__) - | _ -> e -;; - -let gen_fold1sep final f e entry symbl psymb psep = - let failed = - function - [symb; sep] -> Grammar.symb_failed_txt entry sep symb - | _ -> "failed" - in - let parse_top = - function - [symb; _] -> Grammar.parse_top_symb entry symb - | _ -> raise Stream.Failure - in - let rec kont accu (strm__ : _ Stream.t) = - match - try Some (psep strm__) with - Stream.Failure -> None - with - Some v -> - let a = - try - try psymb strm__ with - Stream.Failure -> - let a = - try parse_top symbl strm__ with - Stream.Failure -> raise (Stream.Error (failed symbl)) - in - Obj.magic a - with - Stream.Failure -> raise (Stream.Error "") - in - kont (f a accu) strm__ - | _ -> accu - in - fun (strm__ : _ Stream.t) -> - let a = psymb strm__ in final (kont (f a e) strm__) -;; - -let sfold0 f e = gen_fold0 (fun x -> x) f e;; -let sfold1 f e = gen_fold1 (fun x -> x) f e;; -let sfold0sep f e = gen_fold0sep (fun x -> x) f e;; -let sfold1sep f e = gen_fold1sep (fun x -> x) f e;; - -let cons x y = x :: y;; -let nil = [];; - -let slist0 entry = gen_fold0 List.rev cons nil entry;; -let slist1 entry = gen_fold1 List.rev cons nil entry;; -let slist0sep entry = gen_fold0sep List.rev cons nil entry;; -let slist1sep entry = gen_fold1sep List.rev cons nil entry;; - -let sopt entry symbl psymb (strm__ : _ Stream.t) = - try Some (psymb strm__) with - Stream.Failure -> None -;; diff --git a/camlp4/ocaml_src/lib/extfold.mli b/camlp4/ocaml_src/lib/extfold.mli deleted file mode 100644 index cb2824fb1d..0000000000 --- a/camlp4/ocaml_src/lib/extfold.mli +++ /dev/null @@ -1,24 +0,0 @@ -(* camlp4r *) -(* This file has been generated by program: do not edit! *) - -type ('te, 'a, 'b) t = - 'te Gramext.g_entry -> 'te Gramext.g_symbol list -> ('te Stream.t -> 'a) -> - 'te Stream.t -> 'b -;; - -type ('te, 'a, 'b) tsep = - 'te Gramext.g_entry -> 'te Gramext.g_symbol list -> ('te Stream.t -> 'a) -> - ('te Stream.t -> unit) -> 'te Stream.t -> 'b -;; - -val sfold0 : ('a -> 'b -> 'b) -> 'b -> (_, 'a, 'b) t;; -val sfold1 : ('a -> 'b -> 'b) -> 'b -> (_, 'a, 'b) t;; -val sfold0sep : ('a -> 'b -> 'b) -> 'b -> (_, 'a, 'b) tsep;; -val sfold1sep : ('a -> 'b -> 'b) -> 'b -> (_, 'a, 'b) tsep;; - -val slist0 : (_, 'a, 'a list) t;; -val slist1 : (_, 'a, 'a list) t;; -val slist0sep : (_, 'a, 'a list) tsep;; -val slist1sep : (_, 'a, 'a list) tsep;; - -val sopt : (_, 'a, 'a option) t;; diff --git a/camlp4/ocaml_src/lib/extfun.ml b/camlp4/ocaml_src/lib/extfun.ml deleted file mode 100644 index f8a6b26ac5..0000000000 --- a/camlp4/ocaml_src/lib/extfun.ml +++ /dev/null @@ -1,105 +0,0 @@ -(* camlp4r *) -(* This file has been generated by program: do not edit! *) -(* Copyright 2001 INRIA *) - -(* Extensible Functions *) - -type ('a, 'b) t = ('a, 'b) matching list -and ('a, 'b) matching = { patt : patt; has_when : bool; expr : ('a, 'b) expr } -and patt = - Eapp of patt list - | Eacc of patt list - | Econ of string - | Estr of string - | Eint of string - | Etup of patt list - | Evar of unit -and ('a, 'b) expr = 'a -> 'b option -;; - -exception Failure;; - -let empty = [];; - -(*** Apply ***) - -let rec apply_matchings a = - function - m :: ml -> - begin match m.expr a with - None -> apply_matchings a ml - | x -> x - end - | [] -> None -;; - -let apply ef a = - match apply_matchings a ef with - Some x -> x - | None -> raise Failure -;; - -(*** Trace ***) - -let rec list_iter_sep f s = - function - [] -> () - | [x] -> f x - | x :: l -> f x; s (); list_iter_sep f s l -;; - -let rec print_patt = - function - Eapp pl -> list_iter_sep print_patt2 (fun () -> print_string " ") pl - | p -> print_patt2 p -and print_patt2 = - function - Eacc pl -> list_iter_sep print_patt1 (fun () -> print_string ".") pl - | p -> print_patt1 p -and print_patt1 = - function - Econ s -> print_string s - | Estr s -> print_string "\""; print_string s; print_string "\"" - | Eint s -> print_string s - | Evar () -> print_string "_" - | Etup pl -> - print_string "("; - list_iter_sep print_patt (fun () -> print_string ", ") pl; - print_string ")" - | Eapp _ | Eacc _ as p -> print_string "("; print_patt p; print_string ")" -;; - -let print ef = - List.iter - (fun m -> - print_patt m.patt; - if m.has_when then print_string " when ..."; - print_newline ()) - ef -;; - -(*** Extension ***) - -let insert_matching matchings (patt, has_when, expr) = - let m1 = {patt = patt; has_when = has_when; expr = expr} in - let rec loop = - function - m :: ml as gml -> - if m1.has_when && not m.has_when then m1 :: gml - else if not m1.has_when && m.has_when then m :: loop ml - else - let c = compare m1.patt m.patt in - if c < 0 then m1 :: gml - else if c > 0 then m :: loop ml - else if m.has_when then m1 :: gml - else m1 :: ml - | [] -> [m1] - in - loop matchings -;; - -(* available extension function *) - -let extend ef matchings_def = - List.fold_left insert_matching ef matchings_def -;; diff --git a/camlp4/ocaml_src/lib/extfun.mli b/camlp4/ocaml_src/lib/extfun.mli deleted file mode 100644 index 2d42fe2e84..0000000000 --- a/camlp4/ocaml_src/lib/extfun.mli +++ /dev/null @@ -1,37 +0,0 @@ -(* camlp4r *) -(* This file has been generated by program: do not edit! *) - -(** Extensible functions. - - This module implements pattern matching extensible functions. - To extend, use syntax [pa_extfun.cmo]: - - [extfun e with [ pattern_matching ]] *) - -type ('a, 'b) t;; - (** The type of the extensible functions of type ['a -> 'b] *) -val empty : ('a, 'b) t;; - (** Empty extensible function *) -val apply : ('a, 'b) t -> 'a -> 'b;; - (** Apply an extensible function *) -exception Failure;; - (** Match failure while applying an extensible function *) -val print : ('a, 'b) t -> unit;; - (** Print patterns in the order they are recorded *) - -(**/**) - -type ('a, 'b) matching = - { patt : patt; has_when : bool; expr : ('a, 'b) expr } -and patt = - Eapp of patt list - | Eacc of patt list - | Econ of string - | Estr of string - | Eint of string - | Etup of patt list - | Evar of unit -and ('a, 'b) expr = 'a -> 'b option -;; - -val extend : ('a, 'b) t -> (patt * bool * ('a, 'b) expr) list -> ('a, 'b) t;; diff --git a/camlp4/ocaml_src/lib/fstream.ml b/camlp4/ocaml_src/lib/fstream.ml deleted file mode 100644 index 9ffdb71041..0000000000 --- a/camlp4/ocaml_src/lib/fstream.ml +++ /dev/null @@ -1,84 +0,0 @@ -(* camlp4r *) -(* This file has been generated by program: do not edit! *) -(* Copyright 2001 INRIA *) - -type 'a t = { count : int; data : 'a data Lazy.t } -and 'a data = - Nil - | Cons of 'a * 'a t - | App of 'a t * 'a t -;; - -let from f = - let rec loop i = - {count = 0; - data = - lazy - (match f i with - Some x -> Cons (x, loop (i + 1)) - | None -> Nil)} - in - loop 0 -;; - -let rec next s = - let count = s.count + 1 in - match Lazy.force s.data with - Nil -> None - | Cons (a, s) -> Some (a, {count = count; data = s.data}) - | App (s1, s2) -> - match next s1 with - Some (a, s1) -> Some (a, {count = count; data = lazy (App (s1, s2))}) - | None -> - match next s2 with - Some (a, s2) -> Some (a, {count = count; data = s2.data}) - | None -> None -;; - -let empty s = - match next s with - Some _ -> None - | None -> Some ((), s) -;; - -let nil = {count = 0; data = lazy Nil};; -let cons a s = Cons (a, s);; -let app s1 s2 = App (s1, s2);; -let flazy f = {count = 0; data = Lazy.lazy_from_fun f};; - -let of_list l = - List.fold_right (fun x s -> flazy (fun () -> cons x s)) l nil -;; - -let of_string s = - from (fun c -> if c < String.length s then Some s.[c] else None) -;; - -let of_channel ic = - from - (fun _ -> - try Some (input_char ic) with - End_of_file -> None) -;; - -let iter f = - let rec do_rec strm = - match next strm with - Some (a, strm) -> let _ = f a in do_rec strm - | None -> () - in - do_rec -;; - -let count s = s.count;; - -let count_unfrozen s = - let rec loop cnt s = - if Lazy.lazy_is_val s.data then - match Lazy.force s.data with - Cons (_, s) -> loop (cnt + 1) s - | _ -> cnt - else cnt - in - loop 0 s -;; diff --git a/camlp4/ocaml_src/lib/fstream.mli b/camlp4/ocaml_src/lib/fstream.mli deleted file mode 100644 index d0e8f8b49c..0000000000 --- a/camlp4/ocaml_src/lib/fstream.mli +++ /dev/null @@ -1,60 +0,0 @@ -(* camlp4r *) -(* This file has been generated by program: do not edit! *) - -(* Module [Fstream]: functional streams *) - -(* This module implement functional streams. - To be used with syntax [pa_fstream.cmo]. The syntax is: -- stream: [fstream [: ... :]] -- parser: [parser [ [: ... :] -> ... | ... ]] - - Functional parsers are of type: [Fstream.t 'a -> option ('a * Fstream.t 'a)] - - They have limited backtrack, i.e if a rule fails, the next rule is tested - with the initial stream; limited because when in case of a rule with two - consecutive symbols [a] and [b], if [b] fails, the rule fails: there is - no try with the next rule of [a]. -*) - -type 'a t;; - (* The type of 'a functional streams *) -val from : (int -> 'a option) -> 'a t;; - (* [Fstream.from f] returns a stream built from the function [f]. - To create a new stream element, the function [f] is called with - the current stream count. The user function [f] must return either - [Some ] for a value or [None] to specify the end of the - stream. *) - -val of_list : 'a list -> 'a t;; - (* Return the stream holding the elements of the list in the same - order. *) -val of_string : string -> char t;; - (* Return the stream of the characters of the string parameter. *) -val of_channel : in_channel -> char t;; - (* Return the stream of the characters read from the input channel. *) - -val iter : ('a -> unit) -> 'a t -> unit;; - (* [Fstream.iter f s] scans the whole stream s, applying function [f] - in turn to each stream element encountered. *) - -val next : 'a t -> ('a * 'a t) option;; - (* Return [Some (a, s)] where [a] is the first element of the stream - and [s] the remaining stream, or [None] if the stream is empty. *) -val empty : 'a t -> (unit * 'a t) option;; - (* Return [Some ((), s)] if the stream is empty where [s] is itself, - else [None] *) -val count : 'a t -> int;; - (* Return the current count of the stream elements, i.e. the number - of the stream elements discarded. *) -val count_unfrozen : 'a t -> int;; - (* Return the number of unfrozen elements in the beginning of the - stream; useful to determine the position of a parsing error (longuest - path). *) - -(*--*) - -val nil : 'a t;; -type 'a data;; -val cons : 'a -> 'a t -> 'a data;; -val app : 'a t -> 'a t -> 'a data;; -val flazy : (unit -> 'a data) -> 'a t;; diff --git a/camlp4/ocaml_src/lib/gramext.ml b/camlp4/ocaml_src/lib/gramext.ml deleted file mode 100644 index 41fdd76c19..0000000000 --- a/camlp4/ocaml_src/lib/gramext.ml +++ /dev/null @@ -1,531 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* This file has been generated by program: do not edit! *) - -open Printf;; - -type 'te grammar = - { gtokens : (Token.pattern, int ref) Hashtbl.t; - mutable glexer : 'te Token.glexer } -;; - -type 'te g_entry = - { egram : 'te grammar; - ename : string; - mutable estart : int -> 'te Stream.t -> Obj.t; - mutable econtinue : int -> int -> Obj.t -> 'te Stream.t -> Obj.t; - mutable edesc : 'te g_desc } -and 'te g_desc = - Dlevels of 'te g_level list - | Dparser of ('te Stream.t -> Obj.t) -and 'te g_level = - { assoc : g_assoc; - lname : string option; - lsuffix : 'te g_tree; - lprefix : 'te g_tree } -and g_assoc = - NonA - | RightA - | LeftA -and 'te g_symbol = - Smeta of string * 'te g_symbol list * Obj.t - | Snterm of 'te g_entry - | Snterml of 'te g_entry * string - | Slist0 of 'te g_symbol - | Slist0sep of 'te g_symbol * 'te g_symbol - | Slist1 of 'te g_symbol - | Slist1sep of 'te g_symbol * 'te g_symbol - | Sopt of 'te g_symbol - | Sself - | Snext - | Stoken of Token.pattern - | Stree of 'te g_tree -and g_action = Obj.t -and 'te g_tree = - Node of 'te g_node - | LocAct of g_action * g_action list - | DeadEnd -and 'te g_node = - { node : 'te g_symbol; son : 'te g_tree; brother : 'te g_tree } -;; - -type position = - First - | Last - | Before of string - | After of string - | Level of string -;; - -let warning_verbose = ref true;; - -let rec derive_eps = - function - Slist0 _ -> true - | Slist0sep (_, _) -> true - | Sopt _ -> true - | Stree t -> tree_derive_eps t - | Smeta (_, _, _) | Slist1 _ | Slist1sep (_, _) | Snterm _ | - Snterml (_, _) | Snext | Sself | Stoken _ -> - false -and tree_derive_eps = - function - LocAct (_, _) -> true - | Node {node = s; brother = bro; son = son} -> - derive_eps s && tree_derive_eps son || tree_derive_eps bro - | DeadEnd -> false -;; - -let 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 -> eq_symbol s1 s2 - | Slist0sep (s1, sep1), Slist0sep (s2, sep2) -> - eq_symbol s1 s2 && eq_symbol sep1 sep2 - | Slist1 s1, Slist1 s2 -> eq_symbol s1 s2 - | Slist1sep (s1, sep1), Slist1sep (s2, sep2) -> - eq_symbol s1 s2 && eq_symbol sep1 sep2 - | Sopt s1, Sopt s2 -> eq_symbol s1 s2 - | Stree _, Stree _ -> false - | _ -> s1 = s2 -;; - -let is_before s1 s2 = - match s1, s2 with - Stoken ("ANY", _), _ -> false - | _, Stoken ("ANY", _) -> true - | Stoken (_, s), Stoken (_, "") when s <> "" -> true - | Stoken _, Stoken _ -> false - | Stoken _, _ -> true - | _ -> false -;; - -let insert_tree entry_name 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) -> - if !warning_verbose then - begin - eprintf " Grammar extension: "; - if entry_name <> "" then eprintf "in [%s], " entry_name; - eprintf "some rule has been masked\n"; - flush stderr - end; - 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 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 - begin match try_insert s sl bro with - Some bro -> - let t = Node {node = s1; son = son; brother = bro} in Some t - | None -> None - end - | LocAct (_, _) | DeadEnd -> None - and insert_new = - function - s :: sl -> Node {node = s; son = insert_new sl; brother = DeadEnd} - | [] -> LocAct (action, []) - in - insert gsymbols tree -;; - -let srules rl = - let t = - List.fold_left - (fun tree (symbols, action) -> insert_tree "" symbols action tree) - DeadEnd rl - in - Stree t -;; - -external action : 'a -> g_action = "%identity";; - -let is_level_labelled n lev = - match lev.lname with - Some n1 -> n = n1 - | None -> false -;; - -let insert_level entry_name e1 symbols action slev = - match e1 with - true -> - {assoc = slev.assoc; lname = slev.lname; - lsuffix = insert_tree entry_name symbols action slev.lsuffix; - lprefix = slev.lprefix} - | false -> - {assoc = slev.assoc; lname = slev.lname; lsuffix = slev.lsuffix; - lprefix = insert_tree entry_name symbols action slev.lprefix} -;; - -let empty_lev lname assoc = - let assoc = - match assoc with - Some a -> a - | None -> LeftA - in - {assoc = assoc; lname = lname; lsuffix = DeadEnd; lprefix = DeadEnd} -;; - -let change_lev lev n lname assoc = - let a = - match assoc with - None -> lev.assoc - | Some a -> - if a <> lev.assoc && !warning_verbose then - begin - eprintf " Changing associativity of level \"%s\"\n" n; - flush stderr - end; - a - in - begin match lname with - Some n -> - if lname <> lev.lname && !warning_verbose then - begin eprintf " Level label \"%s\" ignored\n" n; flush stderr end - | None -> () - end; - {assoc = a; lname = lev.lname; lsuffix = lev.lsuffix; lprefix = lev.lprefix} -;; - -let get_level entry position levs = - match position with - Some First -> [], empty_lev, levs - | Some Last -> levs, empty_lev, [] - | Some (Level n) -> - let rec get = - function - [] -> - eprintf "No level labelled \"%s\" in entry \"%s\"\n" n - entry.ename; - flush stderr; - failwith "Grammar.extend" - | lev :: levs -> - if is_level_labelled n lev then [], change_lev lev n, levs - else - let (levs1, rlev, levs2) = get levs in lev :: levs1, rlev, levs2 - in - get levs - | Some (Before n) -> - let rec get = - function - [] -> - eprintf "No level labelled \"%s\" in entry \"%s\"\n" n - entry.ename; - flush stderr; - failwith "Grammar.extend" - | lev :: levs -> - if 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 = - function - [] -> - eprintf "No level labelled \"%s\" in entry \"%s\"\n" n - entry.ename; - flush stderr; - failwith "Grammar.extend" - | lev :: levs -> - if 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 lev "", levs - | [] -> [], empty_lev, [] -;; - -let rec check_gram entry = - function - Snterm e -> - if e.egram != entry.egram then - begin - eprintf "\ -Error: entries \"%s\" and \"%s\" do not belong to the same grammar.\n" - entry.ename e.ename; - flush stderr; - failwith "Grammar.extend error" - end - | Snterml (e, _) -> - if e.egram != entry.egram then - begin - eprintf "\ -Error: entries \"%s\" and \"%s\" do not belong to the same grammar.\n" - entry.ename e.ename; - flush stderr; - failwith "Grammar.extend error" - end - | Smeta (_, sl, _) -> List.iter (check_gram entry) sl - | Slist0sep (s, t) -> check_gram entry t; check_gram entry s - | Slist1sep (s, t) -> check_gram entry t; check_gram entry s - | Slist0 s -> check_gram entry s - | Slist1 s -> check_gram entry s - | Sopt s -> check_gram entry s - | Stree t -> tree_check_gram entry t - | Snext | Sself | Stoken _ -> () -and tree_check_gram entry = - function - Node {node = n; brother = bro; son = son} -> - check_gram entry n; tree_check_gram entry bro; tree_check_gram entry son - | LocAct (_, _) | DeadEnd -> () -;; - -let change_to_self entry = - function - Snterm e when e == entry -> Sself - | x -> x -;; - -let get_initial entry = - function - Sself :: symbols -> true, symbols - | symbols -> false, symbols -;; - -let insert_tokens gram symbols = - let rec insert = - function - Smeta (_, sl, _) -> List.iter insert sl - | Slist0 s -> insert s - | Slist1 s -> insert s - | Slist0sep (s, t) -> insert s; insert t - | Slist1sep (s, t) -> insert s; insert t - | Sopt s -> insert s - | Stree t -> tinsert t - | Stoken ("ANY", _) -> () - | Stoken tok -> - gram.glexer.Token.tok_using tok; - let r = - try Hashtbl.find gram.gtokens tok with - Not_found -> let r = ref 0 in Hashtbl.add gram.gtokens tok r; r - in - incr r - | Snterm _ | Snterml (_, _) | Snext | Sself -> () - and tinsert = - function - Node {node = s; brother = bro; son = son} -> - insert s; tinsert bro; tinsert son - | LocAct (_, _) | DeadEnd -> () - in - List.iter insert symbols -;; - -let levels_of_rules entry position rules = - let elev = - match entry.edesc with - Dlevels elev -> elev - | Dparser _ -> - eprintf "Error: entry not extensible: \"%s\"\n" entry.ename; - flush 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 - List.iter (check_gram entry) symbols; - let (e1, symbols) = get_initial entry symbols in - insert_tokens entry.egram symbols; - insert_level entry.ename e1 symbols action lev) - lev level - in - lev :: levs, empty_lev) - ([], make_lev) rules - in - levs1 @ List.rev levs @ levs2 -;; - -let 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 -> eq_symbols s1 s2 - | Slist0sep (s1, sep1), Slist0sep (s2, sep2) -> - eq_symbols s1 s2 && eq_symbols sep1 sep2 - | Slist1 s1, Slist1 s2 -> eq_symbols s1 s2 - | Slist1sep (s1, sep1), Slist1sep (s2, sep2) -> - eq_symbols s1 s2 && eq_symbols sep1 sep2 - | Sopt s1, Sopt s2 -> eq_symbols s1 s2 - | Stree t1, Stree t2 -> eq_trees t1 t2 - | _ -> 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 -;; - -(* [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 *) - -let delete_rule_in_tree entry = - let rec delete_in_tree symbols tree = - match symbols, tree with - s :: sl, Node n -> - if logically_eq_symbols entry s n.node then delete_son sl n - else - begin match delete_in_tree symbols n.brother with - Some (dsl, t) -> - Some (dsl, Node {node = n.node; son = n.son; brother = t}) - | None -> None - end - | s :: sl, _ -> None - | [], Node n -> - begin match delete_in_tree [] n.brother with - Some (dsl, t) -> - Some (dsl, Node {node = n.node; son = n.son; brother = t}) - | None -> None - end - | [], 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 -;; - -let rec decr_keyw_use gram = - function - Stoken tok -> - let r = Hashtbl.find gram.gtokens tok in - decr r; - if !r == 0 then - begin - Hashtbl.remove gram.gtokens tok; gram.glexer.Token.tok_removing tok - end - | Smeta (_, sl, _) -> List.iter (decr_keyw_use gram) sl - | Slist0 s -> decr_keyw_use gram s - | Slist1 s -> decr_keyw_use gram s - | Slist0sep (s1, s2) -> decr_keyw_use gram s1; decr_keyw_use gram s2 - | Slist1sep (s1, s2) -> decr_keyw_use gram s1; decr_keyw_use gram s2 - | Sopt s -> decr_keyw_use gram s - | Stree t -> decr_keyw_use_in_tree gram t - | Sself | Snext | Snterm _ | Snterml (_, _) -> () -and decr_keyw_use_in_tree gram = - function - DeadEnd | LocAct (_, _) -> () - | Node n -> - decr_keyw_use gram n.node; - decr_keyw_use_in_tree gram n.son; - decr_keyw_use_in_tree gram n.brother -;; - -let rec delete_rule_in_suffix entry symbols = - function - lev :: levs -> - begin match delete_rule_in_tree entry symbols lev.lsuffix with - Some (dsl, t) -> - begin match dsl with - Some dsl -> List.iter (decr_keyw_use entry.egram) dsl - | None -> () - end; - begin 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 - end - | None -> - let levs = delete_rule_in_suffix entry symbols levs in lev :: levs - end - | [] -> raise Not_found -;; - -let rec delete_rule_in_prefix entry symbols = - function - lev :: levs -> - begin match delete_rule_in_tree entry symbols lev.lprefix with - Some (dsl, t) -> - begin match dsl with - Some dsl -> List.iter (decr_keyw_use entry.egram) dsl - | None -> () - end; - begin 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 - end - | None -> - let levs = delete_rule_in_prefix entry symbols levs in lev :: levs - end - | [] -> raise Not_found -;; - -let 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 -;; diff --git a/camlp4/ocaml_src/lib/gramext.mli b/camlp4/ocaml_src/lib/gramext.mli deleted file mode 100644 index bd275ae8ee..0000000000 --- a/camlp4/ocaml_src/lib/gramext.mli +++ /dev/null @@ -1,79 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* This file has been generated by program: do not edit! *) - -type 'te grammar = - { gtokens : (Token.pattern, int ref) Hashtbl.t; - mutable glexer : 'te Token.glexer } -;; - -type 'te g_entry = - { egram : 'te grammar; - ename : string; - mutable estart : int -> 'te Stream.t -> Obj.t; - mutable econtinue : int -> int -> Obj.t -> 'te Stream.t -> Obj.t; - mutable edesc : 'te g_desc } -and 'te g_desc = - Dlevels of 'te g_level list - | Dparser of ('te Stream.t -> Obj.t) -and 'te g_level = - { assoc : g_assoc; - lname : string option; - lsuffix : 'te g_tree; - lprefix : 'te g_tree } -and g_assoc = - NonA - | RightA - | LeftA -and 'te g_symbol = - Smeta of string * 'te g_symbol list * Obj.t - | Snterm of 'te g_entry - | Snterml of 'te g_entry * string - | Slist0 of 'te g_symbol - | Slist0sep of 'te g_symbol * 'te g_symbol - | Slist1 of 'te g_symbol - | Slist1sep of 'te g_symbol * 'te g_symbol - | Sopt of 'te g_symbol - | Sself - | Snext - | Stoken of Token.pattern - | Stree of 'te g_tree -and g_action = Obj.t -and 'te g_tree = - Node of 'te g_node - | LocAct of g_action * g_action list - | DeadEnd -and 'te g_node = - { node : 'te g_symbol; son : 'te g_tree; brother : 'te g_tree } -;; - -type position = - First - | Last - | Before of string - | After of string - | Level of string -;; - -val levels_of_rules : - 'te g_entry -> position option -> - (string option * g_assoc option * ('te g_symbol list * g_action) list) - list -> - 'te g_level list;; -val srules : ('te g_symbol list * g_action) list -> 'te g_symbol;; -external action : 'a -> g_action = "%identity";; - -val delete_rule_in_level_list : - 'te g_entry -> 'te g_symbol list -> 'te g_level list -> 'te g_level list;; - -val warning_verbose : bool ref;; diff --git a/camlp4/ocaml_src/lib/grammar.ml b/camlp4/ocaml_src/lib/grammar.ml deleted file mode 100644 index 196a6b954a..0000000000 --- a/camlp4/ocaml_src/lib/grammar.ml +++ /dev/null @@ -1,1119 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* This file has been generated by program: do not edit! *) - -open Stdpp;; -open Gramext;; -open Format;; - -let rec flatten_tree = - function - DeadEnd -> [] - | LocAct (_, _) -> [[]] - | Node {node = n; brother = b; son = s} -> - List.map (fun l -> n :: l) (flatten_tree s) @ flatten_tree b -;; - -let print_str ppf s = fprintf ppf "\"%s\"" (String.escaped s);; - -let rec print_symbol ppf = - function - 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 - | Stoken (con, prm) when con <> "" && prm <> "" -> - fprintf ppf "%s@ %a" con print_str prm - | Snterml (e, l) -> fprintf ppf "%s@ LEVEL@ %a" e.ename print_str l - | Snterm _ | Snext | Sself | Stoken _ | Stree _ as s -> print_symbol1 ppf s -and print_meta ppf n sl = - let rec loop i = - function - [] -> () - | s :: sl -> - let j = - try String.index_from n i ' ' with - Not_found -> String.length n - in - fprintf ppf "%s %a" (String.sub n i (j - i)) print_symbol1 s; - if sl = [] then () - else - begin fprintf ppf " "; loop (min (j + 1) (String.length n)) sl end - in - loop 0 sl -and print_symbol1 ppf = - function - Snterm e -> pp_print_string ppf e.ename - | Sself -> pp_print_string ppf "SELF" - | Snext -> pp_print_string ppf "NEXT" - | Stoken ("", s) -> print_str ppf s - | Stoken (con, "") -> pp_print_string ppf con - | Stree t -> print_level ppf pp_print_space (flatten_tree t) - | Smeta (_, _, _) | Snterml (_, _) | Slist0 _ | Slist0sep (_, _) | - Slist1 _ | Slist1sep (_, _) | Sopt _ | Stoken _ as s -> - fprintf ppf "(%a)" print_symbol s -and print_rule ppf symbols = - fprintf ppf "@["; - let _ = - List.fold_left - (fun sep symbol -> - fprintf ppf "%t%a" sep print_symbol symbol; - fun ppf -> fprintf ppf ";@ ") - (fun ppf -> ()) symbols - in - fprintf ppf "@]" -and print_level ppf pp_print_space rules = - fprintf ppf "@[[ "; - let _ = - List.fold_left - (fun sep rule -> - fprintf ppf "%t%a" sep print_rule rule; - fun ppf -> fprintf ppf "%a| " pp_print_space ()) - (fun ppf -> ()) rules - in - fprintf ppf " ]@]" -;; - -let print_levels ppf elev = - let _ = - List.fold_left - (fun sep lev -> - let rules = - List.map (fun t -> Sself :: t) (flatten_tree lev.lsuffix) @ - flatten_tree lev.lprefix - in - fprintf ppf "%t@[" sep; - begin match lev.lname with - Some n -> fprintf ppf "%a@;<1 2>" print_str n - | None -> () - end; - begin match lev.assoc with - LeftA -> fprintf ppf "LEFTA" - | RightA -> fprintf ppf "RIGHTA" - | NonA -> fprintf ppf "NONA" - end; - fprintf ppf "@]@;<1 2>"; - print_level ppf pp_force_newline rules; - fun ppf -> fprintf ppf "@,| ") - (fun ppf -> ()) elev - in - () -;; - -let print_entry ppf e = - fprintf ppf "@[[ "; - begin match e.edesc with - Dlevels elev -> print_levels ppf elev - | Dparser _ -> fprintf ppf "" - end; - fprintf ppf " ]@]" -;; - -let iter_entry f e = - let treated = ref [] in - let rec do_entry e = - if List.memq e !treated then () - else - begin - treated := e :: !treated; - f e; - match e.edesc with - Dlevels ll -> List.iter do_level ll - | Dparser _ -> () - end - and do_level lev = do_tree lev.lsuffix; do_tree lev.lprefix - and do_tree = - function - Node n -> do_node n - | LocAct (_, _) | DeadEnd -> () - and do_node n = do_symbol n.node; do_tree n.son; do_tree n.brother - and do_symbol = - function - Smeta (_, sl, _) -> List.iter do_symbol sl - | Snterm e | Snterml (e, _) -> do_entry e - | Slist0 s | Slist1 s | Sopt s -> do_symbol s - | Slist0sep (s1, s2) | Slist1sep (s1, s2) -> do_symbol s1; do_symbol s2 - | Stree t -> do_tree t - | Sself | Snext | Stoken _ -> () - in - do_entry e -;; - -let fold_entry f e init = - let treated = ref [] in - let rec do_entry accu e = - if List.memq e !treated then accu - else - begin - treated := e :: !treated; - let accu = f e accu in - match e.edesc with - Dlevels ll -> List.fold_left do_level accu ll - | Dparser _ -> accu - end - and do_level accu lev = - let accu = do_tree accu lev.lsuffix in do_tree accu lev.lprefix - and do_tree accu = - function - 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 = - function - Smeta (_, sl, _) -> List.fold_left do_symbol accu sl - | Snterm e | Snterml (e, _) -> do_entry accu e - | Slist0 s | Slist1 s | Sopt 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 _ -> accu - in - do_entry init e -;; - -type g = Token.t Gramext.grammar;; - -external grammar_obj : g -> Token.t grammar = "%identity";; - -let floc = ref (fun _ -> failwith "internal error when computing location");; -let loc_of_token_interval bp ep = - if bp == ep then - if bp == 0 then 0, 1 else let a = snd (!floc (bp - 1)) in a, a + 1 - else - let (bp1, bp2) = !floc bp in - let (ep1, ep2) = !floc (pred ep) in - (if bp1 < ep1 then bp1 else ep1), (if bp2 > ep2 then bp2 else ep2) -;; - -let rec name_of_symbol entry = - function - Snterm e -> "[" ^ e.ename ^ "]" - | Snterml (e, l) -> "[" ^ e.ename ^ " level " ^ l ^ "]" - | Sself | Snext -> "[" ^ entry.ename ^ "]" - | Stoken tok -> entry.egram.glexer.Token.tok_text tok - | _ -> "???" -;; - -let rec get_token_list entry tokl last_tok tree = - match tree with - Node {node = Stoken tok as s; 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) -;; - -let rec name_of_symbol_failed entry = - function - Slist0 s -> name_of_symbol_failed entry s - | Slist0sep (s, _) -> name_of_symbol_failed entry s - | Slist1 s -> name_of_symbol_failed entry s - | Slist1sep (s, _) -> name_of_symbol_failed entry s - | Sopt 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 = - function - Node {node = s; brother = bro; son = son} -> - let tokl = - match s with - Stoken tok -> get_token_list entry [] tok son - | _ -> None - in - begin 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, last_tok, son) -> - List.fold_left - (fun s tok -> - (if s = "" then "" else s ^ " ") ^ - entry.egram.glexer.Token.tok_text tok) - "" tokl - end - | DeadEnd | LocAct (_, _) -> "???" -;; - -let search_tree_in_entry prev_symb tree = - function - Dlevels levels -> - let rec search_levels = - function - [] -> 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 -> - begin 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 - end - | LocAct (_, _) | DeadEnd -> None - and search_symbol symb = - match symb with - Snterm _ | Snterml (_, _) | Slist0 _ | Slist0sep (_, _) | Slist1 _ | - Slist1sep (_, _) | Sopt _ | Stoken _ | Stree _ - when symb == prev_symb -> - Some symb - | Slist0 symb -> - begin match search_symbol symb with - Some symb -> Some (Slist0 symb) - | None -> None - end - | Slist0sep (symb, sep) -> - begin 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 - end - | Slist1 symb -> - begin match search_symbol symb with - Some symb -> Some (Slist1 symb) - | None -> None - end - | Slist1sep (symb, sep) -> - begin 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 - end - | Sopt symb -> - begin match search_symbol symb with - Some symb -> Some (Sopt symb) - | None -> None - end - | Stree t -> - begin match search_tree t with - Some t -> Some (Stree t) - | None -> None - end - | _ -> None - in - search_levels levels - | Dparser _ -> tree -;; - -let error_verbose = ref false;; - -let 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) -> - begin match Obj.magic 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" - end - | Slist1sep (s, sep) -> - begin match Obj.magic 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" - end - | Sopt _ | Stree _ -> txt ^ " expected" - | _ -> txt ^ " expected after " ^ name_of_symbol entry prev_symb - in - if !error_verbose then - begin - let tree = search_tree_in_entry prev_symb tree entry.edesc in - let ppf = err_formatter in - fprintf ppf "@[@,"; - fprintf ppf "----------------------------------@,"; - fprintf ppf "Parse error in entry [%s], rule:@;<0 2>" entry.ename; - fprintf ppf "@["; - print_level ppf pp_force_newline (flatten_tree tree); - fprintf ppf "@]@,"; - fprintf ppf "----------------------------------@,"; - fprintf ppf "@]@." - end; - txt ^ " (in [" ^ entry.ename ^ "])" -;; - -let 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 -;; - -external app : Obj.t -> 'a = "%identity";; - -let is_level_labelled n lev = - match lev.lname with - Some n1 -> n = n1 - | None -> false -;; - -let level_number entry lab = - let rec lookup levn = - function - [] -> failwith ("unknown level " ^ lab) - | lev :: levs -> - if 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 -;; - -let rec top_symb entry = - function - Sself | Snext -> Snterm entry - | Snterml (e, _) -> Snterm e - | Slist1sep (s, sep) -> Slist1sep (top_symb entry s, sep) - | _ -> raise Stream.Failure -;; - -let entry_of_symb entry = - function - Sself | Snext -> entry - | Snterm e -> e - | Snterml (e, _) -> e - | _ -> raise Stream.Failure -;; - -let top_tree entry = - function - Node {node = s; brother = bro; son = son} -> - Node {node = top_symb entry s; brother = bro; son = son} - | LocAct (_, _) | DeadEnd -> raise Stream.Failure -;; - -let skip_if_empty bp p strm = - if Stream.count strm == bp then Gramext.action (fun a -> p strm) - else raise Stream.Failure -;; - -let continue entry bp a s son p1 (strm__ : _ Stream.t) = - let a = (entry_of_symb entry s).econtinue 0 bp a strm__ in - let act = - try p1 strm__ with - Stream.Failure -> raise (Stream.Error (tree_failed entry a s son)) - in - Gramext.action (fun _ -> app act a) -;; - -let do_recover - parser_of_tree entry nlevn alevn bp a s son (strm__ : _ Stream.t) = - try parser_of_tree entry nlevn alevn (top_tree entry son) strm__ with - Stream.Failure -> - try - skip_if_empty bp (fun (strm__ : _ Stream.t) -> raise Stream.Failure) - strm__ - with - Stream.Failure -> - continue entry bp a s son (parser_of_tree entry nlevn alevn son) - strm__ -;; - -let strict_parsing = ref false;; - -let recover parser_of_tree entry nlevn alevn bp a s son strm = - if !strict_parsing then raise (Stream.Error (tree_failed entry a s son)) - else do_recover parser_of_tree entry nlevn alevn bp a s son strm -;; - -let token_count = ref 0;; - -let peek_nth n strm = - let list = Stream.npeek n strm in - token_count := Stream.count strm + n; - let rec loop list n = - match list, n with - x :: _, 1 -> Some x - | _ :: l, n -> loop l (n - 1) - | [], _ -> None - in - loop list n -;; - -let rec parser_of_tree entry nlevn alevn = - function - DeadEnd -> (fun (strm__ : _ Stream.t) -> raise Stream.Failure) - | LocAct (act, _) -> (fun (strm__ : _ Stream.t) -> act) - | Node {node = Sself; son = LocAct (act, _); brother = DeadEnd} -> - (fun (strm__ : _ Stream.t) -> - let a = entry.estart alevn strm__ in app act a) - | Node {node = Sself; son = LocAct (act, _); brother = bro} -> - let p2 = parser_of_tree entry nlevn alevn bro in - (fun (strm__ : _ Stream.t) -> - match - try Some (entry.estart alevn strm__) with - Stream.Failure -> None - with - Some a -> app act a - | _ -> p2 strm__) - | Node {node = s; son = son; brother = DeadEnd} -> - let tokl = - match s with - Stoken tok -> get_token_list entry [] tok son - | _ -> None - in - begin 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__ : _ Stream.t) -> - let bp = Stream.count strm__ in - let a = ps strm__ in - let act = - try p1 bp a strm__ with - Stream.Failure -> raise (Stream.Error "") - in - app 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 (Stoken last_tok) son in - parser_of_token_list entry.egram p1 tokl - end - | Node {node = s; son = son; brother = bro} -> - let tokl = - match s with - Stoken tok -> get_token_list entry [] tok 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__ : _ Stream.t) -> - let bp = Stream.count strm__ in - match - try Some (ps strm__) with - Stream.Failure -> None - with - Some a -> - let act = - try p1 bp a strm__ with - Stream.Failure -> raise (Stream.Error "") - in - app act a - | _ -> p2 strm__) - | Some (tokl, last_tok, son) -> - let p1 = parser_of_tree entry nlevn alevn son in - let p1 = parser_cont p1 entry nlevn alevn (Stoken last_tok) son in - let p1 = parser_of_token_list entry.egram p1 tokl in - let p2 = parser_of_tree entry nlevn alevn bro in - fun (strm__ : _ Stream.t) -> - try p1 strm__ with - Stream.Failure -> p2 strm__ -and parser_cont p1 entry nlevn alevn s son bp a (strm__ : _ Stream.t) = - try p1 strm__ with - Stream.Failure -> - try recover parser_of_tree entry nlevn alevn bp a s son strm__ with - Stream.Failure -> raise (Stream.Error (tree_failed entry a s son)) -and parser_of_token_list gram p1 tokl = - let rec loop n = - function - tok :: tokl -> - let tematch = gram.glexer.Token.tok_match tok in - begin match tokl with - [] -> - let ps strm = - match peek_nth n strm with - Some tok -> - let r = tematch tok in - for i = 1 to n do Stream.junk strm done; Obj.repr r - | None -> raise Stream.Failure - in - (fun (strm__ : _ Stream.t) -> - let bp = Stream.count strm__ in - let a = ps strm__ in - let act = - try p1 bp a strm__ with - Stream.Failure -> raise (Stream.Error "") - in - app act a) - | _ -> - let ps strm = - match peek_nth n strm with - Some tok -> tematch tok - | None -> raise Stream.Failure - in - let p1 = loop (n + 1) tokl in - fun (strm__ : _ Stream.t) -> - let a = ps strm__ in let act = p1 strm__ in app act a - end - | [] -> invalid_arg "parser_of_token_list" - in - loop 1 tokl -and parser_of_symbol entry nlevn = - function - Smeta (_, symbl, act) -> - let act = Obj.magic act entry symbl in - Obj.magic - (List.fold_left - (fun act symb -> Obj.magic act (parser_of_symbol entry nlevn symb)) - act symbl) - | Slist0 s -> - let ps = parser_of_symbol entry nlevn s in - let rec loop al (strm__ : _ Stream.t) = - match - try Some (ps strm__) with - Stream.Failure -> None - with - Some a -> loop (a :: al) strm__ - | _ -> al - in - (fun (strm__ : _ Stream.t) -> - let a = loop [] strm__ in Obj.repr (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 (strm__ : _ Stream.t) = - match - try Some (pt strm__) with - Stream.Failure -> None - with - Some v -> - let a = - try ps strm__ with - Stream.Failure -> - raise (Stream.Error (symb_failed entry v sep symb)) - in - kont (a :: al) strm__ - | _ -> al - in - (fun (strm__ : _ Stream.t) -> - match - try Some (ps strm__) with - Stream.Failure -> None - with - Some a -> Obj.repr (List.rev (kont [a] strm__)) - | _ -> Obj.repr []) - | Slist1 s -> - let ps = parser_of_symbol entry nlevn s in - let rec loop al (strm__ : _ Stream.t) = - match - try Some (ps strm__) with - Stream.Failure -> None - with - Some a -> loop (a :: al) strm__ - | _ -> al - in - (fun (strm__ : _ Stream.t) -> - let a = ps strm__ in Obj.repr (List.rev (loop [a] strm__))) - | 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 (strm__ : _ Stream.t) = - match - try Some (pt strm__) with - Stream.Failure -> None - with - Some v -> - let a = - try ps strm__ with - Stream.Failure -> - try parse_top_symb entry symb strm__ with - Stream.Failure -> - raise (Stream.Error (symb_failed entry v sep symb)) - in - kont (a :: al) strm__ - | _ -> al - in - (fun (strm__ : _ Stream.t) -> - let a = ps strm__ in Obj.repr (List.rev (kont [a] strm__))) - | Sopt s -> - let ps = parser_of_symbol entry nlevn s in - (fun (strm__ : _ Stream.t) -> - match - try Some (ps strm__) with - Stream.Failure -> None - with - Some a -> Obj.repr (Some a) - | _ -> Obj.repr None) - | Stree t -> - let pt = parser_of_tree entry 1 0 t in - (fun (strm__ : _ Stream.t) -> - let bp = Stream.count strm__ in - let a = pt strm__ in - let ep = Stream.count strm__ in - let loc = loc_of_token_interval bp ep in app a loc) - | Snterm e -> (fun (strm__ : _ Stream.t) -> e.estart 0 strm__) - | Snterml (e, l) -> - (fun (strm__ : _ Stream.t) -> e.estart (level_number e l) strm__) - | Sself -> (fun (strm__ : _ Stream.t) -> entry.estart 0 strm__) - | Snext -> (fun (strm__ : _ Stream.t) -> entry.estart nlevn strm__) - | Stoken tok -> - let f = entry.egram.glexer.Token.tok_match tok in - fun strm -> - match Stream.peek strm with - Some tok -> let r = f tok in Stream.junk strm; Obj.repr r - | None -> raise Stream.Failure -and parse_top_symb entry symb = - parser_of_symbol entry 0 (top_symb entry symb) -;; - -let symb_failed_txt e s1 s2 = symb_failed e 0 s1 s2;; - -let rec continue_parser_of_levels entry clevn = - function - [] -> (fun levn bp a (strm__ : _ Stream.t) -> raise Stream.Failure) - | 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 - let (strm__ : _ Stream.t) = strm in - try p1 levn bp a strm__ with - Stream.Failure -> - let act = p2 strm__ in - let ep = Stream.count strm__ in - let a = app act a (loc_of_token_interval bp ep) in - entry.econtinue levn bp a strm -;; - -let rec start_parser_of_levels entry clevn = - function - [] -> (fun levn (strm__ : _ Stream.t) -> raise Stream.Failure) - | 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 (strm__ : _ Stream.t) = strm in - let bp = Stream.count strm__ in - let act = p2 strm__ in - let ep = Stream.count strm__ in - let a = app act (loc_of_token_interval bp ep) in - entry.econtinue levn bp a strm) - | _ -> - fun levn strm -> - if levn > clevn then p1 levn strm - else - let (strm__ : _ Stream.t) = strm in - let bp = Stream.count strm__ in - match - try Some (p2 strm__) with - Stream.Failure -> None - with - Some act -> - let ep = Stream.count strm__ in - let a = app act (loc_of_token_interval bp ep) in - entry.econtinue levn bp a strm - | _ -> p1 levn strm__ -;; - -let continue_parser_of_entry entry = - match entry.edesc with - Dlevels elev -> - let p = continue_parser_of_levels entry 0 elev in - (fun levn bp a (strm__ : _ Stream.t) -> - try p levn bp a strm__ with - Stream.Failure -> a) - | Dparser p -> fun levn bp a (strm__ : _ Stream.t) -> raise Stream.Failure -;; - -let empty_entry ename levn strm = - raise (Stream.Error ("entry [" ^ ename ^ "] is empty")) -;; - -let start_parser_of_entry entry = - match entry.edesc with - Dlevels [] -> empty_entry entry.ename - | Dlevels elev -> start_parser_of_levels entry 0 elev - | Dparser p -> fun levn strm -> p strm -;; - -let parse_parsable entry efun (cs, (ts, fun_loc)) = - let restore = - let old_floc = !floc in - let old_tc = !token_count in - fun () -> floc := old_floc; token_count := old_tc - in - let get_loc () = - try - let cnt = Stream.count ts in - let loc = fun_loc cnt in - if !token_count - 1 <= cnt then loc - else fst loc, snd (fun_loc (!token_count - 1)) - with - _ -> Stream.count cs, Stream.count cs + 1 - in - floc := fun_loc; - token_count := 0; - try let r = efun ts in restore (); r with - Stream.Failure -> - let loc = get_loc () in - restore (); - raise_with_loc loc (Stream.Error ("illegal begin of " ^ entry.ename)) - | Stream.Error _ as exc -> - let loc = get_loc () in restore (); raise_with_loc loc exc - | exc -> - let loc = Stream.count cs, Stream.count cs + 1 in - restore (); raise_with_loc loc exc -;; - -let wrap_parse entry efun cs = - let parsable = cs, entry.egram.glexer.Token.tok_func cs in - parse_parsable entry efun parsable -;; - -let create_toktab () = Hashtbl.create 301;; -let gcreate glexer = {gtokens = create_toktab (); glexer = glexer};; - -let tematch tparse tok = - match tparse tok with - Some p -> (fun x -> p (Stream.ising x)) - | None -> Token.default_match tok -;; -let glexer_of_lexer lexer = - {Token.tok_func = lexer.Token.func; Token.tok_using = lexer.Token.using; - Token.tok_removing = lexer.Token.removing; - Token.tok_match = tematch lexer.Token.tparse; - Token.tok_text = lexer.Token.text; Token.tok_comm = None} -;; -let create lexer = gcreate (glexer_of_lexer lexer);; - -(* Extend syntax *) - -let extend_entry entry position rules = - try - let elev = Gramext.levels_of_rules entry position rules in - entry.edesc <- Dlevels elev; - entry.estart <- - (fun lev strm -> - let f = start_parser_of_entry entry in - entry.estart <- f; f lev strm); - entry.econtinue <- - fun lev bp a strm -> - let f = continue_parser_of_entry entry in - entry.econtinue <- f; f lev bp a strm - with - Token.Error s -> - Printf.eprintf "Lexer initialization error:\n- %s\n" s; - flush stderr; - failwith "Grammar.extend" -;; - -let extend entry_rules_list = - let gram = ref None in - List.iter - (fun (entry, position, rules) -> - begin match !gram with - Some g -> - if g != entry.egram then - begin - Printf.eprintf "Error: entries with different grammars\n"; - flush stderr; - failwith "Grammar.extend" - end - | None -> gram := Some entry.egram - end; - extend_entry entry position rules) - entry_rules_list -;; - -(* Deleting a rule *) - -let delete_rule entry sl = - match entry.edesc with - Dlevels levs -> - let levs = Gramext.delete_rule_in_level_list entry sl levs in - entry.edesc <- Dlevels levs; - entry.estart <- - (fun lev strm -> - let f = start_parser_of_entry entry in - entry.estart <- f; f lev strm); - entry.econtinue <- - (fun lev bp a strm -> - let f = continue_parser_of_entry entry in - entry.econtinue <- f; f lev bp a strm) - | Dparser _ -> () -;; - -(* Unsafe *) - -let clear_entry e = - e.estart <- (fun _ (strm__ : _ Stream.t) -> raise Stream.Failure); - e.econtinue <- (fun _ _ _ (strm__ : _ Stream.t) -> raise Stream.Failure); - match e.edesc with - Dlevels _ -> e.edesc <- Dlevels [] - | Dparser _ -> () -;; - -let gram_reinit g glexer = Hashtbl.clear g.gtokens; g.glexer <- glexer;; - -let reinit_gram g lexer = gram_reinit g (glexer_of_lexer lexer);; - -module Unsafe = - struct - let gram_reinit = gram_reinit;; - let clear_entry = clear_entry;; - let reinit_gram = reinit_gram;; - end -;; - -let find_entry e s = - let rec find_levels = - function - [] -> None - | lev :: levs -> - match find_tree lev.lsuffix with - None -> - begin match find_tree lev.lprefix with - None -> find_levels levs - | x -> x - end - | x -> x - and find_symbol = - function - 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 _ -> None - and find_symbol_list = - function - s :: sl -> - begin match find_symbol s with - None -> find_symbol_list sl - | x -> x - end - | [] -> None - and find_tree = - function - Node {node = s; brother = bro; son = son} -> - begin match find_symbol s with - None -> - begin match find_tree bro with - None -> find_tree son - | x -> x - end - | x -> x - end - | LocAct (_, _) | DeadEnd -> None - in - match e.edesc with - Dlevels levs -> - begin match find_levels levs with - Some e -> e - | None -> raise Not_found - end - | Dparser _ -> raise Not_found -;; - -let of_entry e = e.egram;; - -module Entry = - struct - type te = Token.t;; - type 'a e = te g_entry;; - let create g n = - {egram = g; ename = n; estart = empty_entry n; - econtinue = (fun _ _ _ (strm__ : _ Stream.t) -> raise Stream.Failure); - edesc = Dlevels []} - ;; - let parse (entry : 'a e) cs : 'a = - Obj.magic (wrap_parse entry (entry.estart 0) cs) - ;; - let parse_token (entry : 'a e) ts : 'a = Obj.magic (entry.estart 0 ts);; - let name e = e.ename;; - let of_parser g n (p : te Stream.t -> 'a) : 'a e = - {egram = g; ename = n; estart = (fun _ -> Obj.magic p); - econtinue = (fun _ _ _ (strm__ : _ Stream.t) -> raise Stream.Failure); - edesc = Dparser (Obj.magic p)} - ;; - external obj : 'a e -> te Gramext.g_entry = "%identity";; - let print e = printf "%a@." print_entry (obj e);; - let find e s = find_entry (obj e) s;; - end -;; - -let tokens g con = - let list = ref [] in - Hashtbl.iter - (fun (p_con, p_prm) c -> if p_con = con then list := (p_prm, !c) :: !list) - g.gtokens; - !list -;; - -let glexer g = g.glexer;; - -let warning_verbose = Gramext.warning_verbose;; - -(* Functorial interface *) - -module type GLexerType = sig type te;; val lexer : te Token.glexer;; end;; - -module type S = - sig - type te;; - type parsable;; - val parsable : char Stream.t -> parsable;; - val tokens : string -> (string * int) list;; - val glexer : te Token.glexer;; - module Entry : - sig - type 'a e;; - val create : string -> 'a e;; - val parse : 'a e -> parsable -> 'a;; - val parse_token : 'a e -> te Stream.t -> 'a;; - val name : 'a e -> string;; - val of_parser : string -> (te Stream.t -> 'a) -> 'a e;; - val print : 'a e -> unit;; - external obj : 'a e -> te Gramext.g_entry = "%identity";; - end - ;; - module Unsafe : - sig - val gram_reinit : te Token.glexer -> unit;; - val clear_entry : 'a Entry.e -> unit;; - val reinit_gram : Token.lexer -> unit;; - end - ;; - val extend : - 'a Entry.e -> Gramext.position option -> - (string option * Gramext.g_assoc option * - (te Gramext.g_symbol list * Gramext.g_action) list) - list -> - unit;; - val delete_rule : 'a Entry.e -> te Gramext.g_symbol list -> unit;; - end -;; - -module type ReinitType = sig val reinit_gram : g -> Token.lexer -> unit;; end -;; - -module GGMake (R : ReinitType) (L : GLexerType) = - struct - type te = L.te;; - type parsable = char Stream.t * (te Stream.t * Token.location_function);; - let gram = gcreate L.lexer;; - let parsable cs = cs, L.lexer.Token.tok_func cs;; - let tokens = tokens gram;; - let glexer = glexer gram;; - module Entry = - struct - type 'a e = te g_entry;; - let create n = - {egram = gram; ename = n; estart = empty_entry n; - econtinue = - (fun _ _ _ (strm__ : _ Stream.t) -> raise Stream.Failure); - edesc = Dlevels []} - ;; - external obj : 'a e -> te Gramext.g_entry = "%identity";; - let parse (e : 'a e) p : 'a = - Obj.magic (parse_parsable e (e.estart 0) p) - ;; - let parse_token (e : 'a e) ts : 'a = Obj.magic (e.estart 0 ts);; - let name e = e.ename;; - let of_parser n (p : te Stream.t -> 'a) : 'a e = - {egram = gram; ename = n; estart = (fun _ -> Obj.magic p); - econtinue = - (fun _ _ _ (strm__ : _ Stream.t) -> raise Stream.Failure); - edesc = Dparser (Obj.magic p)} - ;; - let print e = printf "%a@." print_entry (obj e);; - end - ;; - module Unsafe = - struct - let gram_reinit = gram_reinit gram;; - let clear_entry = Unsafe.clear_entry;; - let reinit_gram = R.reinit_gram (Obj.magic gram);; - end - ;; - let extend = extend_entry;; - let delete_rule e r = delete_rule (Entry.obj e) r;; - end -;; - -module GMake (L : GLexerType) = - GGMake - (struct - let reinit_gram _ _ = - failwith "call of deprecated reinit_gram in grammar built by GMake" - ;; - end) - (L) -;; - -module type LexerType = sig val lexer : Token.lexer;; end;; - -module Make (L : LexerType) = - GGMake (struct let reinit_gram = reinit_gram;; end) - (struct type te = Token.t;; let lexer = glexer_of_lexer L.lexer;; end) -;; diff --git a/camlp4/ocaml_src/lib/grammar.mli b/camlp4/ocaml_src/lib/grammar.mli deleted file mode 100644 index d38b449f95..0000000000 --- a/camlp4/ocaml_src/lib/grammar.mli +++ /dev/null @@ -1,200 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* This file has been generated by program: do not edit! *) - -(** Extensible grammars. - - This module implements the Camlp4 extensible grammars system. - Grammars entries can be extended using the [EXTEND] statement, - added by loading the Camlp4 [pa_extend.cmo] file. *) - -type g;; - (** The type for grammars, holding entries. *) -val gcreate : Token.t Token.glexer -> g;; - (** Create a new grammar, without keywords, using the lexer given - as parameter. *) -val tokens : g -> string -> (string * int) list;; - (** Given a grammar and a token pattern constructor, returns the list of - the corresponding values currently used in all entries of this grammar. - The integer is the number of times this pattern value is used. - - Examples: -- If the associated lexer uses ("", xxx) to represent a keyword - (what is represented by then simple string xxx in an [EXTEND] - statement rule), the call [Grammar.token g ""] returns the keywords - list. -- The call [Grammar.token g "IDENT"] returns the list of all usages - of the pattern "IDENT" in the [EXTEND] statements. *) -val glexer : g -> Token.t Token.glexer;; - (** Return the lexer used by the grammar *) - -module Entry : - sig - type 'a e;; - val create : g -> string -> 'a e;; - val parse : 'a e -> char Stream.t -> 'a;; - val parse_token : 'a e -> Token.t Stream.t -> 'a;; - val name : 'a e -> string;; - val of_parser : g -> string -> (Token.t Stream.t -> 'a) -> 'a e;; - val print : 'a e -> unit;; - val find : 'a e -> string -> Obj.t e;; - external obj : 'a e -> Token.t Gramext.g_entry = "%identity";; - end -;; - (** Module to handle entries. -- [Entry.e] is the type for entries returning values of type ['a]. -- [Entry.create g n] creates a new entry named [n] in the grammar [g]. -- [Entry.parse e] returns the stream parser of the entry [e]. -- [Entry.parse_token e] returns the token parser of the entry [e]. -- [Entry.name e] returns the name of the entry [e]. -- [Entry.of_parser g n p] makes an entry from a token stream parser. -- [Entry.print e] displays the entry [e] using [Format]. -- [Entry.find e s] finds the entry named [s] in [e]'s rules. -- [Entry.obj e] converts an entry into a [Gramext.g_entry] allowing -- to see what it holds ([Gramext] is visible, but not documented). *) - -val of_entry : 'a Entry.e -> g;; - (** Return the grammar associated with an entry. *) - -(** {6 Clearing grammars and entries} *) - -module Unsafe : - sig - val gram_reinit : g -> Token.t Token.glexer -> unit;; - val clear_entry : 'a Entry.e -> unit;; - val reinit_gram : g -> Token.lexer -> unit;; - end -;; - (** Module for clearing grammars and entries. To be manipulated with - care, because: 1) reinitializing a grammar destroys all tokens - and there may have problems with the associated lexer if it has - a notion of keywords; 2) clearing an entry does not destroy the - tokens used only by itself. -- [Unsafe.reinit_gram g lex] removes the tokens of the grammar -- and sets [lex] as a new lexer for [g]. Warning: the lexer -- itself is not reinitialized. -- [Unsafe.clear_entry e] removes all rules of the entry [e]. *) - -(** {6 Functorial interface} *) - - (** Alternative for grammars use. Grammars are no more Ocaml values: - there is no type for them. Modules generated preserve the - rule "an entry cannot call an entry of another grammar" by - normal OCaml typing. *) - -module type GLexerType = sig type te;; val lexer : te Token.glexer;; end;; - (** The input signature for the functor [Grammar.GMake]: [te] is the - type of the tokens. *) - -module type S = - sig - type te;; - type parsable;; - val parsable : char Stream.t -> parsable;; - val tokens : string -> (string * int) list;; - val glexer : te Token.glexer;; - module Entry : - sig - type 'a e;; - val create : string -> 'a e;; - val parse : 'a e -> parsable -> 'a;; - val parse_token : 'a e -> te Stream.t -> 'a;; - val name : 'a e -> string;; - val of_parser : string -> (te Stream.t -> 'a) -> 'a e;; - val print : 'a e -> unit;; - external obj : 'a e -> te Gramext.g_entry = "%identity";; - end - ;; - module Unsafe : - sig - val gram_reinit : te Token.glexer -> unit;; - val clear_entry : 'a Entry.e -> unit;; - val reinit_gram : Token.lexer -> unit;; - end - ;; - val extend : - 'a Entry.e -> Gramext.position option -> - (string option * Gramext.g_assoc option * - (te Gramext.g_symbol list * Gramext.g_action) list) - list -> - unit;; - val delete_rule : 'a Entry.e -> te Gramext.g_symbol list -> unit;; - end -;; - (** Signature type of the functor [Grammar.GMake]. The types and - functions are almost the same than in generic interface, but: -- Grammars are not values. Functions holding a grammar as parameter - do not have this parameter yet. -- The type [parsable] is used in function [parse] instead of - the char stream, avoiding the possible loss of tokens. -- The type of tokens (expressions and patterns) can be any - type (instead of (string * string)); the module parameter - must specify a way to show them as (string * string) *) - -module GMake (L : GLexerType) : S with type te = L.te;; - -(** {6 Miscellaneous} *) - -val error_verbose : bool ref;; - (** Flag for displaying more information in case of parsing error; - default = [False] *) - -val warning_verbose : bool ref;; - (** Flag for displaying warnings while extension; default = [True] *) - -val strict_parsing : bool ref;; - (** Flag to apply strict parsing, without trying to recover errors; - default = [False] *) - -val print_entry : Format.formatter -> 'te Gramext.g_entry -> unit;; - (** General printer for all kinds of entries (obj entries) *) - -val iter_entry : - ('te Gramext.g_entry -> unit) -> 'te Gramext.g_entry -> unit;; - (** [Grammar.iter_entry f e] applies [f] to the entry [e] and - transitively all entries called by [e]. The order in which - the entries are passed to [f] is the order they appear in - each entry. Each entry is passed only once. *) - -val fold_entry : - ('te Gramext.g_entry -> 'a -> 'a) -> 'te Gramext.g_entry -> 'a -> 'a;; - (** [Grammar.fold_entry f e init] computes [(f eN .. (f e2 (f e1 init)))], - where [e1 .. eN] are [e] and transitively all entries called by [e]. - The order in which the entries are passed to [f] is the order they - appear in each entry. Each entry is passed only once. *) - -(**/**) - -(*** deprecated since version 3.05; use rather the functor GMake *) -module type LexerType = sig val lexer : Token.lexer;; end;; -module Make (L : LexerType) : S with type te = Token.t;; -(*** deprecated since version 3.05; use rather the function gcreate *) -val create : Token.lexer -> g;; - -(*** For system use *) - -val loc_of_token_interval : int -> int -> int * int;; -val extend : - ('te Gramext.g_entry * Gramext.position option * - (string option * Gramext.g_assoc option * - ('te Gramext.g_symbol list * Gramext.g_action) list) - list) - list -> - unit;; -val delete_rule : 'a Entry.e -> Token.t Gramext.g_symbol list -> unit;; - -val parse_top_symb : - 'te Gramext.g_entry -> 'te Gramext.g_symbol -> 'te Stream.t -> Obj.t;; -val symb_failed_txt : - 'te Gramext.g_entry -> 'te Gramext.g_symbol -> 'te Gramext.g_symbol -> - string;; diff --git a/camlp4/ocaml_src/lib/plexer.ml b/camlp4/ocaml_src/lib/plexer.ml deleted file mode 100644 index 4b5dcca151..0000000000 --- a/camlp4/ocaml_src/lib/plexer.ml +++ /dev/null @@ -1,1258 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* This file has been generated by program: do not edit! *) - -open Stdpp;; -open Token;; - -let no_quotations = ref false;; - -(* The string buffering machinery *) - -let buff = ref (String.create 80);; -let store len x = - if len >= String.length !buff then - buff := !buff ^ String.create (String.length !buff); - !buff.[len] <- x; - succ len -;; -let mstore len s = - let rec add_rec len i = - if i == String.length s then len else add_rec (store len s.[i]) (succ i) - in - add_rec len 0 -;; -let get_buff len = String.sub !buff 0 len;; - -(* The lexer *) - -let stream_peek_nth n strm = - let rec loop n = - function - [] -> None - | [x] -> if n == 1 then Some x else None - | _ :: l -> loop (n - 1) l - in - loop n (Stream.npeek n strm) -;; - -let rec ident len (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some - ('A'..'Z' | 'a'..'z' | '\192'..'\214' | '\216'..'\246' | - '\248'..'\255' | '0'..'9' | '_' | '\'' as c) -> - Stream.junk strm__; ident (store len c) strm__ - | _ -> len -and ident2 len (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some - ('!' | '?' | '~' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' | '%' | - '.' | ':' | '<' | '>' | '|' | '$' as c) -> - Stream.junk strm__; ident2 (store len c) strm__ - | _ -> len -and ident3 len (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some - ('0'..'9' | 'A'..'Z' | 'a'..'z' | '\192'..'\214' | '\216'..'\246' | - '\248'..'\255' | '_' | '!' | '%' | '&' | '*' | '+' | '-' | '.' | '/' | - ':' | '<' | '=' | '>' | '?' | '@' | '^' | '|' | '~' | '\'' | '$' as c - ) -> - Stream.junk strm__; ident3 (store len c) strm__ - | _ -> len -and base_number len (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some ('o' | 'O') -> - Stream.junk strm__; digits octal (store len 'o') strm__ - | Some ('x' | 'X') -> Stream.junk strm__; digits hexa (store len 'x') strm__ - | Some ('b' | 'B') -> - Stream.junk strm__; digits binary (store len 'b') strm__ - | _ -> number len strm__ -and digits kind len (strm__ : _ Stream.t) = - let d = - try kind strm__ with - Stream.Failure -> raise (Stream.Error "ill-formed integer constant") - in - digits_under kind (store len d) strm__ -and digits_under kind len (strm__ : _ Stream.t) = - match - try Some (kind strm__) with - Stream.Failure -> None - with - Some d -> digits_under kind (store len d) strm__ - | _ -> - match Stream.peek strm__ with - Some '_' -> Stream.junk strm__; digits_under kind len strm__ - | _ -> "INT", get_buff len -and octal (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some ('0'..'7' as d) -> Stream.junk strm__; d - | _ -> raise Stream.Failure -and hexa (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some ('0'..'9' | 'a'..'f' | 'A'..'F' as d) -> Stream.junk strm__; d - | _ -> raise Stream.Failure -and binary (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some ('0'..'1' as d) -> Stream.junk strm__; d - | _ -> raise Stream.Failure -and number len (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some ('0'..'9' as c) -> Stream.junk strm__; number (store len c) strm__ - | Some '_' -> Stream.junk strm__; number len strm__ - | Some '.' -> Stream.junk strm__; decimal_part (store len '.') strm__ - | Some ('e' | 'E') -> - Stream.junk strm__; exponent_part (store len 'E') strm__ - | Some 'l' -> Stream.junk strm__; "INT32", get_buff len - | Some 'L' -> Stream.junk strm__; "INT64", get_buff len - | Some 'n' -> Stream.junk strm__; "NATIVEINT", get_buff len - | _ -> "INT", get_buff len -and decimal_part len (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some ('0'..'9' as c) -> - Stream.junk strm__; decimal_part (store len c) strm__ - | Some '_' -> Stream.junk strm__; decimal_part len strm__ - | Some ('e' | 'E') -> - Stream.junk strm__; exponent_part (store len 'E') strm__ - | _ -> "FLOAT", get_buff len -and exponent_part len (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some ('+' | '-' as c) -> - Stream.junk strm__; end_exponent_part (store len c) strm__ - | _ -> end_exponent_part len strm__ -and end_exponent_part len (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some ('0'..'9' as c) -> - Stream.junk strm__; end_exponent_part_under (store len c) strm__ - | _ -> raise (Stream.Error "ill-formed floating-point constant") -and end_exponent_part_under len (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some ('0'..'9' as c) -> - Stream.junk strm__; end_exponent_part_under (store len c) strm__ - | Some '_' -> Stream.junk strm__; end_exponent_part_under len strm__ - | _ -> "FLOAT", get_buff len -;; - -let error_on_unknown_keywords = ref false;; -let err loc msg = raise_with_loc loc (Token.Error msg);; - -(* -value next_token_fun dfa find_kwd = - let keyword_or_error loc s = - try (("", find_kwd s), loc) with - [ Not_found -> - if error_on_unknown_keywords.val then err loc ("illegal token: " ^ s) - else (("", s), loc) ] - in - let rec next_token = - parser bp - [ [: `' ' | '\010' | '\013' | '\t' | '\026' | '\012'; s :] -> - next_token s - | [: `'('; s :] -> left_paren bp s - | [: `'#'; s :] -> do { spaces_tabs s; linenum bp s } - | [: `('A'..'Z' | '\192'..'\214' | '\216'..'\222' as c); s :] -> - let id = get_buff (ident (store 0 c) s) in - let loc = (bp, Stream.count s) in - (try ("", find_kwd id) with [ Not_found -> ("UIDENT", id) ], loc) - | [: `('a'..'z' | '\223'..'\246' | '\248'..'\255' | '_' as c); s :] -> - let id = get_buff (ident (store 0 c) s) in - let loc = (bp, Stream.count s) in - (try ("", find_kwd id) with [ Not_found -> ("LIDENT", id) ], loc) - | [: `('1'..'9' as c); s :] -> - let tok = number (store 0 c) s in - let loc = (bp, Stream.count s) in - (tok, loc) - | [: `'0'; s :] -> - let tok = base_number (store 0 '0') s in - let loc = (bp, Stream.count s) in - (tok, loc) - | [: `'''; s :] -> - match Stream.npeek 3 s with - [ [_; '''; _] | ['\\'; _; _] | ['\x0D'; '\x0A'; '''] -> - let tok = ("CHAR", get_buff (char bp 0 s)) in - let loc = (bp, Stream.count s) in - (tok, loc) - | _ -> keyword_or_error (bp, Stream.count s) "'" ] - | [: `'"'; s :] -> - let tok = ("STRING", get_buff (string bp 0 s)) in - let loc = (bp, Stream.count s) in - (tok, loc) - | [: `'$'; s :] -> - let tok = dollar bp 0 s in - let loc = (bp, Stream.count s) in - (tok, loc) - | [: `('!' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' | '%' as c); - s :] -> - let id = get_buff (ident2 (store 0 c) s) in - keyword_or_error (bp, Stream.count s) id - | [: `('~' as c); - a = - parser - [ [: `('a'..'z' as c); len = ident (store 0 c) :] ep -> - (("TILDEIDENT", get_buff len), (bp, ep)) - | [: s :] -> - let id = get_buff (ident2 (store 0 c) s) in - keyword_or_error (bp, Stream.count s) id ] :] -> - a - | [: `('?' as c); - a = - parser - [ [: `('a'..'z' as c); len = ident (store 0 c) :] ep -> - (("QUESTIONIDENT", get_buff len), (bp, ep)) - | [: s :] -> - let id = get_buff (ident2 (store 0 c) s) in - keyword_or_error (bp, Stream.count s) id ] :] -> - a - | [: `'<'; s :] -> less bp s - | [: `(':' as c1); - len = - parser - [ [: `(']' | ':' | '=' | '>' as c2) :] -> store (store 0 c1) c2 - | [: :] -> store 0 c1 ] :] ep -> - let id = get_buff len in - keyword_or_error (bp, ep) id - | [: `('>' | '|' as c1); - len = - parser - [ [: `(']' | '}' as c2) :] -> store (store 0 c1) c2 - | [: a = ident2 (store 0 c1) :] -> a ] :] ep -> - let id = get_buff len in - keyword_or_error (bp, ep) id - | [: `('[' | '{' as c1); s :] -> - let len = - match Stream.npeek 2 s with - [ ['<'; '<' | ':'] -> store 0 c1 - | _ -> - match s with parser - [ [: `('|' | '<' | ':' as c2) :] -> store (store 0 c1) c2 - | [: :] -> store 0 c1 ] ] - in - let ep = Stream.count s in - let id = get_buff len in - keyword_or_error (bp, ep) id - | [: `'.'; - id = - parser - [ [: `'.' :] -> ".." - | [: :] -> if ssd && after_space then " ." else "." ] :] ep -> - keyword_or_error (bp, ep) id - | [: `';'; - id = - parser - [ [: `';' :] -> ";;" - | [: :] -> ";" ] :] ep -> - keyword_or_error (bp, ep) id - | [: `'\\'; s :] ep -> (("LIDENT", get_buff (ident3 0 s)), (bp, ep)) - | [: `c :] ep -> keyword_or_error (bp, ep) (String.make 1 c) - | [: _ = Stream.empty :] -> (("EOI", ""), (bp, succ bp)) ] - and less bp strm = - if no_quotations.val then - match strm with parser - [ [: len = ident2 (store 0 '<') :] ep -> - let id = get_buff len in - keyword_or_error (bp, ep) id ] - else - match strm with parser - [ [: `'<'; len = quotation bp 0 :] ep -> - (("QUOTATION", ":" ^ get_buff len), (bp, ep)) - | [: `':'; i = parser [: len = ident 0 :] -> get_buff len; - `'<' ? "character '<' expected"; len = quotation bp 0 :] ep -> - (("QUOTATION", i ^ ":" ^ get_buff len), (bp, ep)) - | [: len = ident2 (store 0 '<') :] ep -> - let id = get_buff len in - keyword_or_error (bp, ep) id ] - and string bp len = - parser - [ [: `'"' :] -> len - | [: `'\\'; `c; s :] -> string bp (store (store len '\\') c) s - | [: `c; s :] -> string bp (store len c) s - | [: :] ep -> err (bp, ep) "string not terminated" ] - and char bp len = - parser - [ [: `'''; s :] -> if len = 0 then char bp (store len ''') s else len - | [: `'\\'; `c; s :] -> char bp (store (store len '\\') c) s - | [: `c; s :] -> char bp (store len c) s - | [: :] ep -> err (bp, ep) "char not terminated" ] - and dollar bp len = - parser - [ [: `'$' :] -> ("ANTIQUOT", ":" ^ get_buff len) - | [: `('a'..'z' | 'A'..'Z' as c); s :] -> antiquot bp (store len c) s - | [: `('0'..'9' as c); s :] -> maybe_locate bp (store len c) s - | [: `':'; s :] -> - let k = get_buff len in - ("ANTIQUOT", k ^ ":" ^ locate_or_antiquot_rest bp 0 s) - | [: `'\\'; `c; s :] -> - ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s) - | [: s :] -> - if dfa then - match s with parser - [ [: `c :] -> - ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s) - | [: :] ep -> err (bp, ep) "antiquotation not terminated" ] - else ("", get_buff (ident2 (store 0 '$') s)) ] - and maybe_locate bp len = - parser - [ [: `'$' :] -> ("ANTIQUOT", ":" ^ get_buff len) - | [: `('0'..'9' as c); s :] -> maybe_locate bp (store len c) s - | [: `':'; s :] -> - ("LOCATE", get_buff len ^ ":" ^ locate_or_antiquot_rest bp 0 s) - | [: `'\\'; `c; s :] -> - ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s) - | [: `c; s :] -> - ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s) - | [: :] ep -> err (bp, ep) "antiquotation not terminated" ] - and antiquot bp len = - parser - [ [: `'$' :] -> ("ANTIQUOT", ":" ^ get_buff len) - | [: `('a'..'z' | 'A'..'Z' | '0'..'9' as c); s :] -> - antiquot bp (store len c) s - | [: `':'; s :] -> - let k = get_buff len in - ("ANTIQUOT", k ^ ":" ^ locate_or_antiquot_rest bp 0 s) - | [: `'\\'; `c; s :] -> - ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s) - | [: `c; s :] -> - ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s) - | [: :] ep -> err (bp, ep) "antiquotation not terminated" ] - and locate_or_antiquot_rest bp len = - parser - [ [: `'$' :] -> get_buff len - | [: `'\\'; `c; s :] -> locate_or_antiquot_rest bp (store len c) s - | [: `c; s :] -> locate_or_antiquot_rest bp (store len c) s - | [: :] ep -> err (bp, ep) "antiquotation not terminated" ] - and quotation bp len = - parser - [ [: `'>'; s :] -> maybe_end_quotation bp len s - | [: `'<'; s :] -> - quotation bp (maybe_nested_quotation bp (store len '<') s) s - | [: `'\\'; - len = - parser - [ [: `('>' | '<' | '\\' as c) :] -> store len c - | [: :] -> store len '\\' ]; - s :] -> - quotation bp len s - | [: `c; s :] -> quotation bp (store len c) s - | [: :] ep -> err (bp, ep) "quotation not terminated" ] - and maybe_nested_quotation bp len = - parser - [ [: `'<'; s :] -> mstore (quotation bp (store len '<') s) ">>" - | [: `':'; len = ident (store len ':'); - a = - parser - [ [: `'<'; s :] -> mstore (quotation bp (store len '<') s) ">>" - | [: :] -> len ] :] -> - a - | [: :] -> len ] - and maybe_end_quotation bp len = - parser - [ [: `'>' :] -> len - | [: a = quotation bp (store len '>') :] -> a ] - and left_paren bp = - parser - [ [: `'*'; _ = comment bp; a = next_token True :] -> a - | [: :] ep -> keyword_or_error (bp, ep) "(" ] - and comment bp = - parser - [ [: `'('; s :] -> left_paren_in_comment bp s - | [: `'*'; s :] -> star_in_comment bp s - | [: `'"'; _ = string bp 0; s :] -> comment bp s - | [: `'''; s :] -> quote_in_comment bp s - | [: `c; s :] -> comment bp s - | [: :] ep -> err (bp, ep) "comment not terminated" ] - and quote_in_comment bp = - parser - [ [: `'''; s :] -> comment bp s - | [: `'\013'; s :] -> quote_cr_in_comment bp s - | [: `'\\'; s :] -> quote_antislash_in_comment bp s - | [: `'('; s :] -> quote_left_paren_in_comment bp s - | [: `'*'; s :] -> quote_star_in_comment bp s - | [: `'"'; s :] -> quote_doublequote_in_comment bp s - | [: `_; s :] -> quote_any_in_comment bp s - | [: s :] -> comment bp s ] - and quote_any_in_comment bp = - parser - [ [: `'''; s :] -> comment bp s - | [: s :] -> comment bp s ] - and quote_cr_in_comment bp = - parser - [ [: `'\010'; s :] -> quote_any_in_comment bp s - | [: s :] -> quote_any_in_comment bp s ] - and quote_left_paren_in_comment bp = - parser - [ [: `'''; s :] -> comment bp s - | [: s :] -> left_paren_in_comment bp s ] - and quote_star_in_comment bp = - parser - [ [: `'''; s :] -> comment bp s - | [: s :] -> star_in_comment bp s ] - and quote_doublequote_in_comment bp = - parser - [ [: `'''; s :] -> comment bp s - | [: _ = string bp 0; s :] -> comment bp s ] - and quote_antislash_in_comment bp = - parser - [ [: `'''; s :] -> quote_antislash_quote_in_comment bp s - | [: `('\\' | '"' | 'n' | 't' | 'b' | 'r'); s :] -> - quote_any_in_comment bp s - | [: `('0'..'9'); s :] -> quote_antislash_digit_in_comment bp s - | [: `'x'; s :] -> quote_antislash_x_in_comment bp s - | [: s :] -> comment bp s ] - and quote_antislash_quote_in_comment bp = - parser - [ [: `'''; s :] -> comment bp s - | [: s :] -> quote_in_comment bp s ] - and quote_antislash_digit_in_comment bp = - parser - [ [: `('0'..'9'); s :] -> quote_antislash_digit2_in_comment bp s - | [: s :] -> comment bp s ] - and quote_antislash_digit2_in_comment bp = - parser - [ [: `('0'..'9'); s :] -> quote_any_in_comment bp s - | [: s :] -> comment bp s ] - and quote_antislash_x_in_comment bp = - parser - [ [: _ = hexa; s :] -> quote_antislash_x_digit_in_comment bp s - | [: s :] -> comment bp s ] - and quote_antislash_x_digit_in_comment bp = - parser - [ [: _ = hexa; s :] -> quote_any_in_comment bp s - | [: s :] -> comment bp s ] - and left_paren_in_comment bp = - parser - [ [: `'*'; s :] -> do { comment bp s; comment bp s } - | [: a = comment bp :] -> a ] - and star_in_comment bp = - parser - [ [: `')' :] -> () - | [: a = comment bp :] -> a ] - and linedir n s = - match stream_peek_nth n s with - [ Some (' ' | '\t') -> linedir (n + 1) s - | Some ('0'..'9') -> linedir_digits (n + 1) s - | _ -> False ] - and linedir_digits n s = - match stream_peek_nth n s with - [ Some ('0'..'9') -> linedir_digits (n + 1) s - | _ -> linedir_quote n s ] - and linedir_quote n s = - match stream_peek_nth n s with - [ Some (' ' | '\t') -> linedir_quote (n + 1) s - | Some '"' -> True - | _ -> False ] - and any_to_nl = - parser - [ [: `'\013' | '\010' :] ep -> bolpos.val := ep - | [: `_; s :] -> any_to_nl s - | [: :] -> () ] - in - fun cstrm -> - try - let glex = glexr.val in - let comm_bp = Stream.count cstrm in - let r = next_token False cstrm in - do { - match glex.tok_comm with - [ Some list -> - if fst (snd r) > comm_bp then - let comm_loc = (comm_bp, fst (snd r)) in - glex.tok_comm := Some [comm_loc :: list] - else () - | None -> () ]; - r - } - with - [ Stream.Error str -> - err (Stream.count cstrm, Stream.count cstrm + 1) str ] -; -*) - -let next_token_fun dfa ssd find_kwd bolpos glexr = - let keyword_or_error loc s = - try ("", find_kwd s), loc with - Not_found -> - if !error_on_unknown_keywords then err loc ("illegal token: " ^ s) - else ("", s), loc - in - let error_if_keyword ((_, id), loc as a) = - try - ignore (find_kwd id); - err loc ("illegal use of a keyword as a label: " ^ id) - with - Not_found -> a - in - let rec next_token after_space (strm__ : _ Stream.t) = - let bp = Stream.count strm__ in - match Stream.peek strm__ with - Some ('\010' | '\013') -> - Stream.junk strm__; - let s = strm__ in - let ep = Stream.count strm__ in bolpos := ep; next_token true s - | Some (' ' | '\t' | '\026' | '\012') -> - Stream.junk strm__; next_token true strm__ - | Some '#' when bp = !bolpos -> - Stream.junk strm__; - let s = strm__ in - if linedir 1 s then begin any_to_nl s; next_token true s end - else keyword_or_error (bp, bp + 1) "#" - | Some '(' -> Stream.junk strm__; left_paren bp strm__ - | Some ('A'..'Z' | '\192'..'\214' | '\216'..'\222' as c) -> - Stream.junk strm__; - let s = strm__ in - let id = get_buff (ident (store 0 c) s) in - let loc = bp, Stream.count s in - (try "", find_kwd id with - Not_found -> "UIDENT", id), - loc - | Some ('a'..'z' | '\223'..'\246' | '\248'..'\255' | '_' as c) -> - Stream.junk strm__; - let s = strm__ in - let id = get_buff (ident (store 0 c) s) in - let loc = bp, Stream.count s in - (try "", find_kwd id with - Not_found -> "LIDENT", id), - loc - | Some ('1'..'9' as c) -> - Stream.junk strm__; - let tok = number (store 0 c) strm__ in - let loc = bp, Stream.count strm__ in tok, loc - | Some '0' -> - Stream.junk strm__; - let tok = base_number (store 0 '0') strm__ in - let loc = bp, Stream.count strm__ in tok, loc - | Some '\'' -> - Stream.junk strm__; - let s = strm__ in - begin match Stream.npeek 2 s with - [_; '\''] | ['\\'; _] -> - let tok = "CHAR", get_buff (char bp 0 s) in - let loc = bp, Stream.count s in tok, loc - | _ -> keyword_or_error (bp, Stream.count s) "'" - end - | Some '\"' -> - Stream.junk strm__; - let tok = "STRING", get_buff (string bp 0 strm__) in - let loc = bp, Stream.count strm__ in tok, loc - | Some '$' -> - Stream.junk strm__; - let tok = dollar bp 0 strm__ in - let loc = bp, Stream.count strm__ in tok, loc - | Some ('!' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' | '%' as c) -> - Stream.junk strm__; - let id = get_buff (ident2 (store 0 c) strm__) in - keyword_or_error (bp, Stream.count strm__) id - | Some ('~' as c) -> - Stream.junk strm__; - begin try - match Stream.peek strm__ with - Some ('a'..'z' as c) -> - Stream.junk strm__; - let len = - try ident (store 0 c) strm__ with - Stream.Failure -> raise (Stream.Error "") - in - let s = strm__ in - let ep = Stream.count strm__ in - let id = get_buff len in - let (strm__ : _ Stream.t) = s in - begin match Stream.peek strm__ with - Some ':' -> - Stream.junk strm__; - let eb = Stream.count strm__ in - error_if_keyword (("LABEL", id), (bp, ep)) - | _ -> error_if_keyword (("TILDEIDENT", id), (bp, ep)) - end - | _ -> - let id = get_buff (ident2 (store 0 c) strm__) in - keyword_or_error (bp, Stream.count strm__) id - with - Stream.Failure -> raise (Stream.Error "") - end - | Some ('?' as c) -> - Stream.junk strm__; - begin try - match Stream.peek strm__ with - Some ('a'..'z' as c) -> - Stream.junk strm__; - let len = - try ident (store 0 c) strm__ with - Stream.Failure -> raise (Stream.Error "") - in - let s = strm__ in - let ep = Stream.count strm__ in - let id = get_buff len in - let (strm__ : _ Stream.t) = s in - begin match Stream.peek strm__ with - Some ':' -> - Stream.junk strm__; - let eb = Stream.count strm__ in - error_if_keyword (("OPTLABEL", id), (bp, ep)) - | _ -> error_if_keyword (("QUESTIONIDENT", id), (bp, ep)) - end - | _ -> - let id = get_buff (ident2 (store 0 c) strm__) in - keyword_or_error (bp, Stream.count strm__) id - with - Stream.Failure -> raise (Stream.Error "") - end - | Some '<' -> Stream.junk strm__; less bp strm__ - | Some (':' as c1) -> - Stream.junk strm__; - let len = - try - match Stream.peek strm__ with - Some (']' | ':' | '=' | '>' as c2) -> - Stream.junk strm__; store (store 0 c1) c2 - | _ -> store 0 c1 - with - Stream.Failure -> raise (Stream.Error "") - in - let ep = Stream.count strm__ in - let id = get_buff len in keyword_or_error (bp, ep) id - | Some ('>' | '|' as c1) -> - Stream.junk strm__; - let len = - try - match Stream.peek strm__ with - Some (']' | '}' as c2) -> - Stream.junk strm__; store (store 0 c1) c2 - | _ -> ident2 (store 0 c1) strm__ - with - Stream.Failure -> raise (Stream.Error "") - in - let ep = Stream.count strm__ in - let id = get_buff len in keyword_or_error (bp, ep) id - | Some ('[' | '{' as c1) -> - Stream.junk strm__; - let s = strm__ in - let len = - match Stream.npeek 2 s with - ['<'; '<' | ':'] -> store 0 c1 - | _ -> - let (strm__ : _ Stream.t) = s in - match Stream.peek strm__ with - Some ('|' | '<' | ':' as c2) -> - Stream.junk strm__; store (store 0 c1) c2 - | _ -> store 0 c1 - in - let ep = Stream.count s in - let id = get_buff len in keyword_or_error (bp, ep) id - | Some '.' -> - Stream.junk strm__; - let id = - try - match Stream.peek strm__ with - Some '.' -> Stream.junk strm__; ".." - | _ -> if ssd && after_space then " ." else "." - with - Stream.Failure -> raise (Stream.Error "") - in - let ep = Stream.count strm__ in keyword_or_error (bp, ep) id - | Some ';' -> - Stream.junk strm__; - let id = - try - match Stream.peek strm__ with - Some ';' -> Stream.junk strm__; ";;" - | _ -> ";" - with - Stream.Failure -> raise (Stream.Error "") - in - let ep = Stream.count strm__ in keyword_or_error (bp, ep) id - | Some '\\' -> - Stream.junk strm__; - let ep = Stream.count strm__ in - ("LIDENT", get_buff (ident3 0 strm__)), (bp, ep) - | Some c -> - Stream.junk strm__; - let ep = Stream.count strm__ in - keyword_or_error (bp, ep) (String.make 1 c) - | _ -> let _ = Stream.empty strm__ in ("EOI", ""), (bp, succ bp) - and less bp strm = - if !no_quotations then - let (strm__ : _ Stream.t) = strm in - let len = ident2 (store 0 '<') strm__ in - let ep = Stream.count strm__ in - let id = get_buff len in keyword_or_error (bp, ep) id - else - let (strm__ : _ Stream.t) = strm in - match Stream.peek strm__ with - Some '<' -> - Stream.junk strm__; - let len = - try quotation bp 0 strm__ with - Stream.Failure -> raise (Stream.Error "") - in - let ep = Stream.count strm__ in - ("QUOTATION", ":" ^ get_buff len), (bp, ep) - | Some ':' -> - Stream.junk strm__; - let i = - try let len = ident 0 strm__ in get_buff len with - Stream.Failure -> raise (Stream.Error "") - in - begin match Stream.peek strm__ with - Some '<' -> - Stream.junk strm__; - let len = - try quotation bp 0 strm__ with - Stream.Failure -> raise (Stream.Error "") - in - let ep = Stream.count strm__ in - ("QUOTATION", i ^ ":" ^ get_buff len), (bp, ep) - | _ -> raise (Stream.Error "character '<' expected") - end - | _ -> - let len = ident2 (store 0 '<') strm__ in - let ep = Stream.count strm__ in - let id = get_buff len in keyword_or_error (bp, ep) id - and string bp len (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some '\"' -> Stream.junk strm__; len - | Some '\\' -> - Stream.junk strm__; - begin match Stream.peek strm__ with - Some c -> - Stream.junk strm__; - let ep = Stream.count strm__ in - string bp (store (store len '\\') c) strm__ - | _ -> raise (Stream.Error "") - end - | Some c -> Stream.junk strm__; string bp (store len c) strm__ - | _ -> - let ep = Stream.count strm__ in err (bp, ep) "string not terminated" - and char bp len (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some '\'' -> - Stream.junk strm__; - let s = strm__ in if len = 0 then char bp (store len '\'') s else len - | Some '\\' -> - Stream.junk strm__; - begin match Stream.peek strm__ with - Some c -> - Stream.junk strm__; char bp (store (store len '\\') c) strm__ - | _ -> raise (Stream.Error "") - end - | Some c -> Stream.junk strm__; char bp (store len c) strm__ - | _ -> let ep = Stream.count strm__ in err (bp, ep) "char not terminated" - and dollar bp len (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some '$' -> Stream.junk strm__; "ANTIQUOT", ":" ^ get_buff len - | Some ('a'..'z' | 'A'..'Z' as c) -> - Stream.junk strm__; antiquot bp (store len c) strm__ - | Some ('0'..'9' as c) -> - Stream.junk strm__; maybe_locate bp (store len c) strm__ - | Some ':' -> - Stream.junk strm__; - let k = get_buff len in - "ANTIQUOT", k ^ ":" ^ locate_or_antiquot_rest bp 0 strm__ - | Some '\\' -> - Stream.junk strm__; - begin match Stream.peek strm__ with - Some c -> - Stream.junk strm__; - "ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) strm__ - | _ -> raise (Stream.Error "") - end - | _ -> - let s = strm__ in - if dfa then - let (strm__ : _ Stream.t) = s in - match Stream.peek strm__ with - Some c -> - Stream.junk strm__; - "ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s - | _ -> - let ep = Stream.count strm__ in - err (bp, ep) "antiquotation not terminated" - else "", get_buff (ident2 (store 0 '$') s) - and maybe_locate bp len (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some '$' -> Stream.junk strm__; "ANTIQUOT", ":" ^ get_buff len - | Some ('0'..'9' as c) -> - Stream.junk strm__; maybe_locate bp (store len c) strm__ - | Some ':' -> - Stream.junk strm__; - "LOCATE", get_buff len ^ ":" ^ locate_or_antiquot_rest bp 0 strm__ - | Some '\\' -> - Stream.junk strm__; - begin match Stream.peek strm__ with - Some c -> - Stream.junk strm__; - "ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) strm__ - | _ -> raise (Stream.Error "") - end - | Some c -> - Stream.junk strm__; - "ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) strm__ - | _ -> - let ep = Stream.count strm__ in - err (bp, ep) "antiquotation not terminated" - and antiquot bp len (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some '$' -> Stream.junk strm__; "ANTIQUOT", ":" ^ get_buff len - | Some ('a'..'z' | 'A'..'Z' | '0'..'9' as c) -> - Stream.junk strm__; antiquot bp (store len c) strm__ - | Some ':' -> - Stream.junk strm__; - let k = get_buff len in - "ANTIQUOT", k ^ ":" ^ locate_or_antiquot_rest bp 0 strm__ - | Some '\\' -> - Stream.junk strm__; - begin match Stream.peek strm__ with - Some c -> - Stream.junk strm__; - "ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) strm__ - | _ -> raise (Stream.Error "") - end - | Some c -> - Stream.junk strm__; - "ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) strm__ - | _ -> - let ep = Stream.count strm__ in - err (bp, ep) "antiquotation not terminated" - and locate_or_antiquot_rest bp len (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some '$' -> Stream.junk strm__; get_buff len - | Some '\\' -> - Stream.junk strm__; - begin match Stream.peek strm__ with - Some c -> - Stream.junk strm__; - locate_or_antiquot_rest bp (store len c) strm__ - | _ -> raise (Stream.Error "") - end - | Some c -> - Stream.junk strm__; locate_or_antiquot_rest bp (store len c) strm__ - | _ -> - let ep = Stream.count strm__ in - err (bp, ep) "antiquotation not terminated" - and quotation bp len (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some '>' -> Stream.junk strm__; maybe_end_quotation bp len strm__ - | Some '<' -> - Stream.junk strm__; - quotation bp (maybe_nested_quotation bp (store len '<') strm__) strm__ - | Some '\\' -> - Stream.junk strm__; - let len = - try - match Stream.peek strm__ with - Some ('>' | '<' | '\\' as c) -> Stream.junk strm__; store len c - | _ -> store len '\\' - with - Stream.Failure -> raise (Stream.Error "") - in - quotation bp len strm__ - | Some c -> Stream.junk strm__; quotation bp (store len c) strm__ - | _ -> - let ep = Stream.count strm__ in - err (bp, ep) "quotation not terminated" - and maybe_nested_quotation bp len (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some '<' -> - Stream.junk strm__; mstore (quotation bp (store len '<') strm__) ">>" - | Some ':' -> - Stream.junk strm__; - let len = - try ident (store len ':') strm__ with - Stream.Failure -> raise (Stream.Error "") - in - begin try - match Stream.peek strm__ with - Some '<' -> - Stream.junk strm__; - mstore (quotation bp (store len '<') strm__) ">>" - | _ -> len - with - Stream.Failure -> raise (Stream.Error "") - end - | _ -> len - and maybe_end_quotation bp len (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some '>' -> Stream.junk strm__; len - | _ -> quotation bp (store len '>') strm__ - and left_paren bp (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some '*' -> - Stream.junk strm__; - let _ = - try comment bp strm__ with - Stream.Failure -> raise (Stream.Error "") - in - begin try next_token true strm__ with - Stream.Failure -> raise (Stream.Error "") - end - | _ -> let ep = Stream.count strm__ in keyword_or_error (bp, ep) "(" - and comment bp (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some '(' -> Stream.junk strm__; left_paren_in_comment bp strm__ - | Some '*' -> Stream.junk strm__; star_in_comment bp strm__ - | Some '\"' -> - Stream.junk strm__; - let _ = - try string bp 0 strm__ with - Stream.Failure -> raise (Stream.Error "") - in - comment bp strm__ - | Some '\'' -> Stream.junk strm__; quote_in_comment bp strm__ - | Some c -> Stream.junk strm__; comment bp strm__ - | _ -> - let ep = Stream.count strm__ in err (bp, ep) "comment not terminated" - and quote_in_comment bp (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some '\'' -> Stream.junk strm__; comment bp strm__ - | Some '\\' -> Stream.junk strm__; quote_antislash_in_comment bp 0 strm__ - | _ -> - let s = strm__ in - begin match Stream.npeek 2 s with - [_; '\''] -> Stream.junk s; Stream.junk s - | _ -> () - end; - comment bp s - and quote_any_in_comment bp (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some '\'' -> Stream.junk strm__; comment bp strm__ - | _ -> comment bp strm__ - and quote_antislash_in_comment bp len (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some '\'' -> Stream.junk strm__; comment bp strm__ - | Some ('\\' | '\"' | 'n' | 't' | 'b' | 'r') -> - Stream.junk strm__; quote_any_in_comment bp strm__ - | Some ('0'..'9') -> - Stream.junk strm__; quote_antislash_digit_in_comment bp strm__ - | _ -> comment bp strm__ - and quote_antislash_digit_in_comment bp (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some ('0'..'9') -> - Stream.junk strm__; quote_antislash_digit2_in_comment bp strm__ - | _ -> comment bp strm__ - and quote_antislash_digit2_in_comment bp (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some ('0'..'9') -> Stream.junk strm__; quote_any_in_comment bp strm__ - | _ -> comment bp strm__ - and left_paren_in_comment bp (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some '*' -> - Stream.junk strm__; let s = strm__ in comment bp s; comment bp s - | _ -> comment bp strm__ - and star_in_comment bp (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some ')' -> Stream.junk strm__; () - | _ -> comment bp strm__ - and linedir n s = - match stream_peek_nth n s with - Some (' ' | '\t') -> linedir (n + 1) s - | Some ('0'..'9') -> linedir_digits (n + 1) s - | _ -> false - and linedir_digits n s = - match stream_peek_nth n s with - Some ('0'..'9') -> linedir_digits (n + 1) s - | _ -> linedir_quote n s - and linedir_quote n s = - match stream_peek_nth n s with - Some (' ' | '\t') -> linedir_quote (n + 1) s - | Some '\"' -> true - | _ -> false - and any_to_nl (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some ('\013' | '\010') -> - Stream.junk strm__; let ep = Stream.count strm__ in bolpos := ep - | Some _ -> Stream.junk strm__; any_to_nl strm__ - | _ -> () - in - fun cstrm -> - try - let glex = !glexr in - let comm_bp = Stream.count cstrm in - let r = next_token false cstrm in - begin match glex.tok_comm with - Some list -> - if fst (snd r) > comm_bp then - let comm_loc = comm_bp, fst (snd r) in - glex.tok_comm <- Some (comm_loc :: list) - | None -> () - end; - r - with - Stream.Error str -> err (Stream.count cstrm, Stream.count cstrm + 1) str -;; - - -let dollar_for_antiquotation = ref true;; -let specific_space_dot = ref false;; - -let func kwd_table glexr = - let bolpos = ref 0 in - let find = Hashtbl.find kwd_table in - let dfa = !dollar_for_antiquotation in - let ssd = !specific_space_dot in - Token.lexer_func_of_parser (next_token_fun dfa ssd find bolpos glexr) -;; - -let rec check_keyword_stream (strm__ : _ Stream.t) = - let _ = check strm__ in - let _ = - try Stream.empty strm__ with - Stream.Failure -> raise (Stream.Error "") - in - true -and check (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some - ('A'..'Z' | 'a'..'z' | '\192'..'\214' | '\216'..'\246' | - '\248'..'\255') -> - Stream.junk strm__; check_ident strm__ - | Some - ('!' | '?' | '~' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' | '%' | - '.') -> - Stream.junk strm__; check_ident2 strm__ - | Some '<' -> - Stream.junk strm__; - let s = strm__ in - begin match Stream.npeek 1 s with - [':' | '<'] -> () - | _ -> check_ident2 s - end - | Some ':' -> - Stream.junk strm__; - let _ = - try - match Stream.peek strm__ with - Some (']' | ':' | '=' | '>') -> Stream.junk strm__; () - | _ -> () - with - Stream.Failure -> raise (Stream.Error "") - in - let ep = Stream.count strm__ in () - | Some ('>' | '|') -> - Stream.junk strm__; - let _ = - try - match Stream.peek strm__ with - Some (']' | '}') -> Stream.junk strm__; () - | _ -> check_ident2 strm__ - with - Stream.Failure -> raise (Stream.Error "") - in - () - | Some ('[' | '{') -> - Stream.junk strm__; - let s = strm__ in - begin match Stream.npeek 2 s with - ['<'; '<' | ':'] -> () - | _ -> - let (strm__ : _ Stream.t) = s in - match Stream.peek strm__ with - Some ('|' | '<' | ':') -> Stream.junk strm__; () - | _ -> () - end - | Some ';' -> - Stream.junk strm__; - let _ = - try - match Stream.peek strm__ with - Some ';' -> Stream.junk strm__; () - | _ -> () - with - Stream.Failure -> raise (Stream.Error "") - in - () - | Some _ -> Stream.junk strm__; () - | _ -> raise Stream.Failure -and check_ident (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some - ('A'..'Z' | 'a'..'z' | '\192'..'\214' | '\216'..'\246' | - '\248'..'\255' | '0'..'9' | '_' | '\'') -> - Stream.junk strm__; check_ident strm__ - | _ -> () -and check_ident2 (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some - ('!' | '?' | '~' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' | '%' | - '.' | ':' | '<' | '>' | '|') -> - Stream.junk strm__; check_ident2 strm__ - | _ -> () -;; - -let check_keyword s = - try check_keyword_stream (Stream.of_string s) with - _ -> false -;; - -let error_no_respect_rules p_con p_prm = - raise - (Token.Error - ("the token " ^ - (if p_con = "" then "\"" ^ p_prm ^ "\"" - else if p_prm = "" then p_con - else p_con ^ " \"" ^ p_prm ^ "\"") ^ - " does not respect Plexer rules")) -;; - -let error_ident_and_keyword p_con p_prm = - raise - (Token.Error - ("the token \"" ^ p_prm ^ "\" is used as " ^ p_con ^ - " and as keyword")) -;; - -let using_token kwd_table ident_table (p_con, p_prm) = - match p_con with - "" -> - if not (Hashtbl.mem kwd_table p_prm) then - if check_keyword p_prm then - if Hashtbl.mem ident_table p_prm then - error_ident_and_keyword (Hashtbl.find ident_table p_prm) p_prm - else Hashtbl.add kwd_table p_prm p_prm - else error_no_respect_rules p_con p_prm - | "LIDENT" -> - if p_prm = "" then () - else - begin match p_prm.[0] with - 'A'..'Z' -> error_no_respect_rules p_con p_prm - | _ -> - if Hashtbl.mem kwd_table p_prm then - error_ident_and_keyword p_con p_prm - else Hashtbl.add ident_table p_prm p_con - end - | "UIDENT" -> - if p_prm = "" then () - else - begin match p_prm.[0] with - 'a'..'z' -> error_no_respect_rules p_con p_prm - | _ -> - if Hashtbl.mem kwd_table p_prm then - error_ident_and_keyword p_con p_prm - else Hashtbl.add ident_table p_prm p_con - end - | "INT" | "INT32" | "INT64" | "NATIVEINT" | "FLOAT" | "CHAR" | "STRING" | - "TILDEIDENT" | "QUESTIONIDENT" | "LABEL" | "OPTLABEL" | "QUOTATION" | - "ANTIQUOT" | "LOCATE" | "EOI" -> - () - | _ -> - raise - (Token.Error - ("the constructor \"" ^ p_con ^ "\" is not recognized by Plexer")) -;; - -let removing_token kwd_table ident_table (p_con, p_prm) = - match p_con with - "" -> Hashtbl.remove kwd_table p_prm - | "LIDENT" | "UIDENT" -> - if p_prm <> "" then Hashtbl.remove ident_table p_prm - | _ -> () -;; - -let text = - function - "", t -> "'" ^ t ^ "'" - | "LIDENT", "" -> "lowercase identifier" - | "LIDENT", t -> "'" ^ t ^ "'" - | "UIDENT", "" -> "uppercase identifier" - | "UIDENT", t -> "'" ^ t ^ "'" - | "INT", "" -> "integer" - | "INT32", "" -> "32 bits integer" - | "INT64", "" -> "64 bits integer" - | "NATIVEINT", "" -> "native integer" - | ("INT" | "INT32" | "NATIVEINT"), s -> "'" ^ s ^ "'" - | "FLOAT", "" -> "float" - | "STRING", "" -> "string" - | "CHAR", "" -> "char" - | "QUOTATION", "" -> "quotation" - | "ANTIQUOT", k -> "antiquot \"" ^ k ^ "\"" - | "LOCATE", "" -> "locate" - | "EOI", "" -> "end of input" - | con, "" -> con - | con, prm -> con ^ " \"" ^ prm ^ "\"" -;; - -let eq_before_colon p e = - let rec loop i = - if i == String.length e then - failwith "Internal error in Plexer: incorrect ANTIQUOT" - else if i == String.length p then e.[i] == ':' - else if p.[i] == e.[i] then loop (i + 1) - else false - in - loop 0 -;; - -let after_colon e = - try - let i = String.index e ':' in - String.sub e (i + 1) (String.length e - i - 1) - with - Not_found -> "" -;; - -let tok_match = - function - "ANTIQUOT", p_prm -> - begin function - "ANTIQUOT", prm when eq_before_colon p_prm prm -> after_colon prm - | _ -> raise Stream.Failure - end - | tok -> Token.default_match tok -;; - -let gmake () = - let kwd_table = Hashtbl.create 301 in - let id_table = Hashtbl.create 301 in - let glexr = - ref - {tok_func = (fun _ -> raise (Match_failure ("plexer.ml", 972, 17))); - tok_using = (fun _ -> raise (Match_failure ("plexer.ml", 972, 37))); - tok_removing = (fun _ -> raise (Match_failure ("plexer.ml", 972, 60))); - tok_match = (fun _ -> raise (Match_failure ("plexer.ml", 973, 18))); - tok_text = (fun _ -> raise (Match_failure ("plexer.ml", 973, 37))); - tok_comm = None} - in - let glex = - {tok_func = func kwd_table glexr; - tok_using = using_token kwd_table id_table; - tok_removing = removing_token kwd_table id_table; tok_match = tok_match; - tok_text = text; tok_comm = None} - in - glexr := glex; glex -;; - -let tparse = - function - "ANTIQUOT", p_prm -> - let p (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some ("ANTIQUOT", prm) when eq_before_colon p_prm prm -> - Stream.junk strm__; after_colon prm - | _ -> raise Stream.Failure - in - Some p - | _ -> None -;; - -let make () = - let kwd_table = Hashtbl.create 301 in - let id_table = Hashtbl.create 301 in - let glexr = - ref - {tok_func = (fun _ -> raise (Match_failure ("plexer.ml", 1001, 17))); - tok_using = (fun _ -> raise (Match_failure ("plexer.ml", 1001, 37))); - tok_removing = - (fun _ -> raise (Match_failure ("plexer.ml", 1001, 60))); - tok_match = (fun _ -> raise (Match_failure ("plexer.ml", 1002, 18))); - tok_text = (fun _ -> raise (Match_failure ("plexer.ml", 1002, 37))); - tok_comm = None} - in - {func = func kwd_table glexr; using = using_token kwd_table id_table; - removing = removing_token kwd_table id_table; tparse = tparse; text = text} -;; diff --git a/camlp4/ocaml_src/lib/plexer.mli b/camlp4/ocaml_src/lib/plexer.mli deleted file mode 100644 index 601c175331..0000000000 --- a/camlp4/ocaml_src/lib/plexer.mli +++ /dev/null @@ -1,72 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* This file has been generated by program: do not edit! *) - -(** A lexical analyzer. *) - -val gmake : unit -> Token.t Token.glexer;; - (** Some lexer provided. See the module [Token]. The tokens returned - follow the Objective Caml and the Revised syntax lexing rules. - - The meaning of the tokens are: -- * [("", s)] is the keyword [s]. -- * [("LIDENT", s)] is the ident [s] starting with a lowercase letter. -- * [("UIDENT", s)] is the ident [s] starting with an uppercase letter. -- * [("INT", s)] (resp. ["INT32"], ["INT64"] and ["NATIVEINT"]) - is an integer constant whose string source is [s]. -- * [("FLOAT", s)] is a float constant whose string source is [s]. -- * [("STRING", s)] is the string constant [s]. -- * [("CHAR", s)] is the character constant [s]. -- * [("QUOTATION", "t:s")] is a quotation [t] holding the string [s]. -- * [("ANTIQUOT", "t:s")] is an antiquotation [t] holding the string [s]. -- * [("LOCATE", "i:s")] is a location directive at pos [i] holding [s]. -- * [("EOI", "")] is the end of input. - - The associated token patterns in the EXTEND statement hold the - same names than the first string (constructor name) of the tokens - expressions above. - - Warning: the string associated with the constructor [STRING] is - the string found in the source without any interpretation. In - particular, the backslashes are not interpreted. For example, if - the input is ["\n"] the string is *not* a string with one - element containing the character "return", but a string of two - elements: the backslash and the character ["n"]. To interpret - a string use the function [Token.eval_string]. Same thing for - the constructor [CHAR]: to get the character, don't get the - first character of the string, but use the function - [Token.eval_char]. - - The lexer do not use global (mutable) variables: instantiations - of [Plexer.gmake ()] do not perturb each other. *) - -val dollar_for_antiquotation : bool ref;; - (** When True (default), the next call to [Plexer.make ()] returns a - lexer where the dollar sign is used for antiquotations. If False, - the dollar sign can be used as token. *) - -val specific_space_dot : bool ref;; - (** When False (default), the next call to [Plexer.make ()] returns a - lexer where the dots can be preceded by spaces. If True, dots - preceded by spaces return the keyword " ." (space dot), otherwise - return the keyword "." (dot). *) - -val no_quotations : bool ref;; - (** When True, all lexers built by [Plexer.make ()] do not lex the - quotation syntax any more. Default is False (quotations are - lexed). *) - -(**/**) - -(* deprecated since version 3.05; use rather function gmake *) -val make : unit -> Token.lexer;; diff --git a/camlp4/ocaml_src/lib/stdpp.ml b/camlp4/ocaml_src/lib/stdpp.ml deleted file mode 100644 index d91ee78c07..0000000000 --- a/camlp4/ocaml_src/lib/stdpp.ml +++ /dev/null @@ -1,99 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* This file has been generated by program: do not edit! *) - -exception Exc_located of (int * int) * exn;; - -let raise_with_loc loc exc = - match exc with - Exc_located (_, _) -> raise exc - | _ -> raise (Exc_located (loc, exc)) -;; - -let line_of_loc fname (bp, ep) = - try - let ic = open_in_bin fname in - let strm = Stream.of_channel ic in - let rec loop fname lin = - let rec not_a_line_dir col (strm__ : _ Stream.t) = - let cnt = Stream.count strm__ in - match Stream.peek strm__ with - Some c -> - Stream.junk strm__; - let s = strm__ in - if cnt < bp then - if c = '\n' then loop fname (lin + 1) - else not_a_line_dir (col + 1) s - else let col = col - (cnt - bp) in fname, lin, col, col + ep - bp - | _ -> raise Stream.Failure - in - let rec a_line_dir str n col (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some '\n' -> Stream.junk strm__; loop str n - | Some _ -> Stream.junk strm__; a_line_dir str n (col + 1) strm__ - | _ -> raise Stream.Failure - in - let rec spaces col (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some ' ' -> Stream.junk strm__; spaces (col + 1) strm__ - | _ -> col - in - let rec check_string str n col (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some '\"' -> - Stream.junk strm__; - let col = - try spaces (col + 1) strm__ with - Stream.Failure -> raise (Stream.Error "") - in - a_line_dir str n col strm__ - | Some c when c <> '\n' -> - Stream.junk strm__; - check_string (str ^ String.make 1 c) n (col + 1) strm__ - | _ -> not_a_line_dir col strm__ - in - let check_quote n col (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some '\"' -> Stream.junk strm__; check_string "" n (col + 1) strm__ - | _ -> not_a_line_dir col strm__ - in - let rec check_num n col (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some ('0'..'9' as c) -> - Stream.junk strm__; - check_num (10 * n + Char.code c - Char.code '0') (col + 1) strm__ - | _ -> let col = spaces col strm__ in check_quote n col strm__ - in - let begin_line (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some '#' -> - Stream.junk strm__; - let col = - try spaces 1 strm__ with - Stream.Failure -> raise (Stream.Error "") - in - check_num 0 col strm__ - | _ -> not_a_line_dir 0 strm__ - in - begin_line strm - in - let r = - try loop fname 1 with - Stream.Failure -> fname, 1, bp, ep - in - close_in ic; r - with - Sys_error _ -> fname, 1, bp, ep -;; - -let loc_name = ref "loc";; diff --git a/camlp4/ocaml_src/lib/stdpp.mli b/camlp4/ocaml_src/lib/stdpp.mli deleted file mode 100644 index 68c0cb6ada..0000000000 --- a/camlp4/ocaml_src/lib/stdpp.mli +++ /dev/null @@ -1,37 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* This file has been generated by program: do not edit! *) - -(** Standard definitions. *) - -exception Exc_located of (int * int) * exn;; - (** [Exc_located loc e] is an encapsulation of the exception [e] with - the input location [loc]. To be used in quotation expanders - and in grammars to specify some input location for an error. - Do not raise this exception directly: rather use the following - function [raise_with_loc]. *) - -val raise_with_loc : int * int -> exn -> 'a;; - (** [raise_with_loc loc e], if [e] is already the exception [Exc_located], - re-raise it, else raise the exception [Exc_located loc e]. *) - -val line_of_loc : string -> int * int -> string * int * int * int;; - (** [line_of_loc fname loc] reads the file [fname] up to the - location [loc] and returns the real input file, the line number - and the characters location in the line; the real input file - can be different from [fname] because of possibility of line - directives typically generated by /lib/cpp. *) - -val loc_name : string ref;; - (** Name of the location variable used in grammars and in the predefined - quotations for OCaml syntax trees. Default: [loc] *) diff --git a/camlp4/ocaml_src/lib/token.ml b/camlp4/ocaml_src/lib/token.ml deleted file mode 100644 index bc8faeac3e..0000000000 --- a/camlp4/ocaml_src/lib/token.ml +++ /dev/null @@ -1,223 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2001 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* This file has been generated by program: do not edit! *) - -type t = string * string;; -type pattern = string * string;; - -exception Error of string;; - -type location = int * int;; -type location_function = int -> int * int;; -type 'te lexer_func = char Stream.t -> 'te Stream.t * location_function;; - -type 'te glexer = - { tok_func : 'te lexer_func; - tok_using : pattern -> unit; - tok_removing : pattern -> unit; - tok_match : pattern -> 'te -> string; - tok_text : pattern -> string; - mutable tok_comm : location list option } -;; -type lexer = - { func : t lexer_func; - using : pattern -> unit; - removing : pattern -> unit; - tparse : pattern -> (t Stream.t -> string) option; - text : pattern -> string } -;; - -let lexer_text (con, prm) = - if con = "" then "'" ^ prm ^ "'" - else if prm = "" then con - else con ^ " '" ^ prm ^ "'" -;; - -let locerr () = invalid_arg "Lexer: location function";; -let loct_create () = ref (Array.create 1024 None), ref false;; -let loct_func (loct, ov) i = - match - if i < 0 || i >= Array.length !loct then if !ov then Some (0, 0) else None - else Array.unsafe_get !loct i - with - Some loc -> loc - | _ -> locerr () -;; -let loct_add (loct, ov) i loc = - if i >= Array.length !loct then - let new_tmax = Array.length !loct * 2 in - if new_tmax < Sys.max_array_length then - let new_loct = Array.create new_tmax None in - Array.blit !loct 0 new_loct 0 (Array.length !loct); - loct := new_loct; - !loct.(i) <- Some loc - else ov := true - else !loct.(i) <- Some loc -;; - -let make_stream_and_location next_token_loc = - let loct = loct_create () in - let ts = - Stream.from - (fun i -> - let (tok, loc) = next_token_loc () in loct_add loct i loc; Some tok) - in - ts, loct_func loct -;; - -let lexer_func_of_parser next_token_loc cs = - make_stream_and_location (fun () -> next_token_loc cs) -;; - -let lexer_func_of_ocamllex lexfun cs = - let lb = - Lexing.from_function - (fun s n -> - try s.[0] <- Stream.next cs; 1 with - Stream.Failure -> 0) - in - let next_token_loc _ = - let tok = lexfun lb in - let loc = Lexing.lexeme_start lb, Lexing.lexeme_end lb in tok, loc - in - make_stream_and_location next_token_loc -;; - -(* Char and string tokens to real chars and string *) - -let buff = ref (String.create 80);; -let store len x = - if len >= String.length !buff then - buff := !buff ^ String.create (String.length !buff); - !buff.[len] <- x; - succ len -;; -let mstore len s = - let rec add_rec len i = - if i == String.length s then len else add_rec (store len s.[i]) (succ i) - in - add_rec len 0 -;; -let get_buff len = String.sub !buff 0 len;; - -let valch x = Char.code x - Char.code '0';; -let valch_a x = Char.code x - Char.code 'a' + 10;; -let valch_A x = Char.code x - Char.code 'A' + 10;; - -let rec backslash s i = - if i = String.length s then raise Not_found - else - match s.[i] with - 'n' -> '\n', i + 1 - | 'r' -> '\r', i + 1 - | 't' -> '\t', i + 1 - | 'b' -> '\b', i + 1 - | '\\' -> '\\', i + 1 - | '\"' -> '\"', i + 1 - | '\'' -> '\'', i + 1 - | '0'..'9' as c -> backslash1 (valch c) s (i + 1) - | 'x' -> backslash1h s (i + 1) - | _ -> raise Not_found -and backslash1 cod s i = - if i = String.length s then raise Not_found - else - match s.[i] with - '0'..'9' as c -> backslash2 (10 * cod + valch c) s (i + 1) - | _ -> raise Not_found -and backslash2 cod s i = - if i = String.length s then raise Not_found - else - match s.[i] with - '0'..'9' as c -> Char.chr (10 * cod + valch c), i + 1 - | _ -> raise Not_found -and backslash1h s i = - if i = String.length s then raise Not_found - else - match s.[i] with - '0'..'9' as c -> backslash2h (valch c) s (i + 1) - | 'a'..'f' as c -> backslash2h (valch_a c) s (i + 1) - | 'A'..'F' as c -> backslash2h (valch_A c) s (i + 1) - | _ -> raise Not_found -and backslash2h cod s i = - if i = String.length s then '\\', i - 2 - else - match s.[i] with - '0'..'9' as c -> Char.chr (16 * cod + valch c), i + 1 - | 'a'..'f' as c -> Char.chr (16 * cod + valch_a c), i + 1 - | 'A'..'F' as c -> Char.chr (16 * cod + valch_A c), i + 1 - | _ -> raise Not_found -;; - -let rec skip_indent s i = - if i = String.length s then i - else - match s.[i] with - ' ' | '\t' -> skip_indent s (i + 1) - | _ -> i -;; - -let skip_opt_linefeed s i = - if i = String.length s then i else if s.[i] = '\010' then i + 1 else i -;; - -let eval_char s = - if String.length s = 1 then s.[0] - else if String.length s = 0 then failwith "invalid char token" - else if s.[0] = '\\' then - if String.length s = 2 && s.[1] = '\'' then '\'' - else - try - let (c, i) = backslash s 1 in - if i = String.length s then c else raise Not_found - with - Not_found -> failwith "invalid char token" - else failwith "invalid char token" -;; - -let eval_string (bp, ep) s = - let rec loop len i = - if i = String.length s then get_buff len - else - let (len, i) = - if s.[i] = '\\' then - let i = i + 1 in - if i = String.length s then failwith "invalid string token" - else if s.[i] = '\"' then store len '\"', i + 1 - else - match s.[i] with - '\010' -> len, skip_indent s (i + 1) - | '\013' -> len, skip_indent s (skip_opt_linefeed s (i + 1)) - | c -> - try let (c, i) = backslash s i in store len c, i with - Not_found -> - Printf.eprintf "Warning: char %d, Invalid backslash escape in string\n%!" - (bp + i + 1); - store (store len '\\') c, i + 1 - else store len s.[i], i + 1 - in - loop len i - in - loop 0 0 -;; - -let default_match = - function - "ANY", "" -> (fun (con, prm) -> prm) - | "ANY", v -> - (fun (con, prm) -> if v = prm then v else raise Stream.Failure) - | p_con, "" -> - (fun (con, prm) -> if con = p_con then prm else raise Stream.Failure) - | p_con, p_prm -> - fun (con, prm) -> - if con = p_con && prm = p_prm then prm else raise Stream.Failure -;; diff --git a/camlp4/ocaml_src/lib/token.mli b/camlp4/ocaml_src/lib/token.mli deleted file mode 100644 index 9ddb41069b..0000000000 --- a/camlp4/ocaml_src/lib/token.mli +++ /dev/null @@ -1,133 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2001 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* This file has been generated by program: do not edit! *) - -(** Lexers for Camlp4 grammars. - - This module defines the Camlp4 lexer type to be used in extensible - grammars (see module [Grammar]). It also provides some useful functions - to create lexers (this module should be renamed [Glexer] one day). *) - -type pattern = string * string;; - (** Token patterns come from the EXTEND statement. -- The first string is the constructor name (must start with - an uppercase character). When it is empty, the second string - is supposed to be a keyword. -- The second string is the constructor parameter. Empty if it - has no parameter. -- The way tokens patterns are interpreted to parse tokens is - done by the lexer, function [tok_match] below. *) - -exception Error of string;; - (** An lexing error exception to be used by lexers. *) - -(** {6 Lexer type} *) - -type location = int * int;; -type location_function = int -> location;; - (** The type for a function associating a number of a token in a stream - (starting from 0) to its source location. *) -type 'te lexer_func = char Stream.t -> 'te Stream.t * location_function;; - (** The type for a lexer function. The character stream is the input - stream to be lexed. The result is a pair of a token stream and - a location function for this tokens stream. *) - -type 'te glexer = - { tok_func : 'te lexer_func; - tok_using : pattern -> unit; - tok_removing : pattern -> unit; - tok_match : pattern -> 'te -> string; - tok_text : pattern -> string; - mutable tok_comm : location list option } -;; - (** The type for a lexer used by Camlp4 grammars. -- The field [tok_func] is the main lexer function. See [lexer_func] - type above. This function may be created from a [char stream parser] - or for an [ocamllex] function using the functions below. -- The field [tok_using] is a function telling the lexer that the grammar - uses this token (pattern). The lexer can check that its constructor - is correct, and interpret some kind of tokens as keywords (to record - them in its tables). Called by [EXTEND] statements. -- The field [tok_removing] is a function telling the lexer that the - grammar does not uses the given token (pattern) any more. If the - lexer has a notion of "keywords", it can release it from its tables. - Called by [DELETE_RULE] statements. -- The field [tok_match] is a function taking a pattern and returning - a function matching a token against the pattern. Warning: for - efficency, write it as a function returning functions according - to the values of the pattern, not a function with two parameters. -- The field [tok_text] returns the name of some token pattern, - used in error messages. -- The field [tok_comm] if not None asks the lexer to record the - locations of the comments. *) - -val lexer_text : pattern -> string;; - (** A simple [tok_text] function for lexers *) - -val default_match : pattern -> string * string -> string;; - (** A simple [tok_match] function for lexers, appling to token type - [(string * string)] *) - -(** {6 Lexers from char stream parsers or ocamllex function} - - The functions below create lexer functions either from a [char stream] - parser or for an [ocamllex] function. With the returned function [f], - the simplest [Token.lexer] can be written: - {[ - { Token.tok_func = f; - Token.tok_using = (fun _ -> ()); - Token.tok_removing = (fun _ -> ()); - Token.tok_match = Token.default_match; - Token.tok_text = Token.lexer_text } - ]} - Note that a better [tok_using] function should check the used tokens - and raise [Token.Error] for incorrect ones. The other functions - [tok_removing], [tok_match] and [tok_text] may have other implementations - as well. *) - -val lexer_func_of_parser : - (char Stream.t -> 'te * location) -> 'te lexer_func;; - (** A lexer function from a lexer written as a char stream parser - returning the next token and its location. *) -val lexer_func_of_ocamllex : (Lexing.lexbuf -> 'te) -> 'te lexer_func;; - (** A lexer function from a lexer created by [ocamllex] *) - -val make_stream_and_location : - (unit -> 'te * location) -> 'te Stream.t * location_function;; - (** General function *) - -(** {6 Useful functions} *) - -val eval_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] *) - -val eval_string : location -> string -> string;; - (** Convert a string token, where the escape sequences (backslashes) - remain to be interpreted; issue a warning if an incorrect - backslash sequence is found; - [Token.eval_string loc (String.escaped s)] returns [s] *) - -(**/**) - -(* deprecated since version 3.05; use rather type glexer *) -type t = string * string;; -type lexer = - { func : t lexer_func; - using : pattern -> unit; - removing : pattern -> unit; - tparse : pattern -> (t Stream.t -> string) option; - text : pattern -> string } -;; diff --git a/camlp4/ocaml_src/meta/.cvsignore b/camlp4/ocaml_src/meta/.cvsignore deleted file mode 100644 index 45db17209f..0000000000 --- a/camlp4/ocaml_src/meta/.cvsignore +++ /dev/null @@ -1,2 +0,0 @@ -camlp4o.out -camlp4r.out diff --git a/camlp4/ocaml_src/meta/.depend b/camlp4/ocaml_src/meta/.depend deleted file mode 100644 index 737ea5ec6b..0000000000 --- a/camlp4/ocaml_src/meta/.depend +++ /dev/null @@ -1,16 +0,0 @@ -pa_extend.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi -pa_extend.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx -pa_extend_m.cmo: pa_extend.cmo -pa_extend_m.cmx: pa_extend.cmx -pa_ifdef.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi -pa_ifdef.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx -pa_macro.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi -pa_macro.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx -pa_r.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi -pa_r.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx -pa_rp.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi -pa_rp.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx -pr_dump.cmo: ../camlp4/ast2pt.cmi $(OTOP)/utils/config.cmi ../camlp4/pcaml.cmi -pr_dump.cmx: ../camlp4/ast2pt.cmx $(OTOP)/utils/config.cmx ../camlp4/pcaml.cmx -q_MLast.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi ../camlp4/quotation.cmi -q_MLast.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx ../camlp4/quotation.cmx diff --git a/camlp4/ocaml_src/meta/Makefile b/camlp4/ocaml_src/meta/Makefile deleted file mode 100644 index 3b01659358..0000000000 --- a/camlp4/ocaml_src/meta/Makefile +++ /dev/null @@ -1,59 +0,0 @@ -# This file has been generated by program: do not edit! - -include ../../config/Makefile - -INCLUDES=-I ../camlp4 -I ../../boot -I $(OTOP)/utils -OCAMLCFLAGS=-warn-error A $(INCLUDES) -OBJS=q_MLast.cmo pa_r.cmo pa_rp.cmo pa_extend.cmo pa_extend_m.cmo pa_macro.cmo pr_dump.cmo -OBJSX=$(OBJS:.cmo=.cmx) -CAMLP4RM=pa_r.cmo pa_rp.cmo pr_dump.cmo -CAMLP4RMX=$(CAMLP4RM:.cmo=.cmx) -SHELL=/bin/sh -COUT=$(OBJS) camlp4r$(EXE) -COPT=$(OBJSX) camlp4r.opt - -all: $(COUT) -opt: $(COPT) - -camlp4r$(EXE): ../camlp4/camlp4$(EXE) $(CAMLP4RM) - rm -f camlp4r$(EXE) - cd ../camlp4; $(MAKE) OTOP=$(OTOP) CAMLP4=../meta/camlp4r$(EXE) CAMLP4M="-I ../meta $(CAMLP4RM)" - -camlp4r.opt: $(CAMLP4RMX) - rm -f camlp4r.opt - cd ../camlp4; $(MAKE) optp4 OTOP=$(OTOP) CAMLP4OPT=../meta/camlp4r.opt CAMLP4M="-I ../meta $(CAMLP4RMX)" - -clean:: - rm -f *.cm* *.pp[io] *.o *.bak .*.bak $(COUT) $(COPT) - -depend: - cp .depend .depend.bak - > .depend - @for i in *.mli *.ml; do \ - ../tools/apply.sh pr_depend.cmo -- $(INCLUDES) $$i | \ - sed -e 's| \.\./\.\.| $$(OTOP)|g' >> .depend; \ - done - -promote: - cp $(COUT) pa_extend.cmi ../../boot/. - -compare: - @for j in $(COUT); do \ - if cmp $$j ../../boot/$$j; then :; else exit 1; fi; \ - done - -install: - -$(MKDIR) "$(LIBDIR)/camlp4" "$(BINDIR)" - cp $(OBJS) "$(LIBDIR)/camlp4/." - cp pa_macro.cmi pa_extend.cmi "$(LIBDIR)/camlp4/." - cp camlp4r$(EXE) "$(BINDIR)/." - if test -f camlp4r.opt; then \ - cp camlp4r.opt "$(BINDIR)/camlp4r.opt$(EXE)" ;\ - for target in $(OBJSX) $(OBJSX:.cmx=.$(O)) ; do \ - if test -f $$target; then \ - cp $$target "$(LIBDIR)/camlp4/."; \ - fi; \ - done; \ - fi - -include .depend diff --git a/camlp4/ocaml_src/meta/Makefile.Mac b/camlp4/ocaml_src/meta/Makefile.Mac deleted file mode 100644 index b62b945c12..0000000000 --- a/camlp4/ocaml_src/meta/Makefile.Mac +++ /dev/null @@ -1,50 +0,0 @@ -####################################################################### -# # -# Camlp4 # -# # -# Damien Doligez, projet Para, INRIA Rocquencourt # -# # -# Copyright 1999 Institut National de Recherche en Informatique et # -# en Automatique. Distributed only by permission. # -# # -####################################################################### - -# This file has been generated by program: do not edit! - -INCLUDES = -I ::camlp4: -I :::boot: -I "{OTOP}utils:" -OCAMLCFLAGS = {INCLUDES} -OBJS = q_MLast.cmo pa_r.cmo pa_rp.cmo pa_extend.cmo pa_extend_m.cmo ¶ - pa_ifdef.cmo pr_dump.cmo -CAMLP4RM = pa_r.cmo pa_rp.cmo pr_dump.cmo -OUT = {OBJS} camlp4r - -all Ä {OUT} - -camlp4r Ä ::camlp4:camlp4 {CAMLP4RM} - delete -i camlp4r - directory ::camlp4: - domake -d CAMLP4=::meta:camlp4r -d CAMLP4M="-I ::meta {CAMLP4RM}" - directory ::meta: - -clean ÄÄ - delete -i {OUT} - -{dependrule} - -promote Ä - duplicate -y {OUT} pa_extend.cmi :::boot: - -compare Ä - for i in {OUT} - equal -s {i} :::boot:{i} || exit 1 - end - -install Ä - (newfolder "{P4LIBDIR}" || set status 0) ³ dev:null - (newfolder "{BINDIR}" || set status 0) ³ dev:null - duplicate -y {OBJS} "{P4LIBDIR}" - duplicate -y camlp4r "{BINDIR}" - -{defrules} - -pr_dump.cmo Ä ::camlp4:ast2pt.cmo "{OTOP}utils:config.cmi" ::camlp4:pcaml.cmi diff --git a/camlp4/ocaml_src/meta/Makefile.Mac.depend b/camlp4/ocaml_src/meta/Makefile.Mac.depend deleted file mode 100644 index 29675238e9..0000000000 --- a/camlp4/ocaml_src/meta/Makefile.Mac.depend +++ /dev/null @@ -1,12 +0,0 @@ -pa_extend.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi -pa_extend.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx -pa_extend_m.cmoÄ ::camlp4:mLast.cmi pa_extend.cmo -pa_extend_m.cmxÄ ::camlp4:mLast.cmi pa_extend.cmx -pa_macro.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi -pa_macro.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx -pa_r.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi -pa_r.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx -pa_rp.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi -pa_rp.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx -q_MLast.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi ::camlp4:quotation.cmi -q_MLast.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx ::camlp4:quotation.cmx diff --git a/camlp4/ocaml_src/meta/pa_extend.ml b/camlp4/ocaml_src/meta/pa_extend.ml deleted file mode 100644 index d68baf8d59..0000000000 --- a/camlp4/ocaml_src/meta/pa_extend.ml +++ /dev/null @@ -1,2027 +0,0 @@ -(* camlp4r pa_extend.cmo q_MLast.cmo *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* This file has been generated by program: do not edit! *) - -open Stdpp;; - -let split_ext = ref false;; - -Pcaml.add_option "-split_ext" (Arg.Set split_ext) - "Split EXTEND by functions to turn around a PowerPC problem.";; - -Pcaml.add_option "-split_gext" (Arg.Set split_ext) - "Old name for the option -split_ext.";; - -type loc = int * int;; - -type 'e name = { expr : 'e; tvar : string; loc : int * int };; - -type styp = - STlid of loc * string - | STapp of loc * styp * styp - | STquo of loc * string - | STself of loc * string - | STtyp of MLast.ctyp -;; - -type 'e text = - TXmeta of loc * string * 'e text list * 'e * styp - | TXlist of loc * bool * 'e text * 'e text option - | TXnext of loc - | TXnterm of loc * 'e name * string option - | TXopt of loc * 'e text - | TXrules of loc * ('e text list * 'e) list - | TXself of loc - | TXtok of loc * string * 'e -;; - -type ('e, 'p) entry = - { name : 'e name; pos : 'e option; levels : ('e, 'p) level list } -and ('e, 'p) level = - { label : string option; assoc : 'e option; rules : ('e, 'p) rule list } -and ('e, 'p) rule = { prod : ('e, 'p) psymbol list; action : 'e option } -and ('e, 'p) psymbol = { pattern : 'p option; symbol : ('e, 'p) symbol } -and ('e, 'p) symbol = { used : string list; text : 'e text; styp : styp } -;; - -type used = - Unused - | UsedScanned - | UsedNotScanned -;; - -let mark_used modif ht n = - try - let rll = Hashtbl.find_all ht n in - List.iter - (fun (r, _) -> - if !r == Unused then begin r := UsedNotScanned; modif := true end) - rll - with - Not_found -> () -;; - -let rec mark_symbol modif ht symb = - List.iter (fun e -> mark_used modif ht e) symb.used -;; - -let check_use nl el = - let ht = Hashtbl.create 301 in - let modif = ref false in - List.iter - (fun e -> - let u = - match e.name.expr with - MLast.ExLid (_, _) -> 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 := UsedNotScanned) rll - with - _ -> ()) - nl; - modif := true; - while !modif do - modif := false; - Hashtbl.iter - (fun s (r, e) -> - if !r = UsedNotScanned then - begin - r := UsedScanned; - List.iter - (fun level -> - let rules = level.rules in - List.iter - (fun rule -> - List.iter (fun ps -> mark_symbol modif ht ps.symbol) - rule.prod) - rules) - e.levels - end) - ht - done; - Hashtbl.iter - (fun s (r, e) -> - if !r = Unused then - !(Pcaml.warning) e.name.loc ("Unused local entry \"" ^ s ^ "\"")) - ht -;; - -let locate n = let loc = n.loc in n.expr;; - -let new_type_var = - let i = ref 0 in fun () -> incr i; "e__" ^ string_of_int !i -;; - -let used_of_rule_list rl = - List.fold_left - (fun nl r -> List.fold_left (fun nl s -> s.symbol.used @ nl) nl r.prod) [] - rl -;; - -let retype_rule_list_without_patterns loc rl = - try - List.map - (function - {prod = [{pattern = None; symbol = s}]; action = None} -> - {prod = [{pattern = Some (MLast.PaLid (loc, "x")); symbol = s}]; - action = Some (MLast.ExLid (loc, "x"))} - | {prod = []; action = Some _} as r -> r - | _ -> raise Exit) - rl - with - Exit -> rl -;; - -let quotify = ref false;; -let meta_action = ref false;; - -module MetaAction = - struct - let not_impl f x = - let desc = - if Obj.is_block (Obj.repr x) then - "tag = " ^ string_of_int (Obj.tag (Obj.repr x)) - else "int_val = " ^ string_of_int (Obj.magic x) - in - failwith (f ^ ", not impl: " ^ desc) - ;; - let loc = 0, 0;; - let rec mlist mf = - function - [] -> MLast.ExUid (loc, "[]") - | x :: l -> - MLast.ExApp - (loc, MLast.ExApp (loc, MLast.ExUid (loc, "::"), mf x), - mlist mf l) - ;; - let moption mf = - function - None -> MLast.ExUid (loc, "None") - | Some x -> MLast.ExApp (loc, MLast.ExUid (loc, "Some"), mf x) - ;; - let mbool = - function - false -> MLast.ExUid (loc, "False") - | true -> MLast.ExUid (loc, "True") - ;; - let mloc = - MLast.ExTup (loc, [MLast.ExInt (loc, "0"); MLast.ExInt (loc, "0")]) - ;; - let rec mexpr = - function - MLast.ExAcc (loc, e1, e2) -> - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "MLast"), - MLast.ExUid (loc, "ExAcc")), - mloc), - mexpr e1), - mexpr e2) - | MLast.ExApp (loc, e1, e2) -> - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "MLast"), - MLast.ExUid (loc, "ExApp")), - mloc), - mexpr e1), - mexpr e2) - | MLast.ExChr (loc, s) -> - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "MLast"), - MLast.ExUid (loc, "ExChr")), - mloc), - MLast.ExStr (loc, s)) - | MLast.ExFun (loc, pwel) -> - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "MLast"), - MLast.ExUid (loc, "ExFun")), - mloc), - mlist mpwe pwel) - | MLast.ExIfe (loc, e1, e2, e3) -> - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "MLast"), - MLast.ExUid (loc, "ExIfe")), - mloc), - mexpr e1), - mexpr e2), - mexpr e3) - | MLast.ExInt (loc, s) -> - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "MLast"), - MLast.ExUid (loc, "ExInt")), - mloc), - MLast.ExStr (loc, s)) - | MLast.ExFlo (loc, s) -> - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "MLast"), - MLast.ExUid (loc, "ExFlo")), - mloc), - MLast.ExStr (loc, s)) - | MLast.ExLet (loc, rf, pel, e) -> - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "MLast"), - MLast.ExUid (loc, "ExLet")), - mloc), - mbool rf), - mlist mpe pel), - mexpr e) - | MLast.ExLid (loc, s) -> - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "MLast"), - MLast.ExUid (loc, "ExLid")), - mloc), - MLast.ExStr (loc, s)) - | MLast.ExMat (loc, e, pwel) -> - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "MLast"), - MLast.ExUid (loc, "ExMat")), - mloc), - mexpr e), - mlist mpwe pwel) - | MLast.ExRec (loc, pel, eo) -> - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "MLast"), - MLast.ExUid (loc, "ExRec")), - mloc), - mlist mpe pel), - moption mexpr eo) - | MLast.ExSeq (loc, el) -> - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "MLast"), - MLast.ExUid (loc, "ExSeq")), - mloc), - mlist mexpr el) - | MLast.ExSte (loc, e1, e2) -> - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "MLast"), - MLast.ExUid (loc, "ExSte")), - mloc), - mexpr e1), - mexpr e2) - | MLast.ExStr (loc, s) -> - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "MLast"), - MLast.ExUid (loc, "ExStr")), - mloc), - MLast.ExStr (loc, String.escaped s)) - | MLast.ExTry (loc, e, pwel) -> - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "MLast"), - MLast.ExUid (loc, "ExTry")), - mloc), - mexpr e), - mlist mpwe pwel) - | MLast.ExTup (loc, el) -> - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "MLast"), - MLast.ExUid (loc, "ExTup")), - mloc), - mlist mexpr el) - | MLast.ExTyc (loc, e, t) -> - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "MLast"), - MLast.ExUid (loc, "ExTyc")), - mloc), - mexpr e), - mctyp t) - | MLast.ExUid (loc, s) -> - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "MLast"), - MLast.ExUid (loc, "ExUid")), - mloc), - MLast.ExStr (loc, s)) - | x -> not_impl "mexpr" x - and mpatt = - function - MLast.PaAcc (loc, p1, p2) -> - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "MLast"), - MLast.ExUid (loc, "PaAcc")), - mloc), - mpatt p1), - mpatt p2) - | MLast.PaAny loc -> - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "MLast"), MLast.ExUid (loc, "PaAny")), - mloc) - | MLast.PaApp (loc, p1, p2) -> - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "MLast"), - MLast.ExUid (loc, "PaApp")), - mloc), - mpatt p1), - mpatt p2) - | MLast.PaInt (loc, s) -> - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "MLast"), - MLast.ExUid (loc, "PaInt")), - mloc), - MLast.ExStr (loc, s)) - | MLast.PaLid (loc, s) -> - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "MLast"), - MLast.ExUid (loc, "PaLid")), - mloc), - MLast.ExStr (loc, s)) - | MLast.PaOrp (loc, p1, p2) -> - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "MLast"), - MLast.ExUid (loc, "PaOrp")), - mloc), - mpatt p1), - mpatt p2) - | MLast.PaStr (loc, s) -> - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "MLast"), - MLast.ExUid (loc, "PaStr")), - mloc), - MLast.ExStr (loc, String.escaped s)) - | MLast.PaTup (loc, pl) -> - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "MLast"), - MLast.ExUid (loc, "PaTup")), - mloc), - mlist mpatt pl) - | MLast.PaTyc (loc, p, t) -> - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "MLast"), - MLast.ExUid (loc, "PaTyc")), - mloc), - mpatt p), - mctyp t) - | MLast.PaUid (loc, s) -> - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "MLast"), - MLast.ExUid (loc, "PaUid")), - mloc), - MLast.ExStr (loc, s)) - | x -> not_impl "mpatt" x - and mctyp = - function - MLast.TyAcc (loc, t1, t2) -> - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "MLast"), - MLast.ExUid (loc, "TyAcc")), - mloc), - mctyp t1), - mctyp t2) - | MLast.TyApp (loc, t1, t2) -> - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "MLast"), - MLast.ExUid (loc, "TyApp")), - mloc), - mctyp t1), - mctyp t2) - | MLast.TyLid (loc, s) -> - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "MLast"), - MLast.ExUid (loc, "TyLid")), - mloc), - MLast.ExStr (loc, s)) - | MLast.TyQuo (loc, s) -> - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "MLast"), - MLast.ExUid (loc, "TyQuo")), - mloc), - MLast.ExStr (loc, s)) - | MLast.TyTup (loc, tl) -> - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "MLast"), - MLast.ExUid (loc, "TyTup")), - mloc), - mlist mctyp tl) - | MLast.TyUid (loc, s) -> - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "MLast"), - MLast.ExUid (loc, "TyUid")), - mloc), - MLast.ExStr (loc, s)) - | x -> not_impl "mctyp" x - and mpe (p, e) = MLast.ExTup (loc, [mpatt p; mexpr e]) - and mpwe (p, w, e) = - MLast.ExTup (loc, [mpatt p; moption mexpr w; mexpr e]) - ;; - end -;; - -let mklistexp loc = - let rec loop top = - function - [] -> MLast.ExUid (loc, "[]") - | e1 :: el -> - let loc = if top then loc else fst (MLast.loc_of_expr e1), snd loc in - MLast.ExApp - (loc, MLast.ExApp (loc, MLast.ExUid (loc, "::"), e1), loop false el) - in - loop true -;; - -let mklistpat loc = - let rec loop top = - function - [] -> MLast.PaUid (loc, "[]") - | p1 :: pl -> - let loc = if top then loc else fst (MLast.loc_of_patt p1), snd loc in - MLast.PaApp - (loc, MLast.PaApp (loc, MLast.PaUid (loc, "::"), p1), loop false pl) - in - loop true -;; - -let rec expr_fa al = - function - MLast.ExApp (_, f, a) -> expr_fa (a :: al) f - | f -> f, al -;; - -let rec quot_expr e = - let loc = MLast.loc_of_expr e in - match e with - MLast.ExUid (_, "None") -> - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "Option")), - MLast.ExUid (loc, "None")) - | MLast.ExApp (_, MLast.ExUid (_, "Some"), e) -> - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "Option")), - MLast.ExApp (loc, MLast.ExUid (loc, "Some"), quot_expr e)) - | MLast.ExUid (_, "False") -> - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "Bool")), - MLast.ExUid (loc, "False")) - | MLast.ExUid (_, "True") -> - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "Bool")), - MLast.ExUid (loc, "True")) - | MLast.ExUid (_, "()") -> e - | MLast.ExApp - (_, MLast.ExAcc (_, MLast.ExUid (_, "Qast"), MLast.ExUid (_, "List")), - _) -> - e - | MLast.ExApp - (_, MLast.ExAcc (_, MLast.ExUid (_, "Qast"), MLast.ExUid (_, "Option")), - _) -> - e - | MLast.ExApp - (_, MLast.ExAcc (_, MLast.ExUid (_, "Qast"), MLast.ExUid (_, "Str")), - _) -> - e - | MLast.ExUid (_, "[]") -> - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "List")), - MLast.ExUid (loc, "[]")) - | MLast.ExApp - (_, MLast.ExApp (_, MLast.ExUid (_, "::"), e), MLast.ExUid (_, "[]")) -> - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "List")), - MLast.ExApp - (loc, MLast.ExApp (loc, MLast.ExUid (loc, "::"), quot_expr e), - MLast.ExUid (loc, "[]"))) - | MLast.ExApp (_, MLast.ExApp (_, MLast.ExUid (_, "::"), e1), e2) -> - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "Cons")), - quot_expr e1), - quot_expr e2) - | MLast.ExApp (_, _, _) -> - let (f, al) = expr_fa [] e in - begin match f with - MLast.ExUid (_, c) -> - let al = List.map quot_expr al in - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "Node")), - MLast.ExStr (loc, c)), - mklistexp loc al) - | MLast.ExAcc (_, MLast.ExUid (_, "MLast"), MLast.ExUid (_, c)) -> - let al = List.map quot_expr al in - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "Node")), - MLast.ExStr (loc, c)), - mklistexp loc al) - | MLast.ExAcc (_, MLast.ExUid (_, m), MLast.ExUid (_, c)) -> - let al = List.map quot_expr al in - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "Node")), - MLast.ExStr (loc, (m ^ "." ^ c))), - mklistexp loc al) - | MLast.ExLid (_, f) -> - let al = List.map quot_expr al in - List.fold_left (fun f e -> MLast.ExApp (loc, f, e)) - (MLast.ExLid (loc, f)) al - | _ -> e - end - | MLast.ExRec (_, pel, None) -> - begin try - let lel = - List.map - (fun (p, e) -> - let lab = - match p with - MLast.PaLid (_, c) -> MLast.ExStr (loc, c) - | MLast.PaAcc (_, _, MLast.PaLid (_, c)) -> - MLast.ExStr (loc, c) - | _ -> raise Not_found - in - MLast.ExTup (loc, [lab; quot_expr e])) - pel - in - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "Record")), - mklistexp loc lel) - with - Not_found -> e - end - | MLast.ExLid (_, s) -> - if s = !(Stdpp.loc_name) then - MLast.ExAcc (loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "Loc")) - else e - | MLast.ExAcc (_, MLast.ExUid (_, "MLast"), MLast.ExUid (_, s)) -> - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "Node")), - MLast.ExStr (loc, s)), - MLast.ExUid (loc, "[]")) - | MLast.ExAcc (_, MLast.ExUid (_, m), MLast.ExUid (_, s)) -> - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "Node")), - MLast.ExStr (loc, (m ^ "." ^ s))), - MLast.ExUid (loc, "[]")) - | MLast.ExUid (_, s) -> - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "Node")), - MLast.ExStr (loc, s)), - MLast.ExUid (loc, "[]")) - | MLast.ExStr (_, s) -> - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "Str")), - MLast.ExStr (loc, s)) - | MLast.ExTup (_, el) -> - let el = List.map quot_expr el in - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "Tuple")), - mklistexp loc el) - | MLast.ExLet (_, r, pel, e) -> - let pel = List.map (fun (p, e) -> p, quot_expr e) pel in - MLast.ExLet (loc, r, pel, quot_expr e) - | _ -> e -;; - -let symgen = "xx";; - -let pname_of_ptuple pl = - List.fold_left - (fun pname p -> - match p with - MLast.PaLid (_, s) -> pname ^ s - | _ -> pname) - "" pl -;; - -let quotify_action psl act = - let e = quot_expr act in - List.fold_left - (fun e ps -> - match ps.pattern with - Some (MLast.PaTup (_, pl)) -> - let loc = 0, 0 in - let pname = pname_of_ptuple pl in - let (pl1, el1) = - let (l, _) = - List.fold_left - (fun (l, cnt) _ -> - (symgen ^ string_of_int cnt) :: l, cnt + 1) - ([], 1) pl - in - let l = List.rev l in - List.map (fun s -> MLast.PaLid (loc, s)) l, - List.map (fun s -> MLast.ExLid (loc, s)) l - in - MLast.ExLet - (loc, false, - [MLast.PaTup (loc, pl), - MLast.ExMat - (loc, MLast.ExLid (loc, pname), - [MLast.PaApp - (loc, - MLast.PaAcc - (loc, MLast.PaUid (loc, "Qast"), - MLast.PaUid (loc, "Tuple")), - mklistpat loc pl1), - None, MLast.ExTup (loc, el1); - MLast.PaAny loc, None, - MLast.ExMat (loc, MLast.ExUid (loc, "()"), [])])], - e) - | _ -> e) - e psl -;; - -let rec make_ctyp styp tvar = - match styp with - STlid (loc, s) -> MLast.TyLid (loc, s) - | STapp (loc, t1, t2) -> - MLast.TyApp (loc, make_ctyp t1 tvar, make_ctyp t2 tvar) - | STquo (loc, s) -> MLast.TyQuo (loc, s) - | STself (loc, x) -> - if tvar = "" then - Stdpp.raise_with_loc loc - (Stream.Error ("'" ^ x ^ "' illegal in anonymous entry level")) - else MLast.TyQuo (loc, tvar) - | STtyp t -> t -;; - -let rec make_expr gmod tvar = - function - TXmeta (loc, n, tl, e, t) -> - let el = - List.fold_right - (fun t el -> - MLast.ExApp - (loc, - MLast.ExApp - (loc, MLast.ExUid (loc, "::"), make_expr gmod "" t), - el)) - tl (MLast.ExUid (loc, "[]")) - in - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "Gramext"), - MLast.ExUid (loc, "Smeta")), - MLast.ExStr (loc, n)), - el), - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "Obj"), MLast.ExLid (loc, "repr")), - MLast.ExTyc (loc, e, make_ctyp t tvar))) - | TXlist (loc, min, t, ts) -> - let txt = make_expr gmod "" t in - begin match min, ts with - false, None -> - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "Gramext"), - MLast.ExUid (loc, "Slist0")), - txt) - | true, None -> - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "Gramext"), - MLast.ExUid (loc, "Slist1")), - txt) - | false, Some s -> - let x = make_expr gmod tvar s in - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "Gramext"), - MLast.ExUid (loc, "Slist0sep")), - txt), - x) - | true, Some s -> - let x = make_expr gmod tvar s in - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "Gramext"), - MLast.ExUid (loc, "Slist1sep")), - txt), - x) - end - | TXnext loc -> - MLast.ExAcc - (loc, MLast.ExUid (loc, "Gramext"), MLast.ExUid (loc, "Snext")) - | TXnterm (loc, n, lev) -> - begin match lev with - Some lab -> - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "Gramext"), - MLast.ExUid (loc, "Snterml")), - MLast.ExApp - (loc, - MLast.ExAcc - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, gmod), - MLast.ExUid (loc, "Entry")), - MLast.ExLid (loc, "obj")), - MLast.ExTyc - (loc, n.expr, - MLast.TyApp - (loc, - MLast.TyAcc - (loc, - MLast.TyAcc - (loc, MLast.TyUid (loc, gmod), - MLast.TyUid (loc, "Entry")), - MLast.TyLid (loc, "e")), - MLast.TyQuo (loc, n.tvar))))), - MLast.ExStr (loc, lab)) - | None -> - if n.tvar = tvar then - MLast.ExAcc - (loc, MLast.ExUid (loc, "Gramext"), MLast.ExUid (loc, "Sself")) - else - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "Gramext"), - MLast.ExUid (loc, "Snterm")), - MLast.ExApp - (loc, - MLast.ExAcc - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, gmod), - MLast.ExUid (loc, "Entry")), - MLast.ExLid (loc, "obj")), - MLast.ExTyc - (loc, n.expr, - MLast.TyApp - (loc, - MLast.TyAcc - (loc, - MLast.TyAcc - (loc, MLast.TyUid (loc, gmod), - MLast.TyUid (loc, "Entry")), - MLast.TyLid (loc, "e")), - MLast.TyQuo (loc, n.tvar))))) - end - | TXopt (loc, t) -> - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "Gramext"), MLast.ExUid (loc, "Sopt")), - make_expr gmod "" t) - | TXrules (loc, rl) -> - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "Gramext"), MLast.ExLid (loc, "srules")), - make_expr_rules loc gmod rl "") - | TXself loc -> - MLast.ExAcc - (loc, MLast.ExUid (loc, "Gramext"), MLast.ExUid (loc, "Sself")) - | TXtok (loc, s, e) -> - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "Gramext"), MLast.ExUid (loc, "Stoken")), - MLast.ExTup (loc, [MLast.ExStr (loc, s); e])) -and make_expr_rules loc gmod rl tvar = - List.fold_left - (fun txt (sl, ac) -> - let sl = - List.fold_right - (fun t txt -> - let x = make_expr gmod tvar t in - MLast.ExApp - (loc, MLast.ExApp (loc, MLast.ExUid (loc, "::"), x), txt)) - sl (MLast.ExUid (loc, "[]")) - in - MLast.ExApp - (loc, - MLast.ExApp - (loc, MLast.ExUid (loc, "::"), MLast.ExTup (loc, [sl; ac])), - txt)) - (MLast.ExUid (loc, "[]")) rl -;; - -let text_of_action loc psl rtvar act tvar = - let locid = MLast.PaLid (loc, !(Stdpp.loc_name)) in - let act = - match act with - Some act -> if !quotify then quotify_action psl act else act - | None -> MLast.ExUid (loc, "()") - in - let e = - MLast.ExFun - (loc, - [MLast.PaTyc - (loc, locid, - MLast.TyTup - (loc, [MLast.TyLid (loc, "int"); MLast.TyLid (loc, "int")])), - None, MLast.ExTyc (loc, act, MLast.TyQuo (loc, rtvar))]) - in - let txt = - List.fold_left - (fun txt ps -> - match ps.pattern with - None -> MLast.ExFun (loc, [MLast.PaAny loc, None, txt]) - | Some p -> - let t = make_ctyp ps.symbol.styp tvar in - let p = - match p with - MLast.PaTup (_, pl) when !quotify -> - MLast.PaLid (loc, pname_of_ptuple pl) - | _ -> p - in - MLast.ExFun (loc, [MLast.PaTyc (loc, p, t), None, txt])) - e psl - in - let txt = - if !meta_action then - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "Obj"), MLast.ExLid (loc, "magic")), - MetaAction.mexpr txt) - else txt - in - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "Gramext"), MLast.ExLid (loc, "action")), - txt) -;; - -let srules loc t rl tvar = - List.map - (fun r -> - let sl = List.map (fun ps -> ps.symbol.text) r.prod in - let ac = text_of_action loc r.prod t r.action tvar in sl, ac) - rl -;; - -let expr_of_delete_rule loc gmod n sl = - let sl = - List.fold_right - (fun s e -> - MLast.ExApp - (loc, - MLast.ExApp - (loc, MLast.ExUid (loc, "::"), make_expr gmod "" s.text), - e)) - sl (MLast.ExUid (loc, "[]")) - in - n.expr, sl -;; - -let rec ident_of_expr = - function - MLast.ExLid (_, s) -> s - | MLast.ExUid (_, s) -> s - | MLast.ExAcc (_, e1, e2) -> ident_of_expr e1 ^ "__" ^ ident_of_expr e2 - | _ -> failwith "internal error in pa_extend" -;; - -let mk_name loc e = {expr = e; tvar = ident_of_expr e; loc = loc};; - -let slist loc min sep symb = - let t = - match sep with - Some s -> Some s.text - | None -> None - in - TXlist (loc, min, symb.text, t) -;; - -let sstoken loc s = - let n = mk_name loc (MLast.ExLid (loc, ("a_" ^ s))) in - TXnterm (loc, n, None) -;; - -let mk_psymbol p s t = - let symb = {used = []; text = s; styp = t} in - {pattern = Some p; symbol = symb} -;; - -let sslist loc min sep s = - let rl = - let r1 = - let prod = - let n = mk_name loc (MLast.ExLid (loc, "a_list")) in - [mk_psymbol (MLast.PaLid (loc, "a")) (TXnterm (loc, n, None)) - (STquo (loc, "a_list"))] - in - let act = MLast.ExLid (loc, "a") in {prod = prod; action = Some act} - in - let r2 = - let prod = - [mk_psymbol (MLast.PaLid (loc, "a")) (slist loc min sep s) - (STapp (loc, STlid (loc, "list"), s.styp))] - in - let act = - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "List")), - MLast.ExLid (loc, "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} -;; - -let ssopt loc s = - let rl = - let r1 = - let prod = - let n = mk_name loc (MLast.ExLid (loc, "a_opt")) in - [mk_psymbol (MLast.PaLid (loc, "a")) (TXnterm (loc, n, None)) - (STquo (loc, "a_opt"))] - in - let act = MLast.ExLid (loc, "a") in {prod = prod; action = Some act} - in - let r2 = - let s = - match s.text with - TXtok (loc, "", MLast.ExStr (_, _)) -> - let rl = - [{prod = - [{pattern = Some (MLast.PaLid (loc, "x")); symbol = s}]; - action = - Some - (MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "Qast"), - MLast.ExUid (loc, "Str")), - MLast.ExLid (loc, "x")))}] - in - let t = new_type_var () in - {used = []; text = TXrules (loc, srules loc t rl ""); - styp = STquo (loc, t)} - | _ -> s - in - let prod = - [mk_psymbol (MLast.PaLid (loc, "a")) (TXopt (loc, s.text)) - (STapp (loc, STlid (loc, "option"), s.styp))] - in - let act = - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "Option")), - MLast.ExLid (loc, "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} -;; - -let text_of_entry loc gmod e = - let ent = - let x = e.name in - let loc = e.name.loc in - MLast.ExTyc - (loc, x.expr, - MLast.TyApp - (loc, - MLast.TyAcc - (loc, - MLast.TyAcc - (loc, MLast.TyUid (loc, gmod), MLast.TyUid (loc, "Entry")), - MLast.TyLid (loc, "e")), - MLast.TyQuo (loc, x.tvar))) - in - let pos = - match e.pos with - Some pos -> MLast.ExApp (loc, MLast.ExUid (loc, "Some"), pos) - | None -> MLast.ExUid (loc, "None") - in - let txt = - List.fold_right - (fun level txt -> - let lab = - match level.label with - Some lab -> - MLast.ExApp - (loc, MLast.ExUid (loc, "Some"), MLast.ExStr (loc, lab)) - | None -> MLast.ExUid (loc, "None") - in - let ass = - match level.assoc with - Some ass -> MLast.ExApp (loc, MLast.ExUid (loc, "Some"), ass) - | None -> MLast.ExUid (loc, "None") - in - let txt = - let rl = srules loc e.name.tvar level.rules e.name.tvar in - let e = make_expr_rules loc gmod rl e.name.tvar in - MLast.ExApp - (loc, - MLast.ExApp - (loc, MLast.ExUid (loc, "::"), - MLast.ExTup (loc, [lab; ass; e])), - txt) - in - txt) - e.levels (MLast.ExUid (loc, "[]")) - in - ent, pos, txt -;; - -let let_in_of_extend loc gmod functor_version gl el args = - match gl with - Some (n1 :: _ as nl) -> - 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 - MLast.ExLid (_, _) -> - 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 globals = - List.map - (fun {expr = e; tvar = x; loc = loc} -> - MLast.PaAny loc, - MLast.ExTyc - (loc, e, - MLast.TyApp - (loc, - MLast.TyAcc - (loc, - MLast.TyAcc - (loc, MLast.TyUid (loc, gmod), - MLast.TyUid (loc, "Entry")), - MLast.TyLid (loc, "e")), - MLast.TyQuo (loc, x)))) - nl - in - let locals = - List.map - (fun {expr = e; tvar = x; loc = loc} -> - let i = - match e with - MLast.ExLid (_, i) -> i - | _ -> failwith "internal error in pa_extend" - in - MLast.PaLid (loc, i), - MLast.ExTyc - (loc, - MLast.ExApp - (loc, MLast.ExLid (loc, "grammar_entry_create"), - MLast.ExStr (loc, i)), - MLast.TyApp - (loc, - MLast.TyAcc - (loc, - MLast.TyAcc - (loc, MLast.TyUid (loc, gmod), - MLast.TyUid (loc, "Entry")), - MLast.TyLid (loc, "e")), - MLast.TyQuo (loc, x)))) - ll - in - let e = - if ll = [] then args - else if functor_version then - MLast.ExLet - (loc, false, - [MLast.PaLid (loc, "grammar_entry_create"), - MLast.ExAcc - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, gmod), MLast.ExUid (loc, "Entry")), - MLast.ExLid (loc, "create"))], - MLast.ExLet (loc, false, locals, args)) - else - MLast.ExLet - (loc, false, - [MLast.PaLid (loc, "grammar_entry_create"), - MLast.ExFun - (loc, - [MLast.PaLid (loc, "s"), None, - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, gmod), - MLast.ExUid (loc, "Entry")), - MLast.ExLid (loc, "create")), - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, gmod), - MLast.ExLid (loc, "of_entry")), - locate n1)), - MLast.ExLid (loc, "s"))])], - MLast.ExLet (loc, false, locals, args)) - in - MLast.ExLet (loc, false, globals, e) - | _ -> args -;; - -let text_of_extend loc gmod gl el f = - if !split_ext then - let args = - List.map - (fun e -> - let (ent, pos, txt) = text_of_entry e.name.loc gmod e in - let ent = - MLast.ExApp - (loc, - MLast.ExAcc - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, gmod), - MLast.ExUid (loc, "Entry")), - MLast.ExLid (loc, "obj")), - ent) - in - let e = MLast.ExTup (loc, [ent; pos; txt]) in - MLast.ExLet - (loc, false, - [MLast.PaLid (loc, "aux"), - MLast.ExFun - (loc, - [MLast.PaUid (loc, "()"), None, - MLast.ExApp - (loc, f, - MLast.ExApp - (loc, MLast.ExApp (loc, MLast.ExUid (loc, "::"), e), - MLast.ExUid (loc, "[]")))])], - MLast.ExApp - (loc, MLast.ExLid (loc, "aux"), MLast.ExUid (loc, "()")))) - el - in - let args = MLast.ExSeq (loc, args) in - let_in_of_extend loc gmod false gl el args - else - let args = - List.fold_right - (fun e el -> - let (ent, pos, txt) = text_of_entry e.name.loc gmod e in - let ent = - MLast.ExApp - (loc, - MLast.ExAcc - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, gmod), - MLast.ExUid (loc, "Entry")), - MLast.ExLid (loc, "obj")), - ent) - in - let e = MLast.ExTup (loc, [ent; pos; txt]) in - MLast.ExApp - (loc, MLast.ExApp (loc, MLast.ExUid (loc, "::"), e), el)) - el (MLast.ExUid (loc, "[]")) - in - let args = let_in_of_extend loc gmod false gl el args in - MLast.ExApp (loc, f, args) -;; - -let text_of_functorial_extend loc gmod gl el = - let args = - let el = - List.map - (fun e -> - let (ent, pos, txt) = text_of_entry e.name.loc gmod e in - let e = - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, gmod), - MLast.ExLid (loc, "extend")), - ent), - pos), - txt) - in - if !split_ext then - MLast.ExLet - (loc, false, - [MLast.PaLid (loc, "aux"), - MLast.ExFun (loc, [MLast.PaUid (loc, "()"), None, e])], - MLast.ExApp - (loc, MLast.ExLid (loc, "aux"), MLast.ExUid (loc, "()"))) - else e) - el - in - MLast.ExSeq (loc, el) - in - let_in_of_extend loc gmod true gl el args -;; - -open Pcaml;; -let symbol = Grammar.Entry.create gram "symbol";; -let semi_sep = - if !syntax_name = "Scheme" then - Grammar.Entry.of_parser gram "'/'" - (fun (strm__ : _ Stream.t) -> - match Stream.peek strm__ with - Some ("", "/") -> Stream.junk strm__; () - | _ -> raise Stream.Failure) - else - Grammar.Entry.of_parser gram "';'" - (fun (strm__ : _ Stream.t) -> - match Stream.peek strm__ with - Some ("", ";") -> Stream.junk strm__; () - | _ -> raise Stream.Failure) -;; - -Grammar.extend - (let _ = (expr : 'expr Grammar.Entry.e) - and _ = (symbol : 'symbol Grammar.Entry.e) in - let grammar_entry_create s = - Grammar.Entry.create (Grammar.of_entry expr) s - in - let extend_body : 'extend_body Grammar.Entry.e = - grammar_entry_create "extend_body" - and gextend_body : 'gextend_body Grammar.Entry.e = - grammar_entry_create "gextend_body" - and delete_rule_body : 'delete_rule_body Grammar.Entry.e = - grammar_entry_create "delete_rule_body" - and gdelete_rule_body : 'gdelete_rule_body Grammar.Entry.e = - grammar_entry_create "gdelete_rule_body" - and efunction : 'efunction Grammar.Entry.e = - grammar_entry_create "efunction" - and global : 'global Grammar.Entry.e = grammar_entry_create "global" - and entry : 'entry Grammar.Entry.e = grammar_entry_create "entry" - and position : 'position Grammar.Entry.e = grammar_entry_create "position" - and level_list : 'level_list Grammar.Entry.e = - grammar_entry_create "level_list" - and level : 'level Grammar.Entry.e = grammar_entry_create "level" - and assoc : 'assoc Grammar.Entry.e = grammar_entry_create "assoc" - and rule_list : 'rule_list Grammar.Entry.e = - grammar_entry_create "rule_list" - and rule : 'rule Grammar.Entry.e = grammar_entry_create "rule" - and psymbol : 'psymbol Grammar.Entry.e = grammar_entry_create "psymbol" - and pattern : 'pattern Grammar.Entry.e = grammar_entry_create "pattern" - and patterns_comma : 'patterns_comma Grammar.Entry.e = - grammar_entry_create "patterns_comma" - and name : 'name Grammar.Entry.e = grammar_entry_create "name" - and qualid : 'qualid Grammar.Entry.e = grammar_entry_create "qualid" - and string : 'string Grammar.Entry.e = grammar_entry_create "string" in - [Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), - Some (Gramext.After "top"), - [None, None, - [[Gramext.Stoken ("", "GDELETE_RULE"); - Gramext.Snterm - (Grammar.Entry.obj - (gdelete_rule_body : 'gdelete_rule_body Grammar.Entry.e)); - Gramext.Stoken ("", "END")], - Gramext.action - (fun _ (e : 'gdelete_rule_body) _ (loc : int * int) -> (e : 'expr)); - [Gramext.Stoken ("", "DELETE_RULE"); - Gramext.Snterm - (Grammar.Entry.obj - (delete_rule_body : 'delete_rule_body Grammar.Entry.e)); - Gramext.Stoken ("", "END")], - Gramext.action - (fun _ (e : 'delete_rule_body) _ (loc : int * int) -> (e : 'expr)); - [Gramext.Stoken ("", "GEXTEND"); - Gramext.Snterm - (Grammar.Entry.obj (gextend_body : 'gextend_body Grammar.Entry.e)); - Gramext.Stoken ("", "END")], - Gramext.action - (fun _ (e : 'gextend_body) _ (loc : int * int) -> (e : 'expr)); - [Gramext.Stoken ("", "EXTEND"); - Gramext.Snterm - (Grammar.Entry.obj (extend_body : 'extend_body Grammar.Entry.e)); - Gramext.Stoken ("", "END")], - Gramext.action - (fun _ (e : 'extend_body) _ (loc : int * int) -> (e : 'expr))]]; - Grammar.Entry.obj (extend_body : 'extend_body Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj (efunction : 'efunction Grammar.Entry.e)); - Gramext.Sopt - (Gramext.Snterm - (Grammar.Entry.obj (global : 'global Grammar.Entry.e))); - Gramext.Slist1 - (Gramext.srules - [[Gramext.Snterm - (Grammar.Entry.obj (entry : 'entry Grammar.Entry.e)); - Gramext.Snterm - (Grammar.Entry.obj (semi_sep : 'semi_sep Grammar.Entry.e))], - Gramext.action - (fun _ (e : 'entry) (loc : int * int) -> (e : 'e__1))])], - Gramext.action - (fun (el : 'e__1 list) (sl : 'global option) (f : 'efunction) - (loc : int * int) -> - (text_of_extend loc "Grammar" sl el f : 'extend_body))]]; - Grammar.Entry.obj (gextend_body : 'gextend_body Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("UIDENT", ""); - Gramext.Sopt - (Gramext.Snterm - (Grammar.Entry.obj (global : 'global Grammar.Entry.e))); - Gramext.Slist1 - (Gramext.srules - [[Gramext.Snterm - (Grammar.Entry.obj (entry : 'entry Grammar.Entry.e)); - Gramext.Snterm - (Grammar.Entry.obj (semi_sep : 'semi_sep Grammar.Entry.e))], - Gramext.action - (fun _ (e : 'entry) (loc : int * int) -> (e : 'e__2))])], - Gramext.action - (fun (el : 'e__2 list) (sl : 'global option) (g : string) - (loc : int * int) -> - (text_of_functorial_extend loc g sl el : 'gextend_body))]]; - Grammar.Entry.obj (delete_rule_body : 'delete_rule_body Grammar.Entry.e), - None, - [None, None, - [[Gramext.Snterm (Grammar.Entry.obj (name : 'name Grammar.Entry.e)); - Gramext.Stoken ("", ":"); - Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj (symbol : 'symbol Grammar.Entry.e)), - Gramext.Snterm - (Grammar.Entry.obj (semi_sep : 'semi_sep Grammar.Entry.e)))], - Gramext.action - (fun (sl : 'symbol list) _ (n : 'name) (loc : int * int) -> - (let (e, b) = expr_of_delete_rule loc "Grammar" n sl in - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "Grammar"), - MLast.ExLid (loc, "delete_rule")), - e), - b) : - 'delete_rule_body))]]; - Grammar.Entry.obj - (gdelete_rule_body : 'gdelete_rule_body Grammar.Entry.e), - None, - [None, None, - [[Gramext.Stoken ("UIDENT", ""); - Gramext.Snterm (Grammar.Entry.obj (name : 'name Grammar.Entry.e)); - Gramext.Stoken ("", ":"); - Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj (symbol : 'symbol Grammar.Entry.e)), - Gramext.Snterm - (Grammar.Entry.obj (semi_sep : 'semi_sep Grammar.Entry.e)))], - Gramext.action - (fun (sl : 'symbol list) _ (n : 'name) (g : string) - (loc : int * int) -> - (let (e, b) = expr_of_delete_rule loc g n sl in - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, g), - MLast.ExLid (loc, "delete_rule")), - e), - b) : - 'gdelete_rule_body))]]; - Grammar.Entry.obj (efunction : 'efunction Grammar.Entry.e), None, - [None, None, - [[], - Gramext.action - (fun (loc : int * int) -> - (MLast.ExAcc - (loc, MLast.ExUid (loc, "Grammar"), - MLast.ExLid (loc, "extend")) : - 'efunction)); - [Gramext.Stoken ("UIDENT", "FUNCTION"); Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (qualid : 'qualid Grammar.Entry.e)); - Gramext.Snterm - (Grammar.Entry.obj (semi_sep : 'semi_sep Grammar.Entry.e))], - Gramext.action - (fun _ (f : 'qualid) _ _ (loc : int * int) -> (f : 'efunction))]]; - Grammar.Entry.obj (global : 'global Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("UIDENT", "GLOBAL"); Gramext.Stoken ("", ":"); - Gramext.Slist1 - (Gramext.Snterm (Grammar.Entry.obj (name : 'name Grammar.Entry.e))); - Gramext.Snterm - (Grammar.Entry.obj (semi_sep : 'semi_sep Grammar.Entry.e))], - Gramext.action - (fun _ (sl : 'name list) _ _ (loc : int * int) -> (sl : 'global))]]; - Grammar.Entry.obj (entry : 'entry Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm (Grammar.Entry.obj (name : 'name Grammar.Entry.e)); - Gramext.Stoken ("", ":"); - Gramext.Sopt - (Gramext.Snterm - (Grammar.Entry.obj (position : 'position Grammar.Entry.e))); - Gramext.Snterm - (Grammar.Entry.obj (level_list : 'level_list Grammar.Entry.e))], - Gramext.action - (fun (ll : 'level_list) (pos : 'position option) _ (n : 'name) - (loc : int * int) -> - ({name = n; pos = pos; levels = ll} : 'entry))]]; - Grammar.Entry.obj (position : 'position Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("UIDENT", "LEVEL"); - Gramext.Snterm (Grammar.Entry.obj (string : 'string Grammar.Entry.e))], - Gramext.action - (fun (n : 'string) _ (loc : int * int) -> - (MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "Gramext"), - MLast.ExUid (loc, "Level")), - n) : - 'position)); - [Gramext.Stoken ("UIDENT", "AFTER"); - Gramext.Snterm (Grammar.Entry.obj (string : 'string Grammar.Entry.e))], - Gramext.action - (fun (n : 'string) _ (loc : int * int) -> - (MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "Gramext"), - MLast.ExUid (loc, "After")), - n) : - 'position)); - [Gramext.Stoken ("UIDENT", "BEFORE"); - Gramext.Snterm (Grammar.Entry.obj (string : 'string Grammar.Entry.e))], - Gramext.action - (fun (n : 'string) _ (loc : int * int) -> - (MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "Gramext"), - MLast.ExUid (loc, "Before")), - n) : - 'position)); - [Gramext.Stoken ("UIDENT", "LAST")], - Gramext.action - (fun _ (loc : int * int) -> - (MLast.ExAcc - (loc, MLast.ExUid (loc, "Gramext"), MLast.ExUid (loc, "Last")) : - 'position)); - [Gramext.Stoken ("UIDENT", "FIRST")], - Gramext.action - (fun _ (loc : int * int) -> - (MLast.ExAcc - (loc, MLast.ExUid (loc, "Gramext"), - MLast.ExUid (loc, "First")) : - 'position))]]; - Grammar.Entry.obj (level_list : 'level_list Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "["); - Gramext.Slist0sep - (Gramext.Snterm (Grammar.Entry.obj (level : 'level Grammar.Entry.e)), - Gramext.Stoken ("", "|")); - Gramext.Stoken ("", "]")], - Gramext.action - (fun _ (ll : 'level list) _ (loc : int * int) -> - (ll : 'level_list))]]; - Grammar.Entry.obj (level : 'level Grammar.Entry.e), None, - [None, None, - [[Gramext.Sopt (Gramext.Stoken ("STRING", "")); - Gramext.Sopt - (Gramext.Snterm - (Grammar.Entry.obj (assoc : 'assoc Grammar.Entry.e))); - Gramext.Snterm - (Grammar.Entry.obj (rule_list : 'rule_list Grammar.Entry.e))], - Gramext.action - (fun (rules : 'rule_list) (ass : 'assoc option) (lab : string option) - (loc : int * int) -> - ({label = lab; assoc = ass; rules = rules} : 'level))]]; - Grammar.Entry.obj (assoc : 'assoc Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("UIDENT", "NONA")], - Gramext.action - (fun _ (loc : int * int) -> - (MLast.ExAcc - (loc, MLast.ExUid (loc, "Gramext"), MLast.ExUid (loc, "NonA")) : - 'assoc)); - [Gramext.Stoken ("UIDENT", "RIGHTA")], - Gramext.action - (fun _ (loc : int * int) -> - (MLast.ExAcc - (loc, MLast.ExUid (loc, "Gramext"), - MLast.ExUid (loc, "RightA")) : - 'assoc)); - [Gramext.Stoken ("UIDENT", "LEFTA")], - Gramext.action - (fun _ (loc : int * int) -> - (MLast.ExAcc - (loc, MLast.ExUid (loc, "Gramext"), - MLast.ExUid (loc, "LeftA")) : - 'assoc))]]; - Grammar.Entry.obj (rule_list : 'rule_list Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "["); - Gramext.Slist1sep - (Gramext.Snterm (Grammar.Entry.obj (rule : 'rule Grammar.Entry.e)), - Gramext.Stoken ("", "|")); - Gramext.Stoken ("", "]")], - Gramext.action - (fun _ (rules : 'rule list) _ (loc : int * int) -> - (retype_rule_list_without_patterns loc rules : 'rule_list)); - [Gramext.Stoken ("", "["); Gramext.Stoken ("", "]")], - Gramext.action (fun _ _ (loc : int * int) -> ([] : 'rule_list))]]; - Grammar.Entry.obj (rule : 'rule Grammar.Entry.e), None, - [None, None, - [[Gramext.Slist0sep - (Gramext.Snterm - (Grammar.Entry.obj (psymbol : 'psymbol Grammar.Entry.e)), - Gramext.Snterm - (Grammar.Entry.obj (semi_sep : 'semi_sep Grammar.Entry.e)))], - Gramext.action - (fun (psl : 'psymbol list) (loc : int * int) -> - ({prod = psl; action = None} : 'rule)); - [Gramext.Slist0sep - (Gramext.Snterm - (Grammar.Entry.obj (psymbol : 'psymbol Grammar.Entry.e)), - Gramext.Snterm - (Grammar.Entry.obj (semi_sep : 'semi_sep Grammar.Entry.e))); - Gramext.Stoken ("", "->"); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (act : 'expr) _ (psl : 'psymbol list) (loc : int * int) -> - ({prod = psl; action = Some act} : 'rule))]]; - Grammar.Entry.obj (psymbol : 'psymbol Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm (Grammar.Entry.obj (symbol : 'symbol Grammar.Entry.e))], - Gramext.action - (fun (s : 'symbol) (loc : int * int) -> - ({pattern = None; symbol = s} : 'psymbol)); - [Gramext.Snterm - (Grammar.Entry.obj (pattern : 'pattern Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (symbol : 'symbol Grammar.Entry.e))], - Gramext.action - (fun (s : 'symbol) _ (p : 'pattern) (loc : int * int) -> - ({pattern = Some p; symbol = s} : 'psymbol)); - [Gramext.Stoken ("LIDENT", ""); - Gramext.Sopt - (Gramext.srules - [[Gramext.Stoken ("UIDENT", "LEVEL"); - Gramext.Stoken ("STRING", "")], - Gramext.action - (fun (s : string) _ (loc : int * int) -> (s : 'e__3))])], - Gramext.action - (fun (lev : 'e__3 option) (i : string) (loc : int * int) -> - (let name = mk_name loc (MLast.ExLid (loc, i)) in - let text = TXnterm (loc, name, lev) in - let styp = STquo (loc, i) in - let symb = {used = [i]; text = text; styp = styp} in - {pattern = None; symbol = symb} : - 'psymbol)); - [Gramext.Stoken ("LIDENT", ""); Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (symbol : 'symbol Grammar.Entry.e))], - Gramext.action - (fun (s : 'symbol) _ (p : string) (loc : int * int) -> - ({pattern = Some (MLast.PaLid (loc, p)); symbol = s} : - 'psymbol))]]; - Grammar.Entry.obj (symbol : 'symbol Grammar.Entry.e), None, - [Some "top", Some Gramext.NonA, - [[Gramext.Stoken ("UIDENT", "OPT"); Gramext.Sself], - Gramext.action - (fun (s : 'symbol) _ (loc : int * int) -> - (if !quotify then ssopt loc s - else - let styp = STapp (loc, STlid (loc, "option"), s.styp) in - let text = TXopt (loc, s.text) in - {used = s.used; text = text; styp = styp} : - 'symbol)); - [Gramext.Stoken ("UIDENT", "LIST1"); Gramext.Sself; - Gramext.Sopt - (Gramext.srules - [[Gramext.Stoken ("UIDENT", "SEP"); - Gramext.Snterm - (Grammar.Entry.obj (symbol : 'symbol Grammar.Entry.e))], - Gramext.action - (fun (t : 'symbol) _ (loc : int * int) -> (t : 'e__5))])], - Gramext.action - (fun (sep : 'e__5 option) (s : 'symbol) _ (loc : int * int) -> - (if !quotify then sslist loc true sep s - else - 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} : - 'symbol)); - [Gramext.Stoken ("UIDENT", "LIST0"); Gramext.Sself; - Gramext.Sopt - (Gramext.srules - [[Gramext.Stoken ("UIDENT", "SEP"); - Gramext.Snterm - (Grammar.Entry.obj (symbol : 'symbol Grammar.Entry.e))], - Gramext.action - (fun (t : 'symbol) _ (loc : int * int) -> (t : 'e__4))])], - Gramext.action - (fun (sep : 'e__4 option) (s : 'symbol) _ (loc : int * int) -> - (if !quotify then sslist loc false sep s - else - 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} : - 'symbol))]; - None, None, - [[Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (s_t : 'symbol) _ (loc : int * int) -> (s_t : 'symbol)); - [Gramext.Snterm (Grammar.Entry.obj (name : 'name Grammar.Entry.e)); - Gramext.Sopt - (Gramext.srules - [[Gramext.Stoken ("UIDENT", "LEVEL"); - Gramext.Stoken ("STRING", "")], - Gramext.action - (fun (s : string) _ (loc : int * int) -> (s : 'e__7))])], - Gramext.action - (fun (lev : 'e__7 option) (n : 'name) (loc : int * int) -> - ({used = [n.tvar]; text = TXnterm (loc, n, lev); - styp = STquo (loc, n.tvar)} : - 'symbol)); - [Gramext.Stoken ("UIDENT", ""); Gramext.Stoken ("", "."); - Gramext.Snterm (Grammar.Entry.obj (qualid : 'qualid Grammar.Entry.e)); - Gramext.Sopt - (Gramext.srules - [[Gramext.Stoken ("UIDENT", "LEVEL"); - Gramext.Stoken ("STRING", "")], - Gramext.action - (fun (s : string) _ (loc : int * int) -> (s : 'e__6))])], - Gramext.action - (fun (lev : 'e__6 option) (e : 'qualid) _ (i : string) - (loc : int * int) -> - (let n = - mk_name loc (MLast.ExAcc (loc, MLast.ExUid (loc, i), e)) - in - {used = [n.tvar]; text = TXnterm (loc, n, lev); - styp = STquo (loc, n.tvar)} : - 'symbol)); - [Gramext.Snterm (Grammar.Entry.obj (string : 'string Grammar.Entry.e))], - Gramext.action - (fun (e : 'string) (loc : int * int) -> - (let text = TXtok (loc, "", e) in - {used = []; text = text; styp = STlid (loc, "string")} : - 'symbol)); - [Gramext.Stoken ("UIDENT", ""); - Gramext.Snterm (Grammar.Entry.obj (string : 'string Grammar.Entry.e))], - Gramext.action - (fun (e : 'string) (x : string) (loc : int * int) -> - (let text = TXtok (loc, x, e) in - {used = []; text = text; styp = STlid (loc, "string")} : - 'symbol)); - [Gramext.Stoken ("UIDENT", "")], - Gramext.action - (fun (x : string) (loc : int * int) -> - (let text = - if !quotify then sstoken loc x - else TXtok (loc, x, MLast.ExStr (loc, "")) - in - {used = []; text = text; styp = STlid (loc, "string")} : - 'symbol)); - [Gramext.Stoken ("", "["); - Gramext.Slist0sep - (Gramext.Snterm (Grammar.Entry.obj (rule : 'rule Grammar.Entry.e)), - Gramext.Stoken ("", "|")); - Gramext.Stoken ("", "]")], - Gramext.action - (fun _ (rl : 'rule list) _ (loc : int * int) -> - (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)} : - 'symbol)); - [Gramext.Stoken ("UIDENT", "NEXT")], - Gramext.action - (fun _ (loc : int * int) -> - ({used = []; text = TXnext loc; styp = STself (loc, "NEXT")} : - 'symbol)); - [Gramext.Stoken ("UIDENT", "SELF")], - Gramext.action - (fun _ (loc : int * int) -> - ({used = []; text = TXself loc; styp = STself (loc, "SELF")} : - 'symbol))]]; - Grammar.Entry.obj (pattern : 'pattern Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ","); - Gramext.Snterm - (Grammar.Entry.obj - (patterns_comma : 'patterns_comma Grammar.Entry.e)); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (pl : 'patterns_comma) _ (p : 'pattern) _ (loc : int * int) -> - (MLast.PaTup (loc, (p :: pl)) : 'pattern)); - [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (p : 'pattern) _ (loc : int * int) -> (p : 'pattern)); - [Gramext.Stoken ("", "_")], - Gramext.action - (fun _ (loc : int * int) -> (MLast.PaAny loc : 'pattern)); - [Gramext.Stoken ("LIDENT", "")], - Gramext.action - (fun (i : string) (loc : int * int) -> - (MLast.PaLid (loc, i) : 'pattern))]]; - Grammar.Entry.obj (patterns_comma : 'patterns_comma Grammar.Entry.e), - None, - [None, None, - [[Gramext.Sself; Gramext.Stoken ("", ","); - Gramext.Snterm - (Grammar.Entry.obj (pattern : 'pattern Grammar.Entry.e))], - Gramext.action - (fun (p : 'pattern) _ (pl : 'patterns_comma) (loc : int * int) -> - (pl @ [p] : 'patterns_comma))]; - None, None, - [[Gramext.Snterm - (Grammar.Entry.obj (pattern : 'pattern Grammar.Entry.e))], - Gramext.action - (fun (p : 'pattern) (loc : int * int) -> ([p] : 'patterns_comma))]]; - Grammar.Entry.obj (name : 'name Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm (Grammar.Entry.obj (qualid : 'qualid Grammar.Entry.e))], - Gramext.action - (fun (e : 'qualid) (loc : int * int) -> (mk_name loc e : 'name))]]; - Grammar.Entry.obj (qualid : 'qualid Grammar.Entry.e), None, - [None, None, - [[Gramext.Sself; Gramext.Stoken ("", "."); Gramext.Sself], - Gramext.action - (fun (e2 : 'qualid) _ (e1 : 'qualid) (loc : int * int) -> - (MLast.ExAcc (loc, e1, e2) : 'qualid))]; - None, None, - [[Gramext.Stoken ("LIDENT", "")], - Gramext.action - (fun (i : string) (loc : int * int) -> - (MLast.ExLid (loc, i) : 'qualid)); - [Gramext.Stoken ("UIDENT", "")], - Gramext.action - (fun (i : string) (loc : int * int) -> - (MLast.ExUid (loc, i) : 'qualid))]]; - Grammar.Entry.obj (string : 'string Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("ANTIQUOT", "")], - Gramext.action - (fun (i : string) (loc : int * int) -> - (let shift = fst loc + String.length "$" in - let e = - try Grammar.Entry.parse Pcaml.expr_eoi (Stream.of_string i) with - Exc_located ((bp, ep), exc) -> - raise_with_loc (shift + bp, shift + ep) exc - in - Pcaml.expr_reloc (fun (bp, ep) -> shift + bp, shift + ep) 0 e : - 'string)); - [Gramext.Stoken ("STRING", "")], - Gramext.action - (fun (s : string) (loc : int * int) -> - (MLast.ExStr (loc, s) : 'string))]]]);; - -Pcaml.add_option "-quotify" (Arg.Set quotify) "Generate code for quotations";; - -Pcaml.add_option "-meta_action" (Arg.Set meta_action) "Undocumented";; diff --git a/camlp4/ocaml_src/meta/pa_extend_m.ml b/camlp4/ocaml_src/meta/pa_extend_m.ml deleted file mode 100644 index 11fd07f58a..0000000000 --- a/camlp4/ocaml_src/meta/pa_extend_m.ml +++ /dev/null @@ -1,40 +0,0 @@ -(* camlp4r pa_extend.cmo q_MLast.cmo *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* This file has been generated by program: do not edit! *) - -open Pa_extend;; - -Grammar.extend - [Grammar.Entry.obj (symbol : 'symbol Grammar.Entry.e), - Some (Gramext.Level "top"), - [None, Some Gramext.NonA, - [[Gramext.Stoken ("UIDENT", "SOPT"); Gramext.Sself], - Gramext.action - (fun (s : 'symbol) _ (loc : int * int) -> (ssopt loc s : 'symbol)); - [Gramext.srules - [[Gramext.Stoken ("UIDENT", "SLIST1")], - Gramext.action (fun _ (loc : int * int) -> (true : 'e__1)); - [Gramext.Stoken ("UIDENT", "SLIST0")], - Gramext.action (fun _ (loc : int * int) -> (false : 'e__1))]; - Gramext.Sself; - Gramext.Sopt - (Gramext.srules - [[Gramext.Stoken ("UIDENT", "SEP"); - Gramext.Snterm - (Grammar.Entry.obj (symbol : 'symbol Grammar.Entry.e))], - Gramext.action - (fun (t : 'symbol) _ (loc : int * int) -> (t : 'e__2))])], - Gramext.action - (fun (sep : 'e__2 option) (s : 'symbol) (min : 'e__1) - (loc : int * int) -> - (sslist loc min sep s : 'symbol))]]];; diff --git a/camlp4/ocaml_src/meta/pa_ifdef.ml b/camlp4/ocaml_src/meta/pa_ifdef.ml deleted file mode 100644 index 6384d6be1f..0000000000 --- a/camlp4/ocaml_src/meta/pa_ifdef.ml +++ /dev/null @@ -1,216 +0,0 @@ -(* camlp4r pa_extend.cmo q_MLast.cmo *) -(* This file has been generated by program: do not edit! *) - -type 'a item_or_def = - SdStr of 'a - | SdDef of string - | SdUnd of string - | SdNop -;; - -let list_remove x l = - List.fold_right (fun e l -> if e = x then l else e :: l) l [] -;; - -let defined = ref ["OCAML_305"; "CAMLP4_300"; "NEWSEQ"];; -let define x = defined := x :: !defined;; -let undef x = defined := list_remove x !defined;; - -Grammar.extend - (let _ = (Pcaml.expr : 'Pcaml__expr Grammar.Entry.e) - and _ = (Pcaml.str_item : 'Pcaml__str_item Grammar.Entry.e) - and _ = (Pcaml.sig_item : 'Pcaml__sig_item Grammar.Entry.e) in - let grammar_entry_create s = - Grammar.Entry.create (Grammar.of_entry Pcaml.expr) s - in - let def_undef_str : 'def_undef_str Grammar.Entry.e = - grammar_entry_create "def_undef_str" - and str_item_def_undef : 'str_item_def_undef Grammar.Entry.e = - grammar_entry_create "str_item_def_undef" - and def_undef_sig : 'def_undef_sig Grammar.Entry.e = - grammar_entry_create "def_undef_sig" - and sig_item_def_undef : 'sig_item_def_undef Grammar.Entry.e = - grammar_entry_create "sig_item_def_undef" - in - [Grammar.Entry.obj (Pcaml.expr : 'Pcaml__expr Grammar.Entry.e), - Some (Gramext.Level "top"), - [None, None, - [[Gramext.Stoken ("", "ifndef"); Gramext.Stoken ("UIDENT", ""); - Gramext.Stoken ("", "then"); Gramext.Sself; - Gramext.Stoken ("", "else"); Gramext.Sself], - Gramext.action - (fun (e2 : 'Pcaml__expr) _ (e1 : 'Pcaml__expr) _ (c : string) _ - (loc : int * int) -> - (if List.mem c !defined then e2 else e1 : 'Pcaml__expr)); - [Gramext.Stoken ("", "ifdef"); Gramext.Stoken ("UIDENT", ""); - Gramext.Stoken ("", "then"); Gramext.Sself; - Gramext.Stoken ("", "else"); Gramext.Sself], - Gramext.action - (fun (e2 : 'Pcaml__expr) _ (e1 : 'Pcaml__expr) _ (c : string) _ - (loc : int * int) -> - (if List.mem c !defined then e1 else e2 : 'Pcaml__expr))]]; - Grammar.Entry.obj (Pcaml.str_item : 'Pcaml__str_item Grammar.Entry.e), - Some Gramext.First, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj - (def_undef_str : 'def_undef_str Grammar.Entry.e))], - Gramext.action - (fun (x : 'def_undef_str) (loc : int * int) -> - (match x with - SdStr si -> si - | SdDef x -> define x; MLast.StDcl (loc, []) - | SdUnd x -> undef x; MLast.StDcl (loc, []) - | SdNop -> MLast.StDcl (loc, []) : - 'Pcaml__str_item))]]; - Grammar.Entry.obj (def_undef_str : 'def_undef_str Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "undef"); Gramext.Stoken ("UIDENT", "")], - Gramext.action - (fun (c : string) _ (loc : int * int) -> (SdUnd c : 'def_undef_str)); - [Gramext.Stoken ("", "define"); Gramext.Stoken ("UIDENT", "")], - Gramext.action - (fun (c : string) _ (loc : int * int) -> (SdDef c : 'def_undef_str)); - [Gramext.Stoken ("", "ifndef"); Gramext.Stoken ("UIDENT", ""); - Gramext.Stoken ("", "then"); - Gramext.Snterm - (Grammar.Entry.obj - (str_item_def_undef : 'str_item_def_undef Grammar.Entry.e))], - Gramext.action - (fun (e1 : 'str_item_def_undef) _ (c : string) _ (loc : int * int) -> - (if List.mem c !defined then SdNop else e1 : 'def_undef_str)); - [Gramext.Stoken ("", "ifndef"); Gramext.Stoken ("UIDENT", ""); - Gramext.Stoken ("", "then"); - Gramext.Snterm - (Grammar.Entry.obj - (str_item_def_undef : 'str_item_def_undef Grammar.Entry.e)); - Gramext.Stoken ("", "else"); - Gramext.Snterm - (Grammar.Entry.obj - (str_item_def_undef : 'str_item_def_undef Grammar.Entry.e))], - Gramext.action - (fun (e2 : 'str_item_def_undef) _ (e1 : 'str_item_def_undef) _ - (c : string) _ (loc : int * int) -> - (if List.mem c !defined then e2 else e1 : 'def_undef_str)); - [Gramext.Stoken ("", "ifdef"); Gramext.Stoken ("UIDENT", ""); - Gramext.Stoken ("", "then"); - Gramext.Snterm - (Grammar.Entry.obj - (str_item_def_undef : 'str_item_def_undef Grammar.Entry.e))], - Gramext.action - (fun (e1 : 'str_item_def_undef) _ (c : string) _ (loc : int * int) -> - (if List.mem c !defined then e1 else SdNop : 'def_undef_str)); - [Gramext.Stoken ("", "ifdef"); Gramext.Stoken ("UIDENT", ""); - Gramext.Stoken ("", "then"); - Gramext.Snterm - (Grammar.Entry.obj - (str_item_def_undef : 'str_item_def_undef Grammar.Entry.e)); - Gramext.Stoken ("", "else"); - Gramext.Snterm - (Grammar.Entry.obj - (str_item_def_undef : 'str_item_def_undef Grammar.Entry.e))], - Gramext.action - (fun (e2 : 'str_item_def_undef) _ (e1 : 'str_item_def_undef) _ - (c : string) _ (loc : int * int) -> - (if List.mem c !defined then e1 else e2 : 'def_undef_str))]]; - Grammar.Entry.obj - (str_item_def_undef : 'str_item_def_undef Grammar.Entry.e), - None, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj - (Pcaml.str_item : 'Pcaml__str_item Grammar.Entry.e))], - Gramext.action - (fun (si : 'Pcaml__str_item) (loc : int * int) -> - (SdStr si : 'str_item_def_undef)); - [Gramext.Snterm - (Grammar.Entry.obj - (def_undef_str : 'def_undef_str Grammar.Entry.e))], - Gramext.action - (fun (d : 'def_undef_str) (loc : int * int) -> - (d : 'str_item_def_undef))]]; - Grammar.Entry.obj (Pcaml.sig_item : 'Pcaml__sig_item Grammar.Entry.e), - Some Gramext.First, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj - (def_undef_sig : 'def_undef_sig Grammar.Entry.e))], - Gramext.action - (fun (x : 'def_undef_sig) (loc : int * int) -> - (match x with - SdStr si -> si - | SdDef x -> define x; MLast.SgDcl (loc, []) - | SdUnd x -> undef x; MLast.SgDcl (loc, []) - | SdNop -> MLast.SgDcl (loc, []) : - 'Pcaml__sig_item))]]; - Grammar.Entry.obj (def_undef_sig : 'def_undef_sig Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "undef"); Gramext.Stoken ("UIDENT", "")], - Gramext.action - (fun (c : string) _ (loc : int * int) -> (SdUnd c : 'def_undef_sig)); - [Gramext.Stoken ("", "define"); Gramext.Stoken ("UIDENT", "")], - Gramext.action - (fun (c : string) _ (loc : int * int) -> (SdDef c : 'def_undef_sig)); - [Gramext.Stoken ("", "ifndef"); Gramext.Stoken ("UIDENT", ""); - Gramext.Stoken ("", "then"); - Gramext.Snterm - (Grammar.Entry.obj - (sig_item_def_undef : 'sig_item_def_undef Grammar.Entry.e))], - Gramext.action - (fun (e1 : 'sig_item_def_undef) _ (c : string) _ (loc : int * int) -> - (if List.mem c !defined then SdNop else e1 : 'def_undef_sig)); - [Gramext.Stoken ("", "ifndef"); Gramext.Stoken ("UIDENT", ""); - Gramext.Stoken ("", "then"); - Gramext.Snterm - (Grammar.Entry.obj - (sig_item_def_undef : 'sig_item_def_undef Grammar.Entry.e)); - Gramext.Stoken ("", "else"); - Gramext.Snterm - (Grammar.Entry.obj - (sig_item_def_undef : 'sig_item_def_undef Grammar.Entry.e))], - Gramext.action - (fun (e2 : 'sig_item_def_undef) _ (e1 : 'sig_item_def_undef) _ - (c : string) _ (loc : int * int) -> - (if List.mem c !defined then e2 else e1 : 'def_undef_sig)); - [Gramext.Stoken ("", "ifdef"); Gramext.Stoken ("UIDENT", ""); - Gramext.Stoken ("", "then"); - Gramext.Snterm - (Grammar.Entry.obj - (sig_item_def_undef : 'sig_item_def_undef Grammar.Entry.e))], - Gramext.action - (fun (e1 : 'sig_item_def_undef) _ (c : string) _ (loc : int * int) -> - (if List.mem c !defined then e1 else SdNop : 'def_undef_sig)); - [Gramext.Stoken ("", "ifdef"); Gramext.Stoken ("UIDENT", ""); - Gramext.Stoken ("", "then"); - Gramext.Snterm - (Grammar.Entry.obj - (sig_item_def_undef : 'sig_item_def_undef Grammar.Entry.e)); - Gramext.Stoken ("", "else"); - Gramext.Snterm - (Grammar.Entry.obj - (sig_item_def_undef : 'sig_item_def_undef Grammar.Entry.e))], - Gramext.action - (fun (e2 : 'sig_item_def_undef) _ (e1 : 'sig_item_def_undef) _ - (c : string) _ (loc : int * int) -> - (if List.mem c !defined then e1 else e2 : 'def_undef_sig))]]; - Grammar.Entry.obj - (sig_item_def_undef : 'sig_item_def_undef Grammar.Entry.e), - None, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj - (Pcaml.sig_item : 'Pcaml__sig_item Grammar.Entry.e))], - Gramext.action - (fun (si : 'Pcaml__sig_item) (loc : int * int) -> - (SdStr si : 'sig_item_def_undef)); - [Gramext.Snterm - (Grammar.Entry.obj - (def_undef_sig : 'def_undef_sig Grammar.Entry.e))], - Gramext.action - (fun (d : 'def_undef_sig) (loc : int * int) -> - (d : 'sig_item_def_undef))]]]);; - -Pcaml.add_option "-D" (Arg.String define) - " Define for ifdef instruction.";; -Pcaml.add_option "-U" (Arg.String undef) - " Undefine for ifdef instruction.";; diff --git a/camlp4/ocaml_src/meta/pa_macro.ml b/camlp4/ocaml_src/meta/pa_macro.ml deleted file mode 100644 index 599608f9fa..0000000000 --- a/camlp4/ocaml_src/meta/pa_macro.ml +++ /dev/null @@ -1,392 +0,0 @@ -(* camlp4r *) -(* This file has been generated by program: do not edit! *) - -(* -Added statements: - - At toplevel (structure item): - - DEFINE - DEFINE = - DEFINE () = - IFDEF THEN END - IFDEF THEN ELSE END - IFNDEF THEN END - IFNDEF THEN ELSE END - - In expressions: - - IFDEF THEN ELSE END - IFNDEF THEN ELSE END - __FILE__ - __LOCATION__ - - In patterns: - - IFDEF THEN ELSE END - IFNDEF THEN ELSE END - - As Camlp4 options: - - -D - -U - - After having used a DEFINE followed by "= ", you - can use it in expressions *and* in patterns. If the expression defining - the macro cannot be used as a pattern, there is an error message if - it is used in a pattern. - - The expression __FILE__ returns the current compiled file name. - The expression __LOCATION__ returns the current location of itself. - -*) - -(* #load "pa_extend.cmo" *) -(* #load "q_MLast.cmo" *) - -open Pcaml;; - -type 'a item_or_def = - SdStr of 'a - | SdDef of string * (string list * MLast.expr) option - | SdUnd of string - | SdNop -;; - -let rec list_remove x = - function - (y, _) :: l when y = x -> l - | d :: l -> d :: list_remove x l - | [] -> [] -;; - -let defined = ref [];; - -let is_defined i = List.mem_assoc i !defined;; - -let loc = 0, 0;; - -let subst mloc env = - let rec loop = - function - MLast.ExLet (_, rf, pel, e) -> - let pel = List.map (fun (p, e) -> p, loop e) pel in - MLast.ExLet (loc, rf, pel, loop e) - | MLast.ExIfe (_, e1, e2, e3) -> - MLast.ExIfe (loc, loop e1, loop e2, loop e3) - | MLast.ExApp (_, e1, e2) -> MLast.ExApp (loc, loop e1, loop e2) - | MLast.ExLid (_, x) | MLast.ExUid (_, x) as e -> - begin try MLast.ExAnt (loc, List.assoc x env) with - Not_found -> e - end - | MLast.ExTup (_, x) -> MLast.ExTup (loc, List.map loop x) - | MLast.ExRec (_, pel, None) -> - let pel = List.map (fun (p, e) -> p, loop e) pel in - MLast.ExRec (loc, pel, None) - | e -> e - in - loop -;; - -let substp mloc env = - let rec loop = - function - MLast.ExApp (_, e1, e2) -> MLast.PaApp (loc, loop e1, loop e2) - | MLast.ExLid (_, x) -> - begin try MLast.PaAnt (loc, List.assoc x env) with - Not_found -> MLast.PaLid (loc, x) - end - | MLast.ExUid (_, x) -> - begin try MLast.PaAnt (loc, List.assoc x env) with - Not_found -> MLast.PaUid (loc, x) - end - | MLast.ExInt (_, x) -> MLast.PaInt (loc, x) - | MLast.ExTup (_, x) -> MLast.PaTup (loc, List.map loop x) - | MLast.ExRec (_, pel, None) -> - let ppl = List.map (fun (p, e) -> p, loop e) pel in - MLast.PaRec (loc, ppl) - | x -> - Stdpp.raise_with_loc mloc - (Failure - "this macro cannot be used in a pattern (see its definition)") - in - loop -;; - -let incorrect_number loc l1 l2 = - Stdpp.raise_with_loc loc - (Failure - (Printf.sprintf "expected %d parameters; found %d" (List.length l2) - (List.length l1))) -;; - -let define eo x = - begin match eo with - Some ([], e) -> - Grammar.extend - [Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), - Some (Gramext.Level "simple"), - [None, None, - [[Gramext.Stoken ("UIDENT", x)], - Gramext.action - (fun _ (loc : int * int) -> - (Pcaml.expr_reloc (fun _ -> loc) 0 e : 'expr))]]; - Grammar.Entry.obj (patt : 'patt Grammar.Entry.e), - Some (Gramext.Level "simple"), - [None, None, - [[Gramext.Stoken ("UIDENT", x)], - Gramext.action - (fun _ (loc : int * int) -> - (let p = substp loc [] e in - Pcaml.patt_reloc (fun _ -> loc) 0 p : - 'patt))]]] - | Some (sl, e) -> - Grammar.extend - [Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), - Some (Gramext.Level "apply"), - [None, None, - [[Gramext.Stoken ("UIDENT", x); Gramext.Sself], - Gramext.action - (fun (param : 'expr) _ (loc : int * int) -> - (let el = - match param with - MLast.ExTup (_, el) -> el - | e -> [e] - in - if List.length el = List.length sl then - let env = List.combine sl el in - let e = subst loc env e in - Pcaml.expr_reloc (fun _ -> loc) 0 e - else incorrect_number loc el sl : - 'expr))]]; - Grammar.Entry.obj (patt : 'patt Grammar.Entry.e), - Some (Gramext.Level "simple"), - [None, None, - [[Gramext.Stoken ("UIDENT", x); Gramext.Sself], - Gramext.action - (fun (param : 'patt) _ (loc : int * int) -> - (let pl = - match param with - MLast.PaTup (_, pl) -> pl - | 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 - Pcaml.patt_reloc (fun _ -> loc) 0 p - else incorrect_number loc pl sl : - 'patt))]]] - | None -> () - end; - defined := (x, eo) :: !defined -;; - -let undef x = - try - let eo = List.assoc x !defined in - begin match eo with - Some ([], _) -> - Grammar.delete_rule expr [Gramext.Stoken ("UIDENT", x)]; - Grammar.delete_rule patt [Gramext.Stoken ("UIDENT", x)] - | Some (_, _) -> - Grammar.delete_rule expr - [Gramext.Stoken ("UIDENT", x); Gramext.Sself]; - Grammar.delete_rule patt [Gramext.Stoken ("UIDENT", x); Gramext.Sself] - | None -> () - end; - defined := list_remove x !defined - with - Not_found -> () -;; - -Grammar.extend - (let _ = (expr : 'expr Grammar.Entry.e) - and _ = (patt : 'patt Grammar.Entry.e) - and _ = (str_item : 'str_item Grammar.Entry.e) - and _ = (sig_item : 'sig_item Grammar.Entry.e) in - let grammar_entry_create s = - Grammar.Entry.create (Grammar.of_entry expr) s - in - let macro_def : 'macro_def Grammar.Entry.e = - grammar_entry_create "macro_def" - and str_item_or_macro : 'str_item_or_macro Grammar.Entry.e = - grammar_entry_create "str_item_or_macro" - and opt_macro_value : 'opt_macro_value Grammar.Entry.e = - grammar_entry_create "opt_macro_value" - and uident : 'uident Grammar.Entry.e = grammar_entry_create "uident" in - [Grammar.Entry.obj (str_item : 'str_item Grammar.Entry.e), - Some Gramext.First, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj (macro_def : 'macro_def Grammar.Entry.e))], - Gramext.action - (fun (x : 'macro_def) (loc : int * int) -> - (match x with - SdStr [si] -> si - | SdStr sil -> MLast.StDcl (loc, sil) - | SdDef (x, eo) -> define eo x; MLast.StDcl (loc, []) - | SdUnd x -> undef x; MLast.StDcl (loc, []) - | SdNop -> MLast.StDcl (loc, []) : - 'str_item))]]; - Grammar.Entry.obj (macro_def : 'macro_def Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "IFNDEF"); - Gramext.Snterm (Grammar.Entry.obj (uident : 'uident Grammar.Entry.e)); - Gramext.Stoken ("", "THEN"); - Gramext.Snterm - (Grammar.Entry.obj - (str_item_or_macro : 'str_item_or_macro Grammar.Entry.e)); - Gramext.Stoken ("", "ELSE"); - Gramext.Snterm - (Grammar.Entry.obj - (str_item_or_macro : 'str_item_or_macro Grammar.Entry.e)); - Gramext.Stoken ("", "END")], - Gramext.action - (fun _ (d2 : 'str_item_or_macro) _ (d1 : 'str_item_or_macro) _ - (i : 'uident) _ (loc : int * int) -> - (if is_defined i then d2 else d1 : 'macro_def)); - [Gramext.Stoken ("", "IFNDEF"); - Gramext.Snterm (Grammar.Entry.obj (uident : 'uident Grammar.Entry.e)); - Gramext.Stoken ("", "THEN"); - Gramext.Snterm - (Grammar.Entry.obj - (str_item_or_macro : 'str_item_or_macro Grammar.Entry.e)); - Gramext.Stoken ("", "END")], - Gramext.action - (fun _ (d : 'str_item_or_macro) _ (i : 'uident) _ (loc : int * int) -> - (if is_defined i then SdNop else d : 'macro_def)); - [Gramext.Stoken ("", "IFDEF"); - Gramext.Snterm (Grammar.Entry.obj (uident : 'uident Grammar.Entry.e)); - Gramext.Stoken ("", "THEN"); - Gramext.Snterm - (Grammar.Entry.obj - (str_item_or_macro : 'str_item_or_macro Grammar.Entry.e)); - Gramext.Stoken ("", "ELSE"); - Gramext.Snterm - (Grammar.Entry.obj - (str_item_or_macro : 'str_item_or_macro Grammar.Entry.e)); - Gramext.Stoken ("", "END")], - Gramext.action - (fun _ (d2 : 'str_item_or_macro) _ (d1 : 'str_item_or_macro) _ - (i : 'uident) _ (loc : int * int) -> - (if is_defined i then d1 else d2 : 'macro_def)); - [Gramext.Stoken ("", "IFDEF"); - Gramext.Snterm (Grammar.Entry.obj (uident : 'uident Grammar.Entry.e)); - Gramext.Stoken ("", "THEN"); - Gramext.Snterm - (Grammar.Entry.obj - (str_item_or_macro : 'str_item_or_macro Grammar.Entry.e)); - Gramext.Stoken ("", "END")], - Gramext.action - (fun _ (d : 'str_item_or_macro) _ (i : 'uident) _ (loc : int * int) -> - (if is_defined i then d else SdNop : 'macro_def)); - [Gramext.Stoken ("", "UNDEF"); - Gramext.Snterm (Grammar.Entry.obj (uident : 'uident Grammar.Entry.e))], - Gramext.action - (fun (i : 'uident) _ (loc : int * int) -> (SdUnd i : 'macro_def)); - [Gramext.Stoken ("", "DEFINE"); - Gramext.Snterm (Grammar.Entry.obj (uident : 'uident Grammar.Entry.e)); - Gramext.Snterm - (Grammar.Entry.obj - (opt_macro_value : 'opt_macro_value Grammar.Entry.e))], - Gramext.action - (fun (def : 'opt_macro_value) (i : 'uident) _ (loc : int * int) -> - (SdDef (i, def) : 'macro_def))]]; - Grammar.Entry.obj - (str_item_or_macro : 'str_item_or_macro Grammar.Entry.e), - None, - [None, None, - [[Gramext.Slist1 - (Gramext.Snterm - (Grammar.Entry.obj (str_item : 'str_item Grammar.Entry.e)))], - Gramext.action - (fun (si : 'str_item list) (loc : int * int) -> - (SdStr si : 'str_item_or_macro)); - [Gramext.Snterm - (Grammar.Entry.obj (macro_def : 'macro_def Grammar.Entry.e))], - Gramext.action - (fun (d : 'macro_def) (loc : int * int) -> - (d : 'str_item_or_macro))]]; - Grammar.Entry.obj (opt_macro_value : 'opt_macro_value Grammar.Entry.e), - None, - [None, None, - [[], Gramext.action (fun (loc : int * int) -> (None : 'opt_macro_value)); - [Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) _ (loc : int * int) -> - (Some ([], e) : 'opt_macro_value)); - [Gramext.Stoken ("", "("); - Gramext.Slist1sep - (Gramext.Stoken ("LIDENT", ""), Gramext.Stoken ("", ",")); - Gramext.Stoken ("", ")"); Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) _ _ (pl : string list) _ (loc : int * int) -> - (Some (pl, e) : 'opt_macro_value))]]; - Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), - Some (Gramext.Level "top"), - [None, None, - [[Gramext.Stoken ("", "IFNDEF"); - Gramext.Snterm (Grammar.Entry.obj (uident : 'uident Grammar.Entry.e)); - Gramext.Stoken ("", "THEN"); Gramext.Sself; - Gramext.Stoken ("", "ELSE"); Gramext.Sself; - Gramext.Stoken ("", "END")], - Gramext.action - (fun _ (e2 : 'expr) _ (e1 : 'expr) _ (i : 'uident) _ - (loc : int * int) -> - (if is_defined i then e2 else e1 : 'expr)); - [Gramext.Stoken ("", "IFDEF"); - Gramext.Snterm (Grammar.Entry.obj (uident : 'uident Grammar.Entry.e)); - Gramext.Stoken ("", "THEN"); Gramext.Sself; - Gramext.Stoken ("", "ELSE"); Gramext.Sself; - Gramext.Stoken ("", "END")], - Gramext.action - (fun _ (e2 : 'expr) _ (e1 : 'expr) _ (i : 'uident) _ - (loc : int * int) -> - (if is_defined i then e1 else e2 : 'expr))]]; - Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), - Some (Gramext.Level "simple"), - [None, None, - [[Gramext.Stoken ("LIDENT", "__LOCATION__")], - Gramext.action - (fun _ (loc : int * int) -> - (let bp = string_of_int (fst loc) in - let ep = string_of_int (snd loc) in - MLast.ExTup - (loc, [MLast.ExInt (loc, bp); MLast.ExInt (loc, ep)]) : - 'expr)); - [Gramext.Stoken ("LIDENT", "__FILE__")], - Gramext.action - (fun _ (loc : int * int) -> - (MLast.ExStr (loc, !(Pcaml.input_file)) : 'expr))]]; - Grammar.Entry.obj (patt : 'patt Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "IFNDEF"); - Gramext.Snterm (Grammar.Entry.obj (uident : 'uident Grammar.Entry.e)); - Gramext.Stoken ("", "THEN"); Gramext.Sself; - Gramext.Stoken ("", "ELSE"); Gramext.Sself; - Gramext.Stoken ("", "END")], - Gramext.action - (fun _ (p2 : 'patt) _ (p1 : 'patt) _ (i : 'uident) _ - (loc : int * int) -> - (if is_defined i then p2 else p1 : 'patt)); - [Gramext.Stoken ("", "IFDEF"); - Gramext.Snterm (Grammar.Entry.obj (uident : 'uident Grammar.Entry.e)); - Gramext.Stoken ("", "THEN"); Gramext.Sself; - Gramext.Stoken ("", "ELSE"); Gramext.Sself; - Gramext.Stoken ("", "END")], - Gramext.action - (fun _ (p2 : 'patt) _ (p1 : 'patt) _ (i : 'uident) _ - (loc : int * int) -> - (if is_defined i then p1 else p2 : 'patt))]]; - Grammar.Entry.obj (uident : 'uident Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("UIDENT", "")], - Gramext.action - (fun (i : string) (loc : int * int) -> (i : 'uident))]]]);; - -Pcaml.add_option "-D" (Arg.String (define None)) - " Define for IFDEF instruction.";; -Pcaml.add_option "-U" (Arg.String undef) - " Undefine for IFDEF instruction.";; diff --git a/camlp4/ocaml_src/meta/pa_r.ml b/camlp4/ocaml_src/meta/pa_r.ml deleted file mode 100644 index 013adfa8d6..0000000000 --- a/camlp4/ocaml_src/meta/pa_r.ml +++ /dev/null @@ -1,2814 +0,0 @@ -(* camlp4r pa_extend.cmo q_MLast.cmo *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* This file has been generated by program: do not edit! *) - -open Stdpp;; -open Pcaml;; - -Pcaml.no_constructors_arity := false;; - -let help_sequences () = - Printf.eprintf "\ -New syntax: - do {e1; e2; ... ; en} - while e do {e1; e2; ... ; en} - for v = v1 to/downto v2 do {e1; e2; ... ; en} -Old (discouraged) syntax: - do e1; e2; ... ; en-1; return en - while e do e1; e2; ... ; en; done - for v = v1 to/downto v2 do e1; e2; ... ; en; done -To avoid compilation warning use the new syntax. -"; - flush stderr; - exit 1 -;; -Pcaml.add_option "-help_seq" (Arg.Unit help_sequences) - "Print explanations about new sequences and exit.";; - -let odfa = !(Plexer.dollar_for_antiquotation) in -Plexer.dollar_for_antiquotation := false; -Grammar.Unsafe.gram_reinit gram (Plexer.gmake ()); -Plexer.dollar_for_antiquotation := odfa; -Grammar.Unsafe.clear_entry interf; -Grammar.Unsafe.clear_entry implem; -Grammar.Unsafe.clear_entry top_phrase; -Grammar.Unsafe.clear_entry use_file; -Grammar.Unsafe.clear_entry module_type; -Grammar.Unsafe.clear_entry module_expr; -Grammar.Unsafe.clear_entry sig_item; -Grammar.Unsafe.clear_entry str_item; -Grammar.Unsafe.clear_entry expr; -Grammar.Unsafe.clear_entry patt; -Grammar.Unsafe.clear_entry ctyp; -Grammar.Unsafe.clear_entry let_binding; -Grammar.Unsafe.clear_entry type_declaration; -Grammar.Unsafe.clear_entry class_type; -Grammar.Unsafe.clear_entry class_expr; -Grammar.Unsafe.clear_entry class_sig_item; -Grammar.Unsafe.clear_entry class_str_item;; - -Pcaml.parse_interf := Grammar.Entry.parse interf;; -Pcaml.parse_implem := Grammar.Entry.parse implem;; - -let o2b = - function - Some _ -> true - | None -> false -;; - -let mksequence loc = - function - [e] -> e - | el -> MLast.ExSeq (loc, el) -;; - -let mkmatchcase loc p aso w e = - let p = - match aso with - Some p2 -> MLast.PaAli (loc, p, p2) - | _ -> p - in - p, w, e -;; - -let neg_string n = - let len = String.length n in - if len > 0 && n.[0] = '-' then String.sub n 1 (len - 1) else "-" ^ n -;; - -let mkumin loc f arg = - match arg with - MLast.ExInt (_, n) -> MLast.ExInt (loc, neg_string n) - | MLast.ExInt32 (loc, n) -> MLast.ExInt32 (loc, neg_string n) - | MLast.ExInt64 (loc, n) -> MLast.ExInt64 (loc, neg_string n) - | MLast.ExNativeInt (loc, n) -> MLast.ExNativeInt (loc, neg_string n) - | MLast.ExFlo (_, n) -> MLast.ExFlo (loc, neg_string n) - | _ -> let f = "~" ^ f in MLast.ExApp (loc, MLast.ExLid (loc, f), arg) -;; - -let mklistexp loc last = - let rec loop top = - function - [] -> - begin match last with - Some e -> e - | None -> MLast.ExUid (loc, "[]") - end - | e1 :: el -> - let loc = if top then loc else fst (MLast.loc_of_expr e1), snd loc in - MLast.ExApp - (loc, MLast.ExApp (loc, MLast.ExUid (loc, "::"), e1), loop false el) - in - loop true -;; - -let mklistpat loc last = - let rec loop top = - function - [] -> - begin match last with - Some p -> p - | None -> MLast.PaUid (loc, "[]") - end - | p1 :: pl -> - let loc = if top then loc else fst (MLast.loc_of_patt p1), snd loc in - MLast.PaApp - (loc, MLast.PaApp (loc, MLast.PaUid (loc, "::"), p1), loop false pl) - in - loop true -;; - -let mkexprident loc i j = - let rec loop m = - function - MLast.ExAcc (_, x, y) -> loop (MLast.ExAcc (loc, m, x)) y - | e -> MLast.ExAcc (loc, m, e) - in - loop (MLast.ExUid (loc, i)) j -;; - -let mkassert loc e = - match e with - MLast.ExUid (_, "False") -> MLast.ExAsf loc - | _ -> MLast.ExAsr (loc, e) -;; - -let append_elem el e = el @ [e];; - -(* ...suppose to flush the input in case of syntax error to avoid multiple - errors in case of cut-and-paste in the xterm, but work bad: for example - the input "for x = 1;" waits for another line before displaying the - error... -value rec sync cs = - match cs with parser - [ [: `';' :] -> sync_semi cs - | [: `_ :] -> sync cs ] -and sync_semi cs = - match Stream.peek cs with - [ Some ('\010' | '\013') -> () - | _ -> sync cs ] -; -Pcaml.sync.val := sync; -*) - -let ipatt = Grammar.Entry.create gram "ipatt";; -let with_constr = Grammar.Entry.create gram "with_constr";; -let row_field = Grammar.Entry.create gram "row_field";; - -let not_yet_warned_variant = ref true;; -let warn_variant loc = - if !not_yet_warned_variant then - begin - not_yet_warned_variant := false; - !(Pcaml.warning) loc - (Printf.sprintf - "use of syntax of variants types deprecated since version 3.05") - end -;; - -let not_yet_warned = ref true;; -let warn_sequence loc = - if !not_yet_warned then - begin - not_yet_warned := false; - !(Pcaml.warning) loc - "use of syntax of sequences deprecated since version 3.01.1" - end -;; -Pcaml.add_option "-no_warn_seq" (Arg.Clear not_yet_warned) - "No warning when using old syntax for sequences.";; - -Grammar.extend - (let _ = (sig_item : 'sig_item Grammar.Entry.e) - and _ = (str_item : 'str_item Grammar.Entry.e) - and _ = (ctyp : 'ctyp Grammar.Entry.e) - and _ = (patt : 'patt Grammar.Entry.e) - and _ = (expr : 'expr Grammar.Entry.e) - and _ = (module_type : 'module_type Grammar.Entry.e) - and _ = (module_expr : 'module_expr Grammar.Entry.e) - and _ = (class_type : 'class_type Grammar.Entry.e) - and _ = (class_expr : 'class_expr Grammar.Entry.e) - and _ = (class_sig_item : 'class_sig_item Grammar.Entry.e) - and _ = (class_str_item : 'class_str_item Grammar.Entry.e) - and _ = (let_binding : 'let_binding Grammar.Entry.e) - and _ = (type_declaration : 'type_declaration Grammar.Entry.e) - and _ = (ipatt : 'ipatt Grammar.Entry.e) - and _ = (with_constr : 'with_constr Grammar.Entry.e) - and _ = (row_field : 'row_field Grammar.Entry.e) in - let grammar_entry_create s = - Grammar.Entry.create (Grammar.of_entry sig_item) s - in - let rebind_exn : 'rebind_exn Grammar.Entry.e = - grammar_entry_create "rebind_exn" - and module_binding : 'module_binding Grammar.Entry.e = - grammar_entry_create "module_binding" - and module_rec_binding : 'module_rec_binding Grammar.Entry.e = - grammar_entry_create "module_rec_binding" - and module_declaration : 'module_declaration Grammar.Entry.e = - grammar_entry_create "module_declaration" - and module_rec_declaration : 'module_rec_declaration Grammar.Entry.e = - grammar_entry_create "module_rec_declaration" - and cons_expr_opt : 'cons_expr_opt Grammar.Entry.e = - grammar_entry_create "cons_expr_opt" - and dummy : 'dummy Grammar.Entry.e = grammar_entry_create "dummy" - and sequence : 'sequence Grammar.Entry.e = grammar_entry_create "sequence" - and fun_binding : 'fun_binding Grammar.Entry.e = - grammar_entry_create "fun_binding" - and match_case : 'match_case Grammar.Entry.e = - grammar_entry_create "match_case" - and as_patt_opt : 'as_patt_opt Grammar.Entry.e = - grammar_entry_create "as_patt_opt" - and when_expr_opt : 'when_expr_opt Grammar.Entry.e = - grammar_entry_create "when_expr_opt" - and label_expr : 'label_expr Grammar.Entry.e = - grammar_entry_create "label_expr" - and expr_ident : 'expr_ident Grammar.Entry.e = - grammar_entry_create "expr_ident" - and fun_def : 'fun_def Grammar.Entry.e = grammar_entry_create "fun_def" - and cons_patt_opt : 'cons_patt_opt Grammar.Entry.e = - grammar_entry_create "cons_patt_opt" - and label_patt : 'label_patt Grammar.Entry.e = - grammar_entry_create "label_patt" - and patt_label_ident : 'patt_label_ident Grammar.Entry.e = - grammar_entry_create "patt_label_ident" - and label_ipatt : 'label_ipatt Grammar.Entry.e = - grammar_entry_create "label_ipatt" - and type_patt : 'type_patt Grammar.Entry.e = - grammar_entry_create "type_patt" - and constrain : 'constrain Grammar.Entry.e = - grammar_entry_create "constrain" - and type_parameter : 'type_parameter Grammar.Entry.e = - grammar_entry_create "type_parameter" - and constructor_declaration : 'constructor_declaration Grammar.Entry.e = - grammar_entry_create "constructor_declaration" - and label_declaration : 'label_declaration Grammar.Entry.e = - grammar_entry_create "label_declaration" - and ident : 'ident Grammar.Entry.e = grammar_entry_create "ident" - and mod_ident : 'mod_ident Grammar.Entry.e = - grammar_entry_create "mod_ident" - and class_declaration : 'class_declaration Grammar.Entry.e = - grammar_entry_create "class_declaration" - and class_fun_binding : 'class_fun_binding Grammar.Entry.e = - grammar_entry_create "class_fun_binding" - and class_type_parameters : 'class_type_parameters Grammar.Entry.e = - grammar_entry_create "class_type_parameters" - and class_fun_def : 'class_fun_def Grammar.Entry.e = - grammar_entry_create "class_fun_def" - and class_structure : 'class_structure Grammar.Entry.e = - grammar_entry_create "class_structure" - and class_self_patt : 'class_self_patt Grammar.Entry.e = - grammar_entry_create "class_self_patt" - and as_lident : 'as_lident Grammar.Entry.e = - grammar_entry_create "as_lident" - and polyt : 'polyt Grammar.Entry.e = grammar_entry_create "polyt" - and cvalue_binding : 'cvalue_binding Grammar.Entry.e = - grammar_entry_create "cvalue_binding" - and label : 'label Grammar.Entry.e = grammar_entry_create "label" - and class_self_type : 'class_self_type Grammar.Entry.e = - grammar_entry_create "class_self_type" - and class_description : 'class_description Grammar.Entry.e = - grammar_entry_create "class_description" - and class_type_declaration : 'class_type_declaration Grammar.Entry.e = - grammar_entry_create "class_type_declaration" - and field_expr : 'field_expr Grammar.Entry.e = - grammar_entry_create "field_expr" - and field : 'field Grammar.Entry.e = grammar_entry_create "field" - and typevar : 'typevar Grammar.Entry.e = grammar_entry_create "typevar" - and clty_longident : 'clty_longident Grammar.Entry.e = - grammar_entry_create "clty_longident" - and class_longident : 'class_longident Grammar.Entry.e = - grammar_entry_create "class_longident" - and row_field_list : 'row_field_list Grammar.Entry.e = - grammar_entry_create "row_field_list" - and name_tag : 'name_tag Grammar.Entry.e = grammar_entry_create "name_tag" - and patt_tcon : 'patt_tcon Grammar.Entry.e = - grammar_entry_create "patt_tcon" - and ipatt_tcon : 'ipatt_tcon Grammar.Entry.e = - grammar_entry_create "ipatt_tcon" - and eq_expr : 'eq_expr Grammar.Entry.e = grammar_entry_create "eq_expr" - and direction_flag : 'direction_flag Grammar.Entry.e = - grammar_entry_create "direction_flag" - and warning_variant : 'warning_variant Grammar.Entry.e = - grammar_entry_create "warning_variant" - and warning_sequence : 'warning_sequence Grammar.Entry.e = - grammar_entry_create "warning_sequence" - in - [Grammar.Entry.obj (module_expr : 'module_expr Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "struct"); - Gramext.Slist0 - (Gramext.srules - [[Gramext.Snterm - (Grammar.Entry.obj (str_item : 'str_item Grammar.Entry.e)); - Gramext.Stoken ("", ";")], - Gramext.action - (fun _ (s : 'str_item) (loc : int * int) -> (s : 'e__1))]); - Gramext.Stoken ("", "end")], - Gramext.action - (fun _ (st : 'e__1 list) _ (loc : int * int) -> - (MLast.MeStr (loc, st) : 'module_expr)); - [Gramext.Stoken ("", "functor"); Gramext.Stoken ("", "("); - Gramext.Stoken ("UIDENT", ""); Gramext.Stoken ("", ":"); - Gramext.Snterm - (Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e)); - Gramext.Stoken ("", ")"); Gramext.Stoken ("", "->"); Gramext.Sself], - Gramext.action - (fun (me : 'module_expr) _ _ (t : 'module_type) _ (i : string) _ _ - (loc : int * int) -> - (MLast.MeFun (loc, i, t, me) : 'module_expr))]; - None, None, - [[Gramext.Sself; Gramext.Sself], - Gramext.action - (fun (me2 : 'module_expr) (me1 : 'module_expr) (loc : int * int) -> - (MLast.MeApp (loc, me1, me2) : 'module_expr))]; - None, None, - [[Gramext.Sself; Gramext.Stoken ("", "."); Gramext.Sself], - Gramext.action - (fun (me2 : 'module_expr) _ (me1 : 'module_expr) (loc : int * int) -> - (MLast.MeAcc (loc, me1, me2) : 'module_expr))]; - Some "simple", None, - [[Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (me : 'module_expr) _ (loc : int * int) -> - (me : 'module_expr)); - [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ":"); - Gramext.Snterm - (Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e)); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (mt : 'module_type) _ (me : 'module_expr) _ - (loc : int * int) -> - (MLast.MeTyc (loc, me, mt) : 'module_expr)); - [Gramext.Stoken ("UIDENT", "")], - Gramext.action - (fun (i : string) (loc : int * int) -> - (MLast.MeUid (loc, i) : 'module_expr))]]; - Grammar.Entry.obj (str_item : 'str_item Grammar.Entry.e), None, - [Some "top", None, - [[Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) (loc : int * int) -> - (MLast.StExp (loc, e) : 'str_item)); - [Gramext.Stoken ("", "value"); - Gramext.Sopt (Gramext.Stoken ("", "rec")); - Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj (let_binding : 'let_binding Grammar.Entry.e)), - Gramext.Stoken ("", "and"))], - Gramext.action - (fun (l : 'let_binding list) (r : string option) _ - (loc : int * int) -> - (MLast.StVal (loc, o2b r, l) : 'str_item)); - [Gramext.Stoken ("", "type"); - Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj - (type_declaration : 'type_declaration Grammar.Entry.e)), - Gramext.Stoken ("", "and"))], - Gramext.action - (fun (tdl : 'type_declaration list) _ (loc : int * int) -> - (MLast.StTyp (loc, tdl) : 'str_item)); - [Gramext.Stoken ("", "open"); - Gramext.Snterm - (Grammar.Entry.obj (mod_ident : 'mod_ident Grammar.Entry.e))], - Gramext.action - (fun (i : 'mod_ident) _ (loc : int * int) -> - (MLast.StOpn (loc, i) : 'str_item)); - [Gramext.Stoken ("", "module"); Gramext.Stoken ("", "type"); - Gramext.Stoken ("UIDENT", ""); Gramext.Stoken ("", "="); - Gramext.Snterm - (Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e))], - Gramext.action - (fun (mt : 'module_type) _ (i : string) _ _ (loc : int * int) -> - (MLast.StMty (loc, i, mt) : 'str_item)); - [Gramext.Stoken ("", "module"); Gramext.Stoken ("", "rec"); - Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj - (module_rec_binding : 'module_rec_binding Grammar.Entry.e)), - Gramext.Stoken ("", "and"))], - Gramext.action - (fun (nmtmes : 'module_rec_binding list) _ _ (loc : int * int) -> - (MLast.StRecMod (loc, nmtmes) : 'str_item)); - [Gramext.Stoken ("", "module"); Gramext.Stoken ("UIDENT", ""); - Gramext.Snterm - (Grammar.Entry.obj - (module_binding : 'module_binding Grammar.Entry.e))], - Gramext.action - (fun (mb : 'module_binding) (i : string) _ (loc : int * int) -> - (MLast.StMod (loc, i, mb) : 'str_item)); - [Gramext.Stoken ("", "include"); - Gramext.Snterm - (Grammar.Entry.obj (module_expr : 'module_expr Grammar.Entry.e))], - Gramext.action - (fun (me : 'module_expr) _ (loc : int * int) -> - (MLast.StInc (loc, me) : 'str_item)); - [Gramext.Stoken ("", "external"); Gramext.Stoken ("LIDENT", ""); - Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Slist1 (Gramext.Stoken ("STRING", ""))], - Gramext.action - (fun (pd : string list) _ (t : 'ctyp) _ (i : string) _ - (loc : int * int) -> - (MLast.StExt (loc, i, t, pd) : 'str_item)); - [Gramext.Stoken ("", "exception"); - Gramext.Snterm - (Grammar.Entry.obj - (constructor_declaration : - 'constructor_declaration Grammar.Entry.e)); - Gramext.Snterm - (Grammar.Entry.obj (rebind_exn : 'rebind_exn Grammar.Entry.e))], - Gramext.action - (fun (b : 'rebind_exn) (_, c, tl : 'constructor_declaration) _ - (loc : int * int) -> - (MLast.StExc (loc, c, tl, b) : 'str_item)); - [Gramext.Stoken ("", "declare"); - Gramext.Slist0 - (Gramext.srules - [[Gramext.Snterm - (Grammar.Entry.obj (str_item : 'str_item Grammar.Entry.e)); - Gramext.Stoken ("", ";")], - Gramext.action - (fun _ (s : 'str_item) (loc : int * int) -> (s : 'e__2))]); - Gramext.Stoken ("", "end")], - Gramext.action - (fun _ (st : 'e__2 list) _ (loc : int * int) -> - (MLast.StDcl (loc, st) : 'str_item))]]; - Grammar.Entry.obj (rebind_exn : 'rebind_exn Grammar.Entry.e), None, - [None, None, - [[], Gramext.action (fun (loc : int * int) -> ([] : 'rebind_exn)); - [Gramext.Stoken ("", "="); - Gramext.Snterm - (Grammar.Entry.obj (mod_ident : 'mod_ident Grammar.Entry.e))], - Gramext.action - (fun (sl : 'mod_ident) _ (loc : int * int) -> (sl : 'rebind_exn))]]; - Grammar.Entry.obj (module_binding : 'module_binding Grammar.Entry.e), - None, - [None, Some Gramext.RightA, - [[Gramext.Stoken ("", "="); - Gramext.Snterm - (Grammar.Entry.obj (module_expr : 'module_expr Grammar.Entry.e))], - Gramext.action - (fun (me : 'module_expr) _ (loc : int * int) -> - (me : 'module_binding)); - [Gramext.Stoken ("", ":"); - Gramext.Snterm - (Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm - (Grammar.Entry.obj (module_expr : 'module_expr Grammar.Entry.e))], - Gramext.action - (fun (me : 'module_expr) _ (mt : 'module_type) _ (loc : int * int) -> - (MLast.MeTyc (loc, me, mt) : 'module_binding)); - [Gramext.Stoken ("", "("); Gramext.Stoken ("UIDENT", ""); - Gramext.Stoken ("", ":"); - Gramext.Snterm - (Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e)); - Gramext.Stoken ("", ")"); Gramext.Sself], - Gramext.action - (fun (mb : 'module_binding) _ (mt : 'module_type) _ (m : string) _ - (loc : int * int) -> - (MLast.MeFun (loc, m, mt, mb) : 'module_binding))]]; - Grammar.Entry.obj - (module_rec_binding : 'module_rec_binding Grammar.Entry.e), - None, - [None, None, - [[Gramext.Stoken ("UIDENT", ""); Gramext.Stoken ("", ":"); - Gramext.Snterm - (Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm - (Grammar.Entry.obj (module_expr : 'module_expr Grammar.Entry.e))], - Gramext.action - (fun (me : 'module_expr) _ (mt : 'module_type) _ (m : string) - (loc : int * int) -> - (m, mt, me : 'module_rec_binding))]]; - Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "functor"); Gramext.Stoken ("", "("); - Gramext.Stoken ("UIDENT", ""); Gramext.Stoken ("", ":"); Gramext.Sself; - Gramext.Stoken ("", ")"); Gramext.Stoken ("", "->"); Gramext.Sself], - Gramext.action - (fun (mt : 'module_type) _ _ (t : 'module_type) _ (i : string) _ _ - (loc : int * int) -> - (MLast.MtFun (loc, i, t, mt) : 'module_type))]; - None, None, - [[Gramext.Sself; Gramext.Stoken ("", "with"); - Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj (with_constr : 'with_constr Grammar.Entry.e)), - Gramext.Stoken ("", "and"))], - Gramext.action - (fun (wcl : 'with_constr list) _ (mt : 'module_type) - (loc : int * int) -> - (MLast.MtWit (loc, mt, wcl) : 'module_type))]; - None, None, - [[Gramext.Stoken ("", "sig"); - Gramext.Slist0 - (Gramext.srules - [[Gramext.Snterm - (Grammar.Entry.obj (sig_item : 'sig_item Grammar.Entry.e)); - Gramext.Stoken ("", ";")], - Gramext.action - (fun _ (s : 'sig_item) (loc : int * int) -> (s : 'e__3))]); - Gramext.Stoken ("", "end")], - Gramext.action - (fun _ (sg : 'e__3 list) _ (loc : int * int) -> - (MLast.MtSig (loc, sg) : 'module_type))]; - None, None, - [[Gramext.Sself; Gramext.Sself], - Gramext.action - (fun (m2 : 'module_type) (m1 : 'module_type) (loc : int * int) -> - (MLast.MtApp (loc, m1, m2) : 'module_type))]; - None, None, - [[Gramext.Sself; Gramext.Stoken ("", "."); Gramext.Sself], - Gramext.action - (fun (m2 : 'module_type) _ (m1 : 'module_type) (loc : int * int) -> - (MLast.MtAcc (loc, m1, m2) : 'module_type))]; - Some "simple", None, - [[Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (mt : 'module_type) _ (loc : int * int) -> - (mt : 'module_type)); - [Gramext.Stoken ("", "'"); - Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e))], - Gramext.action - (fun (i : 'ident) _ (loc : int * int) -> - (MLast.MtQuo (loc, i) : 'module_type)); - [Gramext.Stoken ("LIDENT", "")], - Gramext.action - (fun (i : string) (loc : int * int) -> - (MLast.MtLid (loc, i) : 'module_type)); - [Gramext.Stoken ("UIDENT", "")], - Gramext.action - (fun (i : string) (loc : int * int) -> - (MLast.MtUid (loc, i) : 'module_type))]]; - Grammar.Entry.obj (sig_item : 'sig_item Grammar.Entry.e), None, - [Some "top", None, - [[Gramext.Stoken ("", "value"); Gramext.Stoken ("LIDENT", ""); - Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], - Gramext.action - (fun (t : 'ctyp) _ (i : string) _ (loc : int * int) -> - (MLast.SgVal (loc, i, t) : 'sig_item)); - [Gramext.Stoken ("", "type"); - Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj - (type_declaration : 'type_declaration Grammar.Entry.e)), - Gramext.Stoken ("", "and"))], - Gramext.action - (fun (tdl : 'type_declaration list) _ (loc : int * int) -> - (MLast.SgTyp (loc, tdl) : 'sig_item)); - [Gramext.Stoken ("", "open"); - Gramext.Snterm - (Grammar.Entry.obj (mod_ident : 'mod_ident Grammar.Entry.e))], - Gramext.action - (fun (i : 'mod_ident) _ (loc : int * int) -> - (MLast.SgOpn (loc, i) : 'sig_item)); - [Gramext.Stoken ("", "module"); Gramext.Stoken ("", "type"); - Gramext.Stoken ("UIDENT", ""); Gramext.Stoken ("", "="); - Gramext.Snterm - (Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e))], - Gramext.action - (fun (mt : 'module_type) _ (i : string) _ _ (loc : int * int) -> - (MLast.SgMty (loc, i, mt) : 'sig_item)); - [Gramext.Stoken ("", "module"); Gramext.Stoken ("", "rec"); - Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj - (module_rec_declaration : - 'module_rec_declaration Grammar.Entry.e)), - Gramext.Stoken ("", "and"))], - Gramext.action - (fun (mds : 'module_rec_declaration list) _ _ (loc : int * int) -> - (MLast.SgRecMod (loc, mds) : 'sig_item)); - [Gramext.Stoken ("", "module"); Gramext.Stoken ("UIDENT", ""); - Gramext.Snterm - (Grammar.Entry.obj - (module_declaration : 'module_declaration Grammar.Entry.e))], - Gramext.action - (fun (mt : 'module_declaration) (i : string) _ (loc : int * int) -> - (MLast.SgMod (loc, i, mt) : 'sig_item)); - [Gramext.Stoken ("", "include"); - Gramext.Snterm - (Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e))], - Gramext.action - (fun (mt : 'module_type) _ (loc : int * int) -> - (MLast.SgInc (loc, mt) : 'sig_item)); - [Gramext.Stoken ("", "external"); Gramext.Stoken ("LIDENT", ""); - Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Slist1 (Gramext.Stoken ("STRING", ""))], - Gramext.action - (fun (pd : string list) _ (t : 'ctyp) _ (i : string) _ - (loc : int * int) -> - (MLast.SgExt (loc, i, t, pd) : 'sig_item)); - [Gramext.Stoken ("", "exception"); - Gramext.Snterm - (Grammar.Entry.obj - (constructor_declaration : - 'constructor_declaration Grammar.Entry.e))], - Gramext.action - (fun (_, c, tl : 'constructor_declaration) _ (loc : int * int) -> - (MLast.SgExc (loc, c, tl) : 'sig_item)); - [Gramext.Stoken ("", "declare"); - Gramext.Slist0 - (Gramext.srules - [[Gramext.Snterm - (Grammar.Entry.obj (sig_item : 'sig_item Grammar.Entry.e)); - Gramext.Stoken ("", ";")], - Gramext.action - (fun _ (s : 'sig_item) (loc : int * int) -> (s : 'e__4))]); - Gramext.Stoken ("", "end")], - Gramext.action - (fun _ (st : 'e__4 list) _ (loc : int * int) -> - (MLast.SgDcl (loc, st) : 'sig_item))]]; - Grammar.Entry.obj - (module_declaration : 'module_declaration Grammar.Entry.e), - None, - [None, Some Gramext.RightA, - [[Gramext.Stoken ("", "("); Gramext.Stoken ("UIDENT", ""); - Gramext.Stoken ("", ":"); - Gramext.Snterm - (Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e)); - Gramext.Stoken ("", ")"); Gramext.Sself], - Gramext.action - (fun (mt : 'module_declaration) _ (t : 'module_type) _ (i : string) _ - (loc : int * int) -> - (MLast.MtFun (loc, i, t, mt) : 'module_declaration)); - [Gramext.Stoken ("", ":"); - Gramext.Snterm - (Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e))], - Gramext.action - (fun (mt : 'module_type) _ (loc : int * int) -> - (mt : 'module_declaration))]]; - Grammar.Entry.obj - (module_rec_declaration : 'module_rec_declaration Grammar.Entry.e), - None, - [None, None, - [[Gramext.Stoken ("UIDENT", ""); Gramext.Stoken ("", ":"); - Gramext.Snterm - (Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e))], - Gramext.action - (fun (mt : 'module_type) _ (m : string) (loc : int * int) -> - (m, mt : 'module_rec_declaration))]]; - Grammar.Entry.obj (with_constr : 'with_constr Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "module"); - Gramext.Snterm - (Grammar.Entry.obj (mod_ident : 'mod_ident Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm - (Grammar.Entry.obj (module_expr : 'module_expr Grammar.Entry.e))], - Gramext.action - (fun (me : 'module_expr) _ (i : 'mod_ident) _ (loc : int * int) -> - (MLast.WcMod (loc, i, me) : 'with_constr)); - [Gramext.Stoken ("", "type"); - Gramext.Snterm - (Grammar.Entry.obj (mod_ident : 'mod_ident Grammar.Entry.e)); - Gramext.Slist0 - (Gramext.Snterm - (Grammar.Entry.obj - (type_parameter : 'type_parameter Grammar.Entry.e))); - Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], - Gramext.action - (fun (t : 'ctyp) _ (tpl : 'type_parameter list) (i : 'mod_ident) _ - (loc : int * int) -> - (MLast.WcTyp (loc, i, tpl, t) : 'with_constr))]]; - Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), None, - [Some "top", Some Gramext.RightA, - [[Gramext.Stoken ("", "while"); Gramext.Sself; Gramext.Stoken ("", "do"); - Gramext.Stoken ("", "{"); - Gramext.Snterm - (Grammar.Entry.obj (sequence : 'sequence Grammar.Entry.e)); - Gramext.Stoken ("", "}")], - Gramext.action - (fun _ (seq : 'sequence) _ _ (e : 'expr) _ (loc : int * int) -> - (MLast.ExWhi (loc, e, seq) : 'expr)); - [Gramext.Stoken ("", "for"); Gramext.Stoken ("LIDENT", ""); - Gramext.Stoken ("", "="); Gramext.Sself; - Gramext.Snterm - (Grammar.Entry.obj - (direction_flag : 'direction_flag Grammar.Entry.e)); - Gramext.Sself; Gramext.Stoken ("", "do"); Gramext.Stoken ("", "{"); - Gramext.Snterm - (Grammar.Entry.obj (sequence : 'sequence Grammar.Entry.e)); - Gramext.Stoken ("", "}")], - Gramext.action - (fun _ (seq : 'sequence) _ _ (e2 : 'expr) (df : 'direction_flag) - (e1 : 'expr) _ (i : string) _ (loc : int * int) -> - (MLast.ExFor (loc, i, e1, e2, df, seq) : 'expr)); - [Gramext.Stoken ("", "do"); Gramext.Stoken ("", "{"); - Gramext.Snterm - (Grammar.Entry.obj (sequence : 'sequence Grammar.Entry.e)); - Gramext.Stoken ("", "}")], - Gramext.action - (fun _ (seq : 'sequence) _ _ (loc : int * int) -> - (mksequence loc seq : 'expr)); - [Gramext.Stoken ("", "if"); Gramext.Sself; Gramext.Stoken ("", "then"); - Gramext.Sself; Gramext.Stoken ("", "else"); Gramext.Sself], - Gramext.action - (fun (e3 : 'expr) _ (e2 : 'expr) _ (e1 : 'expr) _ (loc : int * int) -> - (MLast.ExIfe (loc, e1, e2, e3) : 'expr)); - [Gramext.Stoken ("", "try"); Gramext.Sself; Gramext.Stoken ("", "with"); - Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e)); - Gramext.Stoken ("", "->"); Gramext.Sself], - Gramext.action - (fun (e1 : 'expr) _ (p1 : 'ipatt) _ (e : 'expr) _ (loc : int * int) -> - (MLast.ExTry (loc, e, [p1, None, e1]) : 'expr)); - [Gramext.Stoken ("", "try"); Gramext.Sself; Gramext.Stoken ("", "with"); - Gramext.Stoken ("", "["); - Gramext.Slist0sep - (Gramext.Snterm - (Grammar.Entry.obj (match_case : 'match_case Grammar.Entry.e)), - Gramext.Stoken ("", "|")); - Gramext.Stoken ("", "]")], - Gramext.action - (fun _ (l : 'match_case list) _ _ (e : 'expr) _ (loc : int * int) -> - (MLast.ExTry (loc, e, l) : 'expr)); - [Gramext.Stoken ("", "match"); Gramext.Sself; - Gramext.Stoken ("", "with"); - Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e)); - Gramext.Stoken ("", "->"); Gramext.Sself], - Gramext.action - (fun (e1 : 'expr) _ (p1 : 'ipatt) _ (e : 'expr) _ (loc : int * int) -> - (MLast.ExMat (loc, e, [p1, None, e1]) : 'expr)); - [Gramext.Stoken ("", "match"); Gramext.Sself; - Gramext.Stoken ("", "with"); Gramext.Stoken ("", "["); - Gramext.Slist0sep - (Gramext.Snterm - (Grammar.Entry.obj (match_case : 'match_case Grammar.Entry.e)), - Gramext.Stoken ("", "|")); - Gramext.Stoken ("", "]")], - Gramext.action - (fun _ (l : 'match_case list) _ _ (e : 'expr) _ (loc : int * int) -> - (MLast.ExMat (loc, e, l) : 'expr)); - [Gramext.Stoken ("", "fun"); - Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e)); - Gramext.Snterm - (Grammar.Entry.obj (fun_def : 'fun_def Grammar.Entry.e))], - Gramext.action - (fun (e : 'fun_def) (p : 'ipatt) _ (loc : int * int) -> - (MLast.ExFun (loc, [p, None, e]) : 'expr)); - [Gramext.Stoken ("", "fun"); Gramext.Stoken ("", "["); - Gramext.Slist0sep - (Gramext.Snterm - (Grammar.Entry.obj (match_case : 'match_case Grammar.Entry.e)), - Gramext.Stoken ("", "|")); - Gramext.Stoken ("", "]")], - Gramext.action - (fun _ (l : 'match_case list) _ _ (loc : int * int) -> - (MLast.ExFun (loc, l) : 'expr)); - [Gramext.Stoken ("", "let"); Gramext.Stoken ("", "module"); - Gramext.Stoken ("UIDENT", ""); - Gramext.Snterm - (Grammar.Entry.obj - (module_binding : 'module_binding Grammar.Entry.e)); - Gramext.Stoken ("", "in"); Gramext.Sself], - Gramext.action - (fun (e : 'expr) _ (mb : 'module_binding) (m : string) _ _ - (loc : int * int) -> - (MLast.ExLmd (loc, m, mb, e) : 'expr)); - [Gramext.Stoken ("", "let"); Gramext.Sopt (Gramext.Stoken ("", "rec")); - Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj (let_binding : 'let_binding Grammar.Entry.e)), - Gramext.Stoken ("", "and")); - Gramext.Stoken ("", "in"); Gramext.Sself], - Gramext.action - (fun (x : 'expr) _ (l : 'let_binding list) (r : string option) _ - (loc : int * int) -> - (MLast.ExLet (loc, o2b r, l, x) : 'expr))]; - Some "where", None, - [[Gramext.Sself; Gramext.Stoken ("", "where"); - Gramext.Sopt (Gramext.Stoken ("", "rec")); - Gramext.Snterm - (Grammar.Entry.obj (let_binding : 'let_binding Grammar.Entry.e))], - Gramext.action - (fun (lb : 'let_binding) (rf : string option) _ (e : 'expr) - (loc : int * int) -> - (MLast.ExLet (loc, o2b rf, [lb], e) : 'expr))]; - Some ":=", Some Gramext.NonA, - [[Gramext.Sself; Gramext.Stoken ("", ":="); Gramext.Sself; - Gramext.Snterm (Grammar.Entry.obj (dummy : 'dummy Grammar.Entry.e))], - Gramext.action - (fun _ (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (MLast.ExAss (loc, e1, e2) : 'expr))]; - Some "||", Some Gramext.RightA, - [[Gramext.Sself; Gramext.Stoken ("", "||"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (MLast.ExApp - (loc, MLast.ExApp (loc, MLast.ExLid (loc, "||"), e1), e2) : - 'expr))]; - Some "&&", Some Gramext.RightA, - [[Gramext.Sself; Gramext.Stoken ("", "&&"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (MLast.ExApp - (loc, MLast.ExApp (loc, MLast.ExLid (loc, "&&"), e1), e2) : - 'expr))]; - Some "<", Some Gramext.LeftA, - [[Gramext.Sself; Gramext.Stoken ("", "!="); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (MLast.ExApp - (loc, MLast.ExApp (loc, MLast.ExLid (loc, "!="), e1), e2) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "=="); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (MLast.ExApp - (loc, MLast.ExApp (loc, MLast.ExLid (loc, "=="), e1), e2) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "<>"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (MLast.ExApp - (loc, MLast.ExApp (loc, MLast.ExLid (loc, "<>"), e1), e2) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "="); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (MLast.ExApp - (loc, MLast.ExApp (loc, MLast.ExLid (loc, "="), e1), e2) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", ">="); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (MLast.ExApp - (loc, MLast.ExApp (loc, MLast.ExLid (loc, ">="), e1), e2) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "<="); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (MLast.ExApp - (loc, MLast.ExApp (loc, MLast.ExLid (loc, "<="), e1), e2) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", ">"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (MLast.ExApp - (loc, MLast.ExApp (loc, MLast.ExLid (loc, ">"), e1), e2) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "<"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (MLast.ExApp - (loc, MLast.ExApp (loc, MLast.ExLid (loc, "<"), e1), e2) : - 'expr))]; - Some "^", Some Gramext.RightA, - [[Gramext.Sself; Gramext.Stoken ("", "@"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (MLast.ExApp - (loc, MLast.ExApp (loc, MLast.ExLid (loc, "@"), e1), e2) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "^"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (MLast.ExApp - (loc, MLast.ExApp (loc, MLast.ExLid (loc, "^"), e1), e2) : - 'expr))]; - Some "+", Some Gramext.LeftA, - [[Gramext.Sself; Gramext.Stoken ("", "-."); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (MLast.ExApp - (loc, MLast.ExApp (loc, MLast.ExLid (loc, "-."), e1), e2) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "+."); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (MLast.ExApp - (loc, MLast.ExApp (loc, MLast.ExLid (loc, "+."), e1), e2) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "-"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (MLast.ExApp - (loc, MLast.ExApp (loc, MLast.ExLid (loc, "-"), e1), e2) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "+"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (MLast.ExApp - (loc, MLast.ExApp (loc, MLast.ExLid (loc, "+"), e1), e2) : - 'expr))]; - Some "*", Some Gramext.LeftA, - [[Gramext.Sself; Gramext.Stoken ("", "mod"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (MLast.ExApp - (loc, MLast.ExApp (loc, MLast.ExLid (loc, "mod"), e1), e2) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "lxor"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (MLast.ExApp - (loc, MLast.ExApp (loc, MLast.ExLid (loc, "lxor"), e1), e2) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "lor"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (MLast.ExApp - (loc, MLast.ExApp (loc, MLast.ExLid (loc, "lor"), e1), e2) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "land"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (MLast.ExApp - (loc, MLast.ExApp (loc, MLast.ExLid (loc, "land"), e1), e2) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "/."); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (MLast.ExApp - (loc, MLast.ExApp (loc, MLast.ExLid (loc, "/."), e1), e2) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "*."); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (MLast.ExApp - (loc, MLast.ExApp (loc, MLast.ExLid (loc, "*."), e1), e2) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "/"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (MLast.ExApp - (loc, MLast.ExApp (loc, MLast.ExLid (loc, "/"), e1), e2) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "*"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (MLast.ExApp - (loc, MLast.ExApp (loc, MLast.ExLid (loc, "*"), e1), e2) : - 'expr))]; - Some "**", Some Gramext.RightA, - [[Gramext.Sself; Gramext.Stoken ("", "lsr"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (MLast.ExApp - (loc, MLast.ExApp (loc, MLast.ExLid (loc, "lsr"), e1), e2) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "lsl"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (MLast.ExApp - (loc, MLast.ExApp (loc, MLast.ExLid (loc, "lsl"), e1), e2) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "asr"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (MLast.ExApp - (loc, MLast.ExApp (loc, MLast.ExLid (loc, "asr"), e1), e2) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "**"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (MLast.ExApp - (loc, MLast.ExApp (loc, MLast.ExLid (loc, "**"), e1), e2) : - 'expr))]; - Some "unary minus", Some Gramext.NonA, - [[Gramext.Stoken ("", "-."); Gramext.Sself], - Gramext.action - (fun (e : 'expr) _ (loc : int * int) -> (mkumin loc "-." e : 'expr)); - [Gramext.Stoken ("", "-"); Gramext.Sself], - Gramext.action - (fun (e : 'expr) _ (loc : int * int) -> (mkumin loc "-" e : 'expr))]; - Some "apply", Some Gramext.LeftA, - [[Gramext.Stoken ("", "lazy"); Gramext.Sself], - Gramext.action - (fun (e : 'expr) _ (loc : int * int) -> - (MLast.ExLaz (loc, e) : 'expr)); - [Gramext.Stoken ("", "assert"); Gramext.Sself], - Gramext.action - (fun (e : 'expr) _ (loc : int * int) -> (mkassert loc e : 'expr)); - [Gramext.Sself; Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) (e1 : 'expr) (loc : int * int) -> - (MLast.ExApp (loc, e1, e2) : 'expr))]; - Some ".", Some Gramext.LeftA, - [[Gramext.Sself; Gramext.Stoken ("", "."); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (MLast.ExAcc (loc, e1, e2) : 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "."); Gramext.Stoken ("", "["); - Gramext.Sself; Gramext.Stoken ("", "]")], - Gramext.action - (fun _ (e2 : 'expr) _ _ (e1 : 'expr) (loc : int * int) -> - (MLast.ExSte (loc, e1, e2) : 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "."); Gramext.Stoken ("", "("); - Gramext.Sself; Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (e2 : 'expr) _ _ (e1 : 'expr) (loc : int * int) -> - (MLast.ExAre (loc, e1, e2) : 'expr))]; - Some "~-", Some Gramext.NonA, - [[Gramext.Stoken ("", "~-."); Gramext.Sself], - Gramext.action - (fun (e : 'expr) _ (loc : int * int) -> - (MLast.ExApp (loc, MLast.ExLid (loc, "~-."), e) : 'expr)); - [Gramext.Stoken ("", "~-"); Gramext.Sself], - Gramext.action - (fun (e : 'expr) _ (loc : int * int) -> - (MLast.ExApp (loc, MLast.ExLid (loc, "~-"), e) : 'expr))]; - Some "simple", None, - [[Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ")")], - Gramext.action (fun _ (e : 'expr) _ (loc : int * int) -> (e : 'expr)); - [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ","); - Gramext.Slist1sep - (Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e)), - Gramext.Stoken ("", ",")); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (el : 'expr list) _ (e : 'expr) _ (loc : int * int) -> - (MLast.ExTup (loc, (e :: el)) : 'expr)); - [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (t : 'ctyp) _ (e : 'expr) _ (loc : int * int) -> - (MLast.ExTyc (loc, e, t) : 'expr)); - [Gramext.Stoken ("", "("); Gramext.Stoken ("", ")")], - Gramext.action - (fun _ _ (loc : int * int) -> (MLast.ExUid (loc, "()") : 'expr)); - [Gramext.Stoken ("", "{"); Gramext.Stoken ("", "("); Gramext.Sself; - Gramext.Stoken ("", ")"); Gramext.Stoken ("", "with"); - Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj (label_expr : 'label_expr Grammar.Entry.e)), - Gramext.Stoken ("", ";")); - Gramext.Stoken ("", "}")], - Gramext.action - (fun _ (lel : 'label_expr list) _ _ (e : 'expr) _ _ - (loc : int * int) -> - (MLast.ExRec (loc, lel, Some e) : 'expr)); - [Gramext.Stoken ("", "{"); - Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj (label_expr : 'label_expr Grammar.Entry.e)), - Gramext.Stoken ("", ";")); - Gramext.Stoken ("", "}")], - Gramext.action - (fun _ (lel : 'label_expr list) _ (loc : int * int) -> - (MLast.ExRec (loc, lel, None) : 'expr)); - [Gramext.Stoken ("", "[|"); - Gramext.Slist0sep - (Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e)), - Gramext.Stoken ("", ";")); - Gramext.Stoken ("", "|]")], - Gramext.action - (fun _ (el : 'expr list) _ (loc : int * int) -> - (MLast.ExArr (loc, el) : 'expr)); - [Gramext.Stoken ("", "["); - Gramext.Slist1sep - (Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e)), - Gramext.Stoken ("", ";")); - Gramext.Snterm - (Grammar.Entry.obj (cons_expr_opt : 'cons_expr_opt Grammar.Entry.e)); - Gramext.Stoken ("", "]")], - Gramext.action - (fun _ (last : 'cons_expr_opt) (el : 'expr list) _ - (loc : int * int) -> - (mklistexp loc last el : 'expr)); - [Gramext.Stoken ("", "["); Gramext.Stoken ("", "]")], - Gramext.action - (fun _ _ (loc : int * int) -> (MLast.ExUid (loc, "[]") : 'expr)); - [Gramext.Snterm - (Grammar.Entry.obj (expr_ident : 'expr_ident Grammar.Entry.e))], - Gramext.action (fun (i : 'expr_ident) (loc : int * int) -> (i : 'expr)); - [Gramext.Stoken ("CHAR", "")], - Gramext.action - (fun (s : string) (loc : int * int) -> - (MLast.ExChr (loc, s) : 'expr)); - [Gramext.Stoken ("STRING", "")], - Gramext.action - (fun (s : string) (loc : int * int) -> - (MLast.ExStr (loc, s) : 'expr)); - [Gramext.Stoken ("FLOAT", "")], - Gramext.action - (fun (s : string) (loc : int * int) -> - (MLast.ExFlo (loc, s) : 'expr)); - [Gramext.Stoken ("NATIVEINT", "")], - Gramext.action - (fun (s : string) (loc : int * int) -> - (MLast.ExNativeInt (loc, s) : 'expr)); - [Gramext.Stoken ("INT64", "")], - Gramext.action - (fun (s : string) (loc : int * int) -> - (MLast.ExInt64 (loc, s) : 'expr)); - [Gramext.Stoken ("INT32", "")], - Gramext.action - (fun (s : string) (loc : int * int) -> - (MLast.ExInt32 (loc, s) : 'expr)); - [Gramext.Stoken ("INT", "")], - Gramext.action - (fun (s : string) (loc : int * int) -> - (MLast.ExInt (loc, s) : 'expr))]]; - Grammar.Entry.obj (cons_expr_opt : 'cons_expr_opt Grammar.Entry.e), None, - [None, None, - [[], Gramext.action (fun (loc : int * int) -> (None : 'cons_expr_opt)); - [Gramext.Stoken ("", "::"); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) _ (loc : int * int) -> (Some e : 'cons_expr_opt))]]; - Grammar.Entry.obj (dummy : 'dummy Grammar.Entry.e), None, - [None, None, - [[], Gramext.action (fun (loc : int * int) -> (() : 'dummy))]]; - Grammar.Entry.obj (sequence : 'sequence Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action (fun (e : 'expr) (loc : int * int) -> ([e] : 'sequence)); - [Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e)); - Gramext.Stoken ("", ";")], - Gramext.action - (fun _ (e : 'expr) (loc : int * int) -> ([e] : 'sequence)); - [Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e)); - Gramext.Stoken ("", ";"); Gramext.Sself], - Gramext.action - (fun (el : 'sequence) _ (e : 'expr) (loc : int * int) -> - (e :: el : 'sequence)); - [Gramext.Stoken ("", "let"); Gramext.Sopt (Gramext.Stoken ("", "rec")); - Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj (let_binding : 'let_binding Grammar.Entry.e)), - Gramext.Stoken ("", "and")); - Gramext.srules - [[Gramext.Stoken ("", ";")], - Gramext.action (fun (x : string) (loc : int * int) -> (x : 'e__5)); - [Gramext.Stoken ("", "in")], - Gramext.action (fun (x : string) (loc : int * int) -> (x : 'e__5))]; - Gramext.Sself], - Gramext.action - (fun (el : 'sequence) _ (l : 'let_binding list) (rf : string option) _ - (loc : int * int) -> - ([MLast.ExLet (loc, o2b rf, l, mksequence loc el)] : 'sequence))]]; - Grammar.Entry.obj (let_binding : 'let_binding Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e)); - Gramext.Snterm - (Grammar.Entry.obj (fun_binding : 'fun_binding Grammar.Entry.e))], - Gramext.action - (fun (e : 'fun_binding) (p : 'ipatt) (loc : int * int) -> - (p, e : 'let_binding))]]; - Grammar.Entry.obj (fun_binding : 'fun_binding Grammar.Entry.e), None, - [None, Some Gramext.RightA, - [[Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) _ (t : 'ctyp) _ (loc : int * int) -> - (MLast.ExTyc (loc, e, t) : 'fun_binding)); - [Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) _ (loc : int * int) -> (e : 'fun_binding)); - [Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e)); - Gramext.Sself], - Gramext.action - (fun (e : 'fun_binding) (p : 'ipatt) (loc : int * int) -> - (MLast.ExFun (loc, [p, None, e]) : 'fun_binding))]]; - Grammar.Entry.obj (match_case : 'match_case Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e)); - Gramext.Snterm - (Grammar.Entry.obj (as_patt_opt : 'as_patt_opt Grammar.Entry.e)); - Gramext.Snterm - (Grammar.Entry.obj (when_expr_opt : 'when_expr_opt Grammar.Entry.e)); - Gramext.Stoken ("", "->"); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) _ (w : 'when_expr_opt) (aso : 'as_patt_opt) - (p : 'patt) (loc : int * int) -> - (mkmatchcase loc p aso w e : 'match_case))]]; - Grammar.Entry.obj (as_patt_opt : 'as_patt_opt Grammar.Entry.e), None, - [None, None, - [[], Gramext.action (fun (loc : int * int) -> (None : 'as_patt_opt)); - [Gramext.Stoken ("", "as"); - Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e))], - Gramext.action - (fun (p : 'patt) _ (loc : int * int) -> (Some p : 'as_patt_opt))]]; - Grammar.Entry.obj (when_expr_opt : 'when_expr_opt Grammar.Entry.e), None, - [None, None, - [[], Gramext.action (fun (loc : int * int) -> (None : 'when_expr_opt)); - [Gramext.Stoken ("", "when"); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) _ (loc : int * int) -> (Some e : 'when_expr_opt))]]; - Grammar.Entry.obj (label_expr : 'label_expr Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj - (patt_label_ident : 'patt_label_ident Grammar.Entry.e)); - Gramext.Snterm - (Grammar.Entry.obj (fun_binding : 'fun_binding Grammar.Entry.e))], - Gramext.action - (fun (e : 'fun_binding) (i : 'patt_label_ident) (loc : int * int) -> - (i, e : 'label_expr))]]; - Grammar.Entry.obj (expr_ident : 'expr_ident Grammar.Entry.e), None, - [None, Some Gramext.RightA, - [[Gramext.Stoken ("UIDENT", ""); Gramext.Stoken ("", "."); - Gramext.Sself], - Gramext.action - (fun (j : 'expr_ident) _ (i : string) (loc : int * int) -> - (mkexprident loc i j : 'expr_ident)); - [Gramext.Stoken ("UIDENT", "")], - Gramext.action - (fun (i : string) (loc : int * int) -> - (MLast.ExUid (loc, i) : 'expr_ident)); - [Gramext.Stoken ("LIDENT", "")], - Gramext.action - (fun (i : string) (loc : int * int) -> - (MLast.ExLid (loc, i) : 'expr_ident))]]; - Grammar.Entry.obj (fun_def : 'fun_def Grammar.Entry.e), None, - [None, Some Gramext.RightA, - [[Gramext.Stoken ("", "->"); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action (fun (e : 'expr) _ (loc : int * int) -> (e : 'fun_def)); - [Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e)); - Gramext.Sself], - Gramext.action - (fun (e : 'fun_def) (p : 'ipatt) (loc : int * int) -> - (MLast.ExFun (loc, [p, None, e]) : 'fun_def))]]; - Grammar.Entry.obj (patt : 'patt Grammar.Entry.e), None, - [None, Some Gramext.LeftA, - [[Gramext.Sself; Gramext.Stoken ("", "|"); Gramext.Sself], - Gramext.action - (fun (p2 : 'patt) _ (p1 : 'patt) (loc : int * int) -> - (MLast.PaOrp (loc, p1, p2) : 'patt))]; - None, Some Gramext.NonA, - [[Gramext.Sself; Gramext.Stoken ("", ".."); Gramext.Sself], - Gramext.action - (fun (p2 : 'patt) _ (p1 : 'patt) (loc : int * int) -> - (MLast.PaRng (loc, p1, p2) : 'patt))]; - None, Some Gramext.LeftA, - [[Gramext.Sself; Gramext.Sself], - Gramext.action - (fun (p2 : 'patt) (p1 : 'patt) (loc : int * int) -> - (MLast.PaApp (loc, p1, p2) : 'patt))]; - None, Some Gramext.LeftA, - [[Gramext.Sself; Gramext.Stoken ("", "."); Gramext.Sself], - Gramext.action - (fun (p2 : 'patt) _ (p1 : 'patt) (loc : int * int) -> - (MLast.PaAcc (loc, p1, p2) : 'patt))]; - Some "simple", None, - [[Gramext.Stoken ("", "_")], - Gramext.action (fun _ (loc : int * int) -> (MLast.PaAny loc : 'patt)); - [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ","); - Gramext.Slist1sep - (Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e)), - Gramext.Stoken ("", ",")); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (pl : 'patt list) _ (p : 'patt) _ (loc : int * int) -> - (MLast.PaTup (loc, (p :: pl)) : 'patt)); - [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", "as"); - Gramext.Sself; Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (p2 : 'patt) _ (p : 'patt) _ (loc : int * int) -> - (MLast.PaAli (loc, p, p2) : 'patt)); - [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (t : 'ctyp) _ (p : 'patt) _ (loc : int * int) -> - (MLast.PaTyc (loc, p, t) : 'patt)); - [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ")")], - Gramext.action (fun _ (p : 'patt) _ (loc : int * int) -> (p : 'patt)); - [Gramext.Stoken ("", "("); Gramext.Stoken ("", ")")], - Gramext.action - (fun _ _ (loc : int * int) -> (MLast.PaUid (loc, "()") : 'patt)); - [Gramext.Stoken ("", "{"); - Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj (label_patt : 'label_patt Grammar.Entry.e)), - Gramext.Stoken ("", ";")); - Gramext.Stoken ("", "}")], - Gramext.action - (fun _ (lpl : 'label_patt list) _ (loc : int * int) -> - (MLast.PaRec (loc, lpl) : 'patt)); - [Gramext.Stoken ("", "[|"); - Gramext.Slist0sep - (Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e)), - Gramext.Stoken ("", ";")); - Gramext.Stoken ("", "|]")], - Gramext.action - (fun _ (pl : 'patt list) _ (loc : int * int) -> - (MLast.PaArr (loc, pl) : 'patt)); - [Gramext.Stoken ("", "["); - Gramext.Slist1sep - (Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e)), - Gramext.Stoken ("", ";")); - Gramext.Snterm - (Grammar.Entry.obj (cons_patt_opt : 'cons_patt_opt Grammar.Entry.e)); - Gramext.Stoken ("", "]")], - Gramext.action - (fun _ (last : 'cons_patt_opt) (pl : 'patt list) _ - (loc : int * int) -> - (mklistpat loc last pl : 'patt)); - [Gramext.Stoken ("", "["); Gramext.Stoken ("", "]")], - Gramext.action - (fun _ _ (loc : int * int) -> (MLast.PaUid (loc, "[]") : 'patt)); - [Gramext.Stoken ("", "-"); Gramext.Stoken ("FLOAT", "")], - Gramext.action - (fun (s : string) _ (loc : int * int) -> - (MLast.PaFlo (loc, neg_string s) : 'patt)); - [Gramext.Stoken ("", "-"); Gramext.Stoken ("NATIVEINT", "")], - Gramext.action - (fun (s : string) _ (loc : int * int) -> - (MLast.PaNativeInt (loc, neg_string s) : 'patt)); - [Gramext.Stoken ("", "-"); Gramext.Stoken ("INT64", "")], - Gramext.action - (fun (s : string) _ (loc : int * int) -> - (MLast.PaInt64 (loc, neg_string s) : 'patt)); - [Gramext.Stoken ("", "-"); Gramext.Stoken ("INT32", "")], - Gramext.action - (fun (s : string) _ (loc : int * int) -> - (MLast.PaInt32 (loc, neg_string s) : 'patt)); - [Gramext.Stoken ("", "-"); Gramext.Stoken ("INT", "")], - Gramext.action - (fun (s : string) _ (loc : int * int) -> - (MLast.PaInt (loc, neg_string s) : 'patt)); - [Gramext.Stoken ("CHAR", "")], - Gramext.action - (fun (s : string) (loc : int * int) -> - (MLast.PaChr (loc, s) : 'patt)); - [Gramext.Stoken ("STRING", "")], - Gramext.action - (fun (s : string) (loc : int * int) -> - (MLast.PaStr (loc, s) : 'patt)); - [Gramext.Stoken ("FLOAT", "")], - Gramext.action - (fun (s : string) (loc : int * int) -> - (MLast.PaFlo (loc, s) : 'patt)); - [Gramext.Stoken ("NATIVEINT", "")], - Gramext.action - (fun (s : string) (loc : int * int) -> - (MLast.PaNativeInt (loc, s) : 'patt)); - [Gramext.Stoken ("INT64", "")], - Gramext.action - (fun (s : string) (loc : int * int) -> - (MLast.PaInt64 (loc, s) : 'patt)); - [Gramext.Stoken ("INT32", "")], - Gramext.action - (fun (s : string) (loc : int * int) -> - (MLast.PaInt32 (loc, s) : 'patt)); - [Gramext.Stoken ("INT", "")], - Gramext.action - (fun (s : string) (loc : int * int) -> - (MLast.PaInt (loc, s) : 'patt)); - [Gramext.Stoken ("UIDENT", "")], - Gramext.action - (fun (s : string) (loc : int * int) -> - (MLast.PaUid (loc, s) : 'patt)); - [Gramext.Stoken ("LIDENT", "")], - Gramext.action - (fun (s : string) (loc : int * int) -> - (MLast.PaLid (loc, s) : 'patt))]]; - Grammar.Entry.obj (cons_patt_opt : 'cons_patt_opt Grammar.Entry.e), None, - [None, None, - [[], Gramext.action (fun (loc : int * int) -> (None : 'cons_patt_opt)); - [Gramext.Stoken ("", "::"); - Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e))], - Gramext.action - (fun (p : 'patt) _ (loc : int * int) -> (Some p : 'cons_patt_opt))]]; - Grammar.Entry.obj (label_patt : 'label_patt Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj - (patt_label_ident : 'patt_label_ident Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e))], - Gramext.action - (fun (p : 'patt) _ (i : 'patt_label_ident) (loc : int * int) -> - (i, p : 'label_patt))]]; - Grammar.Entry.obj (patt_label_ident : 'patt_label_ident Grammar.Entry.e), - None, - [None, Some Gramext.LeftA, - [[Gramext.Sself; Gramext.Stoken ("", "."); Gramext.Sself], - Gramext.action - (fun (p2 : 'patt_label_ident) _ (p1 : 'patt_label_ident) - (loc : int * int) -> - (MLast.PaAcc (loc, p1, p2) : 'patt_label_ident))]; - Some "simple", Some Gramext.RightA, - [[Gramext.Stoken ("LIDENT", "")], - Gramext.action - (fun (i : string) (loc : int * int) -> - (MLast.PaLid (loc, i) : 'patt_label_ident)); - [Gramext.Stoken ("UIDENT", "")], - Gramext.action - (fun (i : string) (loc : int * int) -> - (MLast.PaUid (loc, i) : 'patt_label_ident))]]; - Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "_")], - Gramext.action (fun _ (loc : int * int) -> (MLast.PaAny loc : 'ipatt)); - [Gramext.Stoken ("LIDENT", "")], - Gramext.action - (fun (s : string) (loc : int * int) -> - (MLast.PaLid (loc, s) : 'ipatt)); - [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ","); - Gramext.Slist1sep - (Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e)), - Gramext.Stoken ("", ",")); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (pl : 'ipatt list) _ (p : 'ipatt) _ (loc : int * int) -> - (MLast.PaTup (loc, (p :: pl)) : 'ipatt)); - [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", "as"); - Gramext.Sself; Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (p2 : 'ipatt) _ (p : 'ipatt) _ (loc : int * int) -> - (MLast.PaAli (loc, p, p2) : 'ipatt)); - [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (t : 'ctyp) _ (p : 'ipatt) _ (loc : int * int) -> - (MLast.PaTyc (loc, p, t) : 'ipatt)); - [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ")")], - Gramext.action (fun _ (p : 'ipatt) _ (loc : int * int) -> (p : 'ipatt)); - [Gramext.Stoken ("", "("); Gramext.Stoken ("", ")")], - Gramext.action - (fun _ _ (loc : int * int) -> (MLast.PaUid (loc, "()") : 'ipatt)); - [Gramext.Stoken ("", "{"); - Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj (label_ipatt : 'label_ipatt Grammar.Entry.e)), - Gramext.Stoken ("", ";")); - Gramext.Stoken ("", "}")], - Gramext.action - (fun _ (lpl : 'label_ipatt list) _ (loc : int * int) -> - (MLast.PaRec (loc, lpl) : 'ipatt))]]; - Grammar.Entry.obj (label_ipatt : 'label_ipatt Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj - (patt_label_ident : 'patt_label_ident Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e))], - Gramext.action - (fun (p : 'ipatt) _ (i : 'patt_label_ident) (loc : int * int) -> - (i, p : 'label_ipatt))]]; - Grammar.Entry.obj (type_declaration : 'type_declaration Grammar.Entry.e), - None, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj (type_patt : 'type_patt Grammar.Entry.e)); - Gramext.Slist0 - (Gramext.Snterm - (Grammar.Entry.obj - (type_parameter : 'type_parameter Grammar.Entry.e))); - Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Slist0 - (Gramext.Snterm - (Grammar.Entry.obj (constrain : 'constrain Grammar.Entry.e)))], - Gramext.action - (fun (cl : 'constrain list) (tk : 'ctyp) _ - (tpl : 'type_parameter list) (n : 'type_patt) (loc : int * int) -> - (n, tpl, tk, cl : 'type_declaration))]]; - Grammar.Entry.obj (type_patt : 'type_patt Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("LIDENT", "")], - Gramext.action - (fun (n : string) (loc : int * int) -> (loc, n : 'type_patt))]]; - Grammar.Entry.obj (constrain : 'constrain Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "constraint"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], - Gramext.action - (fun (t2 : 'ctyp) _ (t1 : 'ctyp) _ (loc : int * int) -> - (t1, t2 : 'constrain))]]; - Grammar.Entry.obj (type_parameter : 'type_parameter Grammar.Entry.e), - None, - [None, None, - [[Gramext.Stoken ("", "-"); Gramext.Stoken ("", "'"); - Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e))], - Gramext.action - (fun (i : 'ident) _ _ (loc : int * int) -> - (i, (false, true) : 'type_parameter)); - [Gramext.Stoken ("", "+"); Gramext.Stoken ("", "'"); - Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e))], - Gramext.action - (fun (i : 'ident) _ _ (loc : int * int) -> - (i, (true, false) : 'type_parameter)); - [Gramext.Stoken ("", "'"); - Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e))], - Gramext.action - (fun (i : 'ident) _ (loc : int * int) -> - (i, (false, false) : 'type_parameter))]]; - Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e), None, - [None, Some Gramext.LeftA, - [[Gramext.Sself; Gramext.Stoken ("", "=="); Gramext.Sself], - Gramext.action - (fun (t2 : 'ctyp) _ (t1 : 'ctyp) (loc : int * int) -> - (MLast.TyMan (loc, t1, t2) : 'ctyp))]; - None, Some Gramext.LeftA, - [[Gramext.Sself; Gramext.Stoken ("", "as"); Gramext.Sself], - Gramext.action - (fun (t2 : 'ctyp) _ (t1 : 'ctyp) (loc : int * int) -> - (MLast.TyAli (loc, t1, t2) : 'ctyp))]; - None, Some Gramext.LeftA, - [[Gramext.Stoken ("", "!"); - Gramext.Slist1 - (Gramext.Snterm - (Grammar.Entry.obj (typevar : 'typevar Grammar.Entry.e))); - Gramext.Stoken ("", "."); Gramext.Sself], - Gramext.action - (fun (t : 'ctyp) _ (pl : 'typevar list) _ (loc : int * int) -> - (MLast.TyPol (loc, pl, t) : 'ctyp))]; - Some "arrow", Some Gramext.RightA, - [[Gramext.Sself; Gramext.Stoken ("", "->"); Gramext.Sself], - Gramext.action - (fun (t2 : 'ctyp) _ (t1 : 'ctyp) (loc : int * int) -> - (MLast.TyArr (loc, t1, t2) : 'ctyp))]; - Some "label", Some Gramext.NonA, - [[Gramext.Stoken ("OPTLABEL", ""); Gramext.Sself], - Gramext.action - (fun (t : 'ctyp) (i : string) (loc : int * int) -> - (MLast.TyOlb (loc, i, t) : 'ctyp)); - [Gramext.Stoken ("QUESTIONIDENT", ""); Gramext.Stoken ("", ":"); - Gramext.Sself], - Gramext.action - (fun (t : 'ctyp) _ (i : string) (loc : int * int) -> - (MLast.TyOlb (loc, i, t) : 'ctyp)); - [Gramext.Stoken ("LABEL", ""); Gramext.Sself], - Gramext.action - (fun (t : 'ctyp) (i : string) (loc : int * int) -> - (MLast.TyLab (loc, i, t) : 'ctyp)); - [Gramext.Stoken ("TILDEIDENT", ""); Gramext.Stoken ("", ":"); - Gramext.Sself], - Gramext.action - (fun (t : 'ctyp) _ (i : string) (loc : int * int) -> - (MLast.TyLab (loc, i, t) : 'ctyp))]; - None, Some Gramext.LeftA, - [[Gramext.Sself; Gramext.Sself], - Gramext.action - (fun (t2 : 'ctyp) (t1 : 'ctyp) (loc : int * int) -> - (MLast.TyApp (loc, t1, t2) : 'ctyp))]; - None, Some Gramext.LeftA, - [[Gramext.Sself; Gramext.Stoken ("", "."); Gramext.Sself], - Gramext.action - (fun (t2 : 'ctyp) _ (t1 : 'ctyp) (loc : int * int) -> - (MLast.TyAcc (loc, t1, t2) : 'ctyp))]; - Some "simple", None, - [[Gramext.Stoken ("", "{"); - Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj - (label_declaration : 'label_declaration Grammar.Entry.e)), - Gramext.Stoken ("", ";")); - Gramext.Stoken ("", "}")], - Gramext.action - (fun _ (ldl : 'label_declaration list) _ (loc : int * int) -> - (MLast.TyRec (loc, false, ldl) : 'ctyp)); - [Gramext.Stoken ("", "["); - Gramext.Slist0sep - (Gramext.Snterm - (Grammar.Entry.obj - (constructor_declaration : - 'constructor_declaration Grammar.Entry.e)), - Gramext.Stoken ("", "|")); - Gramext.Stoken ("", "]")], - Gramext.action - (fun _ (cdl : 'constructor_declaration list) _ (loc : int * int) -> - (MLast.TySum (loc, false, cdl) : 'ctyp)); - [Gramext.Stoken ("", "private"); Gramext.Stoken ("", "{"); - Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj - (label_declaration : 'label_declaration Grammar.Entry.e)), - Gramext.Stoken ("", ";")); - Gramext.Stoken ("", "}")], - Gramext.action - (fun _ (ldl : 'label_declaration list) _ _ (loc : int * int) -> - (MLast.TyRec (loc, true, ldl) : 'ctyp)); - [Gramext.Stoken ("", "private"); Gramext.Stoken ("", "["); - Gramext.Slist0sep - (Gramext.Snterm - (Grammar.Entry.obj - (constructor_declaration : - 'constructor_declaration Grammar.Entry.e)), - Gramext.Stoken ("", "|")); - Gramext.Stoken ("", "]")], - Gramext.action - (fun _ (cdl : 'constructor_declaration list) _ _ (loc : int * int) -> - (MLast.TySum (loc, true, cdl) : 'ctyp)); - [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ")")], - Gramext.action (fun _ (t : 'ctyp) _ (loc : int * int) -> (t : 'ctyp)); - [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", "*"); - Gramext.Slist1sep - (Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)), - Gramext.Stoken ("", "*")); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (tl : 'ctyp list) _ (t : 'ctyp) _ (loc : int * int) -> - (MLast.TyTup (loc, (t :: tl)) : 'ctyp)); - [Gramext.Stoken ("UIDENT", "")], - Gramext.action - (fun (i : string) (loc : int * int) -> - (MLast.TyUid (loc, i) : 'ctyp)); - [Gramext.Stoken ("LIDENT", "")], - Gramext.action - (fun (i : string) (loc : int * int) -> - (MLast.TyLid (loc, i) : 'ctyp)); - [Gramext.Stoken ("", "_")], - Gramext.action (fun _ (loc : int * int) -> (MLast.TyAny loc : 'ctyp)); - [Gramext.Stoken ("", "'"); - Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e))], - Gramext.action - (fun (i : 'ident) _ (loc : int * int) -> - (MLast.TyQuo (loc, i) : 'ctyp))]]; - Grammar.Entry.obj - (constructor_declaration : 'constructor_declaration Grammar.Entry.e), - None, - [None, None, - [[Gramext.Stoken ("UIDENT", "")], - Gramext.action - (fun (ci : string) (loc : int * int) -> - (loc, ci, [] : 'constructor_declaration)); - [Gramext.Stoken ("UIDENT", ""); Gramext.Stoken ("", "of"); - Gramext.Slist1sep - (Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)), - Gramext.Stoken ("", "and"))], - Gramext.action - (fun (cal : 'ctyp list) _ (ci : string) (loc : int * int) -> - (loc, ci, cal : 'constructor_declaration))]]; - Grammar.Entry.obj - (label_declaration : 'label_declaration Grammar.Entry.e), - None, - [None, None, - [[Gramext.Stoken ("LIDENT", ""); Gramext.Stoken ("", ":"); - Gramext.Sopt (Gramext.Stoken ("", "mutable")); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], - Gramext.action - (fun (t : 'ctyp) (mf : string option) _ (i : string) - (loc : int * int) -> - (loc, i, o2b mf, t : 'label_declaration))]]; - Grammar.Entry.obj (ident : 'ident Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("UIDENT", "")], - Gramext.action (fun (i : string) (loc : int * int) -> (i : 'ident)); - [Gramext.Stoken ("LIDENT", "")], - Gramext.action (fun (i : string) (loc : int * int) -> (i : 'ident))]]; - Grammar.Entry.obj (mod_ident : 'mod_ident Grammar.Entry.e), None, - [None, Some Gramext.RightA, - [[Gramext.Stoken ("UIDENT", ""); Gramext.Stoken ("", "."); - Gramext.Sself], - Gramext.action - (fun (j : 'mod_ident) _ (i : string) (loc : int * int) -> - (i :: j : 'mod_ident)); - [Gramext.Stoken ("LIDENT", "")], - Gramext.action - (fun (i : string) (loc : int * int) -> ([i] : 'mod_ident)); - [Gramext.Stoken ("UIDENT", "")], - Gramext.action - (fun (i : string) (loc : int * int) -> ([i] : 'mod_ident))]]; - Grammar.Entry.obj (str_item : 'str_item Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "class"); Gramext.Stoken ("", "type"); - Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj - (class_type_declaration : - 'class_type_declaration Grammar.Entry.e)), - Gramext.Stoken ("", "and"))], - Gramext.action - (fun (ctd : 'class_type_declaration list) _ _ (loc : int * int) -> - (MLast.StClt (loc, ctd) : 'str_item)); - [Gramext.Stoken ("", "class"); - Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj - (class_declaration : 'class_declaration Grammar.Entry.e)), - Gramext.Stoken ("", "and"))], - Gramext.action - (fun (cd : 'class_declaration list) _ (loc : int * int) -> - (MLast.StCls (loc, cd) : 'str_item))]]; - Grammar.Entry.obj (sig_item : 'sig_item Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "class"); Gramext.Stoken ("", "type"); - Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj - (class_type_declaration : - 'class_type_declaration Grammar.Entry.e)), - Gramext.Stoken ("", "and"))], - Gramext.action - (fun (ctd : 'class_type_declaration list) _ _ (loc : int * int) -> - (MLast.SgClt (loc, ctd) : 'sig_item)); - [Gramext.Stoken ("", "class"); - Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj - (class_description : 'class_description Grammar.Entry.e)), - Gramext.Stoken ("", "and"))], - Gramext.action - (fun (cd : 'class_description list) _ (loc : int * int) -> - (MLast.SgCls (loc, cd) : 'sig_item))]]; - Grammar.Entry.obj - (class_declaration : 'class_declaration Grammar.Entry.e), - None, - [None, None, - [[Gramext.Sopt (Gramext.Stoken ("", "virtual")); - Gramext.Stoken ("LIDENT", ""); - Gramext.Snterm - (Grammar.Entry.obj - (class_type_parameters : 'class_type_parameters Grammar.Entry.e)); - Gramext.Snterm - (Grammar.Entry.obj - (class_fun_binding : 'class_fun_binding Grammar.Entry.e))], - Gramext.action - (fun (cfb : 'class_fun_binding) (ctp : 'class_type_parameters) - (i : string) (vf : string option) (loc : int * int) -> - ({MLast.ciLoc = loc; MLast.ciVir = o2b vf; MLast.ciPrm = ctp; - MLast.ciNam = i; MLast.ciExp = cfb} : - 'class_declaration))]]; - Grammar.Entry.obj - (class_fun_binding : 'class_fun_binding Grammar.Entry.e), - None, - [None, None, - [[Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e)); - Gramext.Sself], - Gramext.action - (fun (cfb : 'class_fun_binding) (p : 'ipatt) (loc : int * int) -> - (MLast.CeFun (loc, p, cfb) : 'class_fun_binding)); - [Gramext.Stoken ("", ":"); - Gramext.Snterm - (Grammar.Entry.obj (class_type : 'class_type Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm - (Grammar.Entry.obj (class_expr : 'class_expr Grammar.Entry.e))], - Gramext.action - (fun (ce : 'class_expr) _ (ct : 'class_type) _ (loc : int * int) -> - (MLast.CeTyc (loc, ce, ct) : 'class_fun_binding)); - [Gramext.Stoken ("", "="); - Gramext.Snterm - (Grammar.Entry.obj (class_expr : 'class_expr Grammar.Entry.e))], - Gramext.action - (fun (ce : 'class_expr) _ (loc : int * int) -> - (ce : 'class_fun_binding))]]; - Grammar.Entry.obj - (class_type_parameters : 'class_type_parameters Grammar.Entry.e), - None, - [None, None, - [[Gramext.Stoken ("", "["); - Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj - (type_parameter : 'type_parameter Grammar.Entry.e)), - Gramext.Stoken ("", ",")); - Gramext.Stoken ("", "]")], - Gramext.action - (fun _ (tpl : 'type_parameter list) _ (loc : int * int) -> - (loc, tpl : 'class_type_parameters)); - [], - Gramext.action - (fun (loc : int * int) -> (loc, [] : 'class_type_parameters))]]; - Grammar.Entry.obj (class_fun_def : 'class_fun_def Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "->"); - Gramext.Snterm - (Grammar.Entry.obj (class_expr : 'class_expr Grammar.Entry.e))], - Gramext.action - (fun (ce : 'class_expr) _ (loc : int * int) -> (ce : 'class_fun_def)); - [Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e)); - Gramext.Sself], - Gramext.action - (fun (ce : 'class_fun_def) (p : 'ipatt) (loc : int * int) -> - (MLast.CeFun (loc, p, ce) : 'class_fun_def))]]; - Grammar.Entry.obj (class_expr : 'class_expr Grammar.Entry.e), None, - [Some "top", None, - [[Gramext.Stoken ("", "let"); Gramext.Sopt (Gramext.Stoken ("", "rec")); - Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj (let_binding : 'let_binding Grammar.Entry.e)), - Gramext.Stoken ("", "and")); - Gramext.Stoken ("", "in"); Gramext.Sself], - Gramext.action - (fun (ce : 'class_expr) _ (lb : 'let_binding list) - (rf : string option) _ (loc : int * int) -> - (MLast.CeLet (loc, o2b rf, lb, ce) : 'class_expr)); - [Gramext.Stoken ("", "fun"); - Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e)); - Gramext.Snterm - (Grammar.Entry.obj - (class_fun_def : 'class_fun_def Grammar.Entry.e))], - Gramext.action - (fun (ce : 'class_fun_def) (p : 'ipatt) _ (loc : int * int) -> - (MLast.CeFun (loc, p, ce) : 'class_expr))]; - Some "apply", Some Gramext.NonA, - [[Gramext.Sself; - Gramext.Snterml - (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), "label")], - Gramext.action - (fun (e : 'expr) (ce : 'class_expr) (loc : int * int) -> - (MLast.CeApp (loc, ce, e) : 'class_expr))]; - Some "simple", None, - [[Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (ce : 'class_expr) _ (loc : int * int) -> (ce : 'class_expr)); - [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ":"); - Gramext.Snterm - (Grammar.Entry.obj (class_type : 'class_type Grammar.Entry.e)); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (ct : 'class_type) _ (ce : 'class_expr) _ (loc : int * int) -> - (MLast.CeTyc (loc, ce, ct) : 'class_expr)); - [Gramext.Stoken ("", "object"); - Gramext.Sopt - (Gramext.Snterm - (Grammar.Entry.obj - (class_self_patt : 'class_self_patt Grammar.Entry.e))); - Gramext.Snterm - (Grammar.Entry.obj - (class_structure : 'class_structure Grammar.Entry.e)); - Gramext.Stoken ("", "end")], - Gramext.action - (fun _ (cf : 'class_structure) (cspo : 'class_self_patt option) _ - (loc : int * int) -> - (MLast.CeStr (loc, cspo, cf) : 'class_expr)); - [Gramext.Snterm - (Grammar.Entry.obj - (class_longident : 'class_longident Grammar.Entry.e))], - Gramext.action - (fun (ci : 'class_longident) (loc : int * int) -> - (MLast.CeCon (loc, ci, []) : 'class_expr)); - [Gramext.Snterm - (Grammar.Entry.obj - (class_longident : 'class_longident Grammar.Entry.e)); - Gramext.Stoken ("", "["); - Gramext.Slist0sep - (Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)), - Gramext.Stoken ("", ",")); - Gramext.Stoken ("", "]")], - Gramext.action - (fun _ (ctcl : 'ctyp list) _ (ci : 'class_longident) - (loc : int * int) -> - (MLast.CeCon (loc, ci, ctcl) : 'class_expr))]]; - Grammar.Entry.obj (class_structure : 'class_structure Grammar.Entry.e), - None, - [None, None, - [[Gramext.Slist0 - (Gramext.srules - [[Gramext.Snterm - (Grammar.Entry.obj - (class_str_item : 'class_str_item Grammar.Entry.e)); - Gramext.Stoken ("", ";")], - Gramext.action - (fun _ (cf : 'class_str_item) (loc : int * int) -> - (cf : 'e__6))])], - Gramext.action - (fun (cf : 'e__6 list) (loc : int * int) -> - (cf : 'class_structure))]]; - Grammar.Entry.obj (class_self_patt : 'class_self_patt Grammar.Entry.e), - None, - [None, None, - [[Gramext.Stoken ("", "("); - Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e)); - Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (t : 'ctyp) _ (p : 'patt) _ (loc : int * int) -> - (MLast.PaTyc (loc, p, t) : 'class_self_patt)); - [Gramext.Stoken ("", "("); - Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e)); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (p : 'patt) _ (loc : int * int) -> (p : 'class_self_patt))]]; - Grammar.Entry.obj (class_str_item : 'class_str_item Grammar.Entry.e), - None, - [None, None, - [[Gramext.Stoken ("", "initializer"); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (se : 'expr) _ (loc : int * int) -> - (MLast.CrIni (loc, se) : 'class_str_item)); - [Gramext.Stoken ("", "type"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], - Gramext.action - (fun (t2 : 'ctyp) _ (t1 : 'ctyp) _ (loc : int * int) -> - (MLast.CrCtr (loc, t1, t2) : 'class_str_item)); - [Gramext.Stoken ("", "method"); - Gramext.Sopt (Gramext.Stoken ("", "private")); - Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e)); - Gramext.Sopt - (Gramext.Snterm - (Grammar.Entry.obj (polyt : 'polyt Grammar.Entry.e))); - Gramext.Snterm - (Grammar.Entry.obj (fun_binding : 'fun_binding Grammar.Entry.e))], - Gramext.action - (fun (e : 'fun_binding) (topt : 'polyt option) (l : 'label) - (pf : string option) _ (loc : int * int) -> - (MLast.CrMth (loc, l, o2b pf, e, topt) : 'class_str_item)); - [Gramext.Stoken ("", "method"); Gramext.Stoken ("", "virtual"); - Gramext.Sopt (Gramext.Stoken ("", "private")); - Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e)); - Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], - Gramext.action - (fun (t : 'ctyp) _ (l : 'label) (pf : string option) _ _ - (loc : int * int) -> - (MLast.CrVir (loc, l, o2b pf, t) : 'class_str_item)); - [Gramext.Stoken ("", "value"); - Gramext.Sopt (Gramext.Stoken ("", "mutable")); - Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e)); - Gramext.Snterm - (Grammar.Entry.obj - (cvalue_binding : 'cvalue_binding Grammar.Entry.e))], - Gramext.action - (fun (e : 'cvalue_binding) (lab : 'label) (mf : string option) _ - (loc : int * int) -> - (MLast.CrVal (loc, lab, o2b mf, e) : 'class_str_item)); - [Gramext.Stoken ("", "inherit"); - Gramext.Snterm - (Grammar.Entry.obj (class_expr : 'class_expr Grammar.Entry.e)); - Gramext.Sopt - (Gramext.Snterm - (Grammar.Entry.obj (as_lident : 'as_lident Grammar.Entry.e)))], - Gramext.action - (fun (pb : 'as_lident option) (ce : 'class_expr) _ - (loc : int * int) -> - (MLast.CrInh (loc, ce, pb) : 'class_str_item)); - [Gramext.Stoken ("", "declare"); - Gramext.Slist0 - (Gramext.srules - [[Gramext.Snterm - (Grammar.Entry.obj - (class_str_item : 'class_str_item Grammar.Entry.e)); - Gramext.Stoken ("", ";")], - Gramext.action - (fun _ (s : 'class_str_item) (loc : int * int) -> - (s : 'e__7))]); - Gramext.Stoken ("", "end")], - Gramext.action - (fun _ (st : 'e__7 list) _ (loc : int * int) -> - (MLast.CrDcl (loc, st) : 'class_str_item))]]; - Grammar.Entry.obj (as_lident : 'as_lident Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "as"); Gramext.Stoken ("LIDENT", "")], - Gramext.action - (fun (i : string) _ (loc : int * int) -> (i : 'as_lident))]]; - Grammar.Entry.obj (polyt : 'polyt Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], - Gramext.action (fun (t : 'ctyp) _ (loc : int * int) -> (t : 'polyt))]]; - Grammar.Entry.obj (cvalue_binding : 'cvalue_binding Grammar.Entry.e), - None, - [None, None, - [[Gramext.Stoken ("", ":>"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) _ (t : 'ctyp) _ (loc : int * int) -> - (MLast.ExCoe (loc, e, None, t) : 'cvalue_binding)); - [Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", ":>"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) _ (t2 : 'ctyp) _ (t : 'ctyp) _ (loc : int * int) -> - (MLast.ExCoe (loc, e, Some t, t2) : 'cvalue_binding)); - [Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) _ (t : 'ctyp) _ (loc : int * int) -> - (MLast.ExTyc (loc, e, t) : 'cvalue_binding)); - [Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) _ (loc : int * int) -> (e : 'cvalue_binding))]]; - Grammar.Entry.obj (label : 'label Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("LIDENT", "")], - Gramext.action (fun (i : string) (loc : int * int) -> (i : 'label))]]; - Grammar.Entry.obj (class_type : 'class_type Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "object"); - Gramext.Sopt - (Gramext.Snterm - (Grammar.Entry.obj - (class_self_type : 'class_self_type Grammar.Entry.e))); - Gramext.Slist0 - (Gramext.srules - [[Gramext.Snterm - (Grammar.Entry.obj - (class_sig_item : 'class_sig_item Grammar.Entry.e)); - Gramext.Stoken ("", ";")], - Gramext.action - (fun _ (csf : 'class_sig_item) (loc : int * int) -> - (csf : 'e__8))]); - Gramext.Stoken ("", "end")], - Gramext.action - (fun _ (csf : 'e__8 list) (cst : 'class_self_type option) _ - (loc : int * int) -> - (MLast.CtSig (loc, cst, csf) : 'class_type)); - [Gramext.Snterm - (Grammar.Entry.obj - (clty_longident : 'clty_longident Grammar.Entry.e))], - Gramext.action - (fun (id : 'clty_longident) (loc : int * int) -> - (MLast.CtCon (loc, id, []) : 'class_type)); - [Gramext.Snterm - (Grammar.Entry.obj - (clty_longident : 'clty_longident Grammar.Entry.e)); - Gramext.Stoken ("", "["); - Gramext.Slist1sep - (Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)), - Gramext.Stoken ("", ",")); - Gramext.Stoken ("", "]")], - Gramext.action - (fun _ (tl : 'ctyp list) _ (id : 'clty_longident) (loc : int * int) -> - (MLast.CtCon (loc, id, tl) : 'class_type)); - [Gramext.Stoken ("", "["); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", "]"); Gramext.Stoken ("", "->"); Gramext.Sself], - Gramext.action - (fun (ct : 'class_type) _ _ (t : 'ctyp) _ (loc : int * int) -> - (MLast.CtFun (loc, t, ct) : 'class_type))]]; - Grammar.Entry.obj (class_self_type : 'class_self_type Grammar.Entry.e), - None, - [None, None, - [[Gramext.Stoken ("", "("); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (t : 'ctyp) _ (loc : int * int) -> (t : 'class_self_type))]]; - Grammar.Entry.obj (class_sig_item : 'class_sig_item Grammar.Entry.e), - None, - [None, None, - [[Gramext.Stoken ("", "type"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], - Gramext.action - (fun (t2 : 'ctyp) _ (t1 : 'ctyp) _ (loc : int * int) -> - (MLast.CgCtr (loc, t1, t2) : 'class_sig_item)); - [Gramext.Stoken ("", "method"); - Gramext.Sopt (Gramext.Stoken ("", "private")); - Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e)); - Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], - Gramext.action - (fun (t : 'ctyp) _ (l : 'label) (pf : string option) _ - (loc : int * int) -> - (MLast.CgMth (loc, l, o2b pf, t) : 'class_sig_item)); - [Gramext.Stoken ("", "method"); Gramext.Stoken ("", "virtual"); - Gramext.Sopt (Gramext.Stoken ("", "private")); - Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e)); - Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], - Gramext.action - (fun (t : 'ctyp) _ (l : 'label) (pf : string option) _ _ - (loc : int * int) -> - (MLast.CgVir (loc, l, o2b pf, t) : 'class_sig_item)); - [Gramext.Stoken ("", "value"); - Gramext.Sopt (Gramext.Stoken ("", "mutable")); - Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e)); - Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], - Gramext.action - (fun (t : 'ctyp) _ (l : 'label) (mf : string option) _ - (loc : int * int) -> - (MLast.CgVal (loc, l, o2b mf, t) : 'class_sig_item)); - [Gramext.Stoken ("", "inherit"); - Gramext.Snterm - (Grammar.Entry.obj (class_type : 'class_type Grammar.Entry.e))], - Gramext.action - (fun (cs : 'class_type) _ (loc : int * int) -> - (MLast.CgInh (loc, cs) : 'class_sig_item)); - [Gramext.Stoken ("", "declare"); - Gramext.Slist0 - (Gramext.srules - [[Gramext.Snterm - (Grammar.Entry.obj - (class_sig_item : 'class_sig_item Grammar.Entry.e)); - Gramext.Stoken ("", ";")], - Gramext.action - (fun _ (s : 'class_sig_item) (loc : int * int) -> - (s : 'e__9))]); - Gramext.Stoken ("", "end")], - Gramext.action - (fun _ (st : 'e__9 list) _ (loc : int * int) -> - (MLast.CgDcl (loc, st) : 'class_sig_item))]]; - Grammar.Entry.obj - (class_description : 'class_description Grammar.Entry.e), - None, - [None, None, - [[Gramext.Sopt (Gramext.Stoken ("", "virtual")); - Gramext.Stoken ("LIDENT", ""); - Gramext.Snterm - (Grammar.Entry.obj - (class_type_parameters : 'class_type_parameters Grammar.Entry.e)); - Gramext.Stoken ("", ":"); - Gramext.Snterm - (Grammar.Entry.obj (class_type : 'class_type Grammar.Entry.e))], - Gramext.action - (fun (ct : 'class_type) _ (ctp : 'class_type_parameters) (n : string) - (vf : string option) (loc : int * int) -> - ({MLast.ciLoc = loc; MLast.ciVir = o2b vf; MLast.ciPrm = ctp; - MLast.ciNam = n; MLast.ciExp = ct} : - 'class_description))]]; - Grammar.Entry.obj - (class_type_declaration : 'class_type_declaration Grammar.Entry.e), - None, - [None, None, - [[Gramext.Sopt (Gramext.Stoken ("", "virtual")); - Gramext.Stoken ("LIDENT", ""); - Gramext.Snterm - (Grammar.Entry.obj - (class_type_parameters : 'class_type_parameters Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm - (Grammar.Entry.obj (class_type : 'class_type Grammar.Entry.e))], - Gramext.action - (fun (cs : 'class_type) _ (ctp : 'class_type_parameters) (n : string) - (vf : string option) (loc : int * int) -> - ({MLast.ciLoc = loc; MLast.ciVir = o2b vf; MLast.ciPrm = ctp; - MLast.ciNam = n; MLast.ciExp = cs} : - 'class_type_declaration))]]; - Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), - Some (Gramext.Level "apply"), - [None, Some Gramext.LeftA, - [[Gramext.Stoken ("", "new"); - Gramext.Snterm - (Grammar.Entry.obj - (class_longident : 'class_longident Grammar.Entry.e))], - Gramext.action - (fun (i : 'class_longident) _ (loc : int * int) -> - (MLast.ExNew (loc, i) : 'expr))]]; - Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), - Some (Gramext.Level "."), - [None, None, - [[Gramext.Sself; Gramext.Stoken ("", "#"); - Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e))], - Gramext.action - (fun (lab : 'label) _ (e : 'expr) (loc : int * int) -> - (MLast.ExSnd (loc, e, lab) : 'expr))]]; - Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), - Some (Gramext.Level "simple"), - [None, None, - [[Gramext.Stoken ("", "{<"); - Gramext.Slist0sep - (Gramext.Snterm - (Grammar.Entry.obj (field_expr : 'field_expr Grammar.Entry.e)), - Gramext.Stoken ("", ";")); - Gramext.Stoken ("", ">}")], - Gramext.action - (fun _ (fel : 'field_expr list) _ (loc : int * int) -> - (MLast.ExOvr (loc, fel) : 'expr)); - [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ":>"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (t : 'ctyp) _ (e : 'expr) _ (loc : int * int) -> - (MLast.ExCoe (loc, e, None, t) : 'expr)); - [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", ":>"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (t2 : 'ctyp) _ (t : 'ctyp) _ (e : 'expr) _ (loc : int * int) -> - (MLast.ExCoe (loc, e, Some t, t2) : 'expr))]]; - Grammar.Entry.obj (field_expr : 'field_expr Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) _ (l : 'label) (loc : int * int) -> - (l, e : 'field_expr))]]; - Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e), - Some (Gramext.Level "simple"), - [None, None, - [[Gramext.Stoken ("", "<"); - Gramext.Slist0sep - (Gramext.Snterm (Grammar.Entry.obj (field : 'field Grammar.Entry.e)), - Gramext.Stoken ("", ";")); - Gramext.Sopt (Gramext.Stoken ("", "..")); Gramext.Stoken ("", ">")], - Gramext.action - (fun _ (v : string option) (ml : 'field list) _ (loc : int * int) -> - (MLast.TyObj (loc, ml, o2b v) : 'ctyp)); - [Gramext.Stoken ("", "#"); - Gramext.Snterm - (Grammar.Entry.obj - (class_longident : 'class_longident Grammar.Entry.e))], - Gramext.action - (fun (id : 'class_longident) _ (loc : int * int) -> - (MLast.TyCls (loc, id) : 'ctyp))]]; - Grammar.Entry.obj (field : 'field Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("LIDENT", ""); Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], - Gramext.action - (fun (t : 'ctyp) _ (lab : string) (loc : int * int) -> - (lab, t : 'field))]]; - Grammar.Entry.obj (typevar : 'typevar Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "'"); - Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e))], - Gramext.action - (fun (i : 'ident) _ (loc : int * int) -> (i : 'typevar))]]; - Grammar.Entry.obj (clty_longident : 'clty_longident Grammar.Entry.e), - None, - [None, None, - [[Gramext.Stoken ("LIDENT", "")], - Gramext.action - (fun (i : string) (loc : int * int) -> ([i] : 'clty_longident)); - [Gramext.Stoken ("UIDENT", ""); Gramext.Stoken ("", "."); - Gramext.Sself], - Gramext.action - (fun (l : 'clty_longident) _ (m : string) (loc : int * int) -> - (m :: l : 'clty_longident))]]; - Grammar.Entry.obj (class_longident : 'class_longident Grammar.Entry.e), - None, - [None, None, - [[Gramext.Stoken ("LIDENT", "")], - Gramext.action - (fun (i : string) (loc : int * int) -> ([i] : 'class_longident)); - [Gramext.Stoken ("UIDENT", ""); Gramext.Stoken ("", "."); - Gramext.Sself], - Gramext.action - (fun (l : 'class_longident) _ (m : string) (loc : int * int) -> - (m :: l : 'class_longident))]]; - Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e), - Some (Gramext.Level "simple"), - [None, None, - [[Gramext.Stoken ("", "["); Gramext.Stoken ("", "<"); - Gramext.Snterm - (Grammar.Entry.obj - (row_field_list : 'row_field_list Grammar.Entry.e)); - Gramext.Stoken ("", ">"); - Gramext.Slist1 - (Gramext.Snterm - (Grammar.Entry.obj (name_tag : 'name_tag Grammar.Entry.e))); - Gramext.Stoken ("", "]")], - Gramext.action - (fun _ (ntl : 'name_tag list) _ (rfl : 'row_field_list) _ _ - (loc : int * int) -> - (MLast.TyVrn (loc, rfl, Some (Some ntl)) : 'ctyp)); - [Gramext.Stoken ("", "["); Gramext.Stoken ("", "<"); - Gramext.Snterm - (Grammar.Entry.obj - (row_field_list : 'row_field_list Grammar.Entry.e)); - Gramext.Stoken ("", "]")], - Gramext.action - (fun _ (rfl : 'row_field_list) _ _ (loc : int * int) -> - (MLast.TyVrn (loc, rfl, Some (Some [])) : 'ctyp)); - [Gramext.Stoken ("", "["); Gramext.Stoken ("", ">"); - Gramext.Snterm - (Grammar.Entry.obj - (row_field_list : 'row_field_list Grammar.Entry.e)); - Gramext.Stoken ("", "]")], - Gramext.action - (fun _ (rfl : 'row_field_list) _ _ (loc : int * int) -> - (MLast.TyVrn (loc, rfl, Some None) : 'ctyp)); - [Gramext.Stoken ("", "["); Gramext.Stoken ("", "="); - Gramext.Snterm - (Grammar.Entry.obj - (row_field_list : 'row_field_list Grammar.Entry.e)); - Gramext.Stoken ("", "]")], - Gramext.action - (fun _ (rfl : 'row_field_list) _ _ (loc : int * int) -> - (MLast.TyVrn (loc, rfl, None) : 'ctyp))]]; - Grammar.Entry.obj (row_field_list : 'row_field_list Grammar.Entry.e), - None, - [None, None, - [[Gramext.Slist0sep - (Gramext.Snterm - (Grammar.Entry.obj (row_field : 'row_field Grammar.Entry.e)), - Gramext.Stoken ("", "|"))], - Gramext.action - (fun (rfl : 'row_field list) (loc : int * int) -> - (rfl : 'row_field_list))]]; - Grammar.Entry.obj (row_field : 'row_field Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], - Gramext.action - (fun (t : 'ctyp) (loc : int * int) -> (MLast.RfInh t : 'row_field)); - [Gramext.Stoken ("", "`"); - Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e)); - Gramext.Stoken ("", "of"); Gramext.Sopt (Gramext.Stoken ("", "&")); - Gramext.Slist1sep - (Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)), - Gramext.Stoken ("", "&"))], - Gramext.action - (fun (l : 'ctyp list) (ao : string option) _ (i : 'ident) _ - (loc : int * int) -> - (MLast.RfTag (i, o2b ao, l) : 'row_field)); - [Gramext.Stoken ("", "`"); - Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e))], - Gramext.action - (fun (i : 'ident) _ (loc : int * int) -> - (MLast.RfTag (i, true, []) : 'row_field))]]; - Grammar.Entry.obj (name_tag : 'name_tag Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "`"); - Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e))], - Gramext.action - (fun (i : 'ident) _ (loc : int * int) -> (i : 'name_tag))]]; - Grammar.Entry.obj (patt : 'patt Grammar.Entry.e), - Some (Gramext.Level "simple"), - [None, None, - [[Gramext.Stoken ("", "?"); Gramext.Stoken ("", "("); - Gramext.Snterm - (Grammar.Entry.obj (patt_tcon : 'patt_tcon Grammar.Entry.e)); - Gramext.Sopt - (Gramext.Snterm - (Grammar.Entry.obj (eq_expr : 'eq_expr Grammar.Entry.e))); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (eo : 'eq_expr option) (p : 'patt_tcon) _ _ - (loc : int * int) -> - (MLast.PaOlb (loc, "", Some (p, eo)) : 'patt)); - [Gramext.Stoken ("QUESTIONIDENT", "")], - Gramext.action - (fun (i : string) (loc : int * int) -> - (MLast.PaOlb (loc, i, None) : 'patt)); - [Gramext.Stoken ("OPTLABEL", ""); Gramext.Stoken ("", "("); - Gramext.Snterm - (Grammar.Entry.obj (patt_tcon : 'patt_tcon Grammar.Entry.e)); - Gramext.Sopt - (Gramext.Snterm - (Grammar.Entry.obj (eq_expr : 'eq_expr Grammar.Entry.e))); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (eo : 'eq_expr option) (p : 'patt_tcon) _ (i : string) - (loc : int * int) -> - (MLast.PaOlb (loc, i, Some (p, eo)) : 'patt)); - [Gramext.Stoken ("QUESTIONIDENT", ""); Gramext.Stoken ("", ":"); - Gramext.Stoken ("", "("); - Gramext.Snterm - (Grammar.Entry.obj (patt_tcon : 'patt_tcon Grammar.Entry.e)); - Gramext.Sopt - (Gramext.Snterm - (Grammar.Entry.obj (eq_expr : 'eq_expr Grammar.Entry.e))); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (eo : 'eq_expr option) (p : 'patt_tcon) _ _ (i : string) - (loc : int * int) -> - (MLast.PaOlb (loc, i, Some (p, eo)) : 'patt)); - [Gramext.Stoken ("TILDEIDENT", "")], - Gramext.action - (fun (i : string) (loc : int * int) -> - (MLast.PaLab (loc, i, None) : 'patt)); - [Gramext.Stoken ("LABEL", ""); Gramext.Sself], - Gramext.action - (fun (p : 'patt) (i : string) (loc : int * int) -> - (MLast.PaLab (loc, i, Some p) : 'patt)); - [Gramext.Stoken ("TILDEIDENT", ""); Gramext.Stoken ("", ":"); - Gramext.Sself], - Gramext.action - (fun (p : 'patt) _ (i : string) (loc : int * int) -> - (MLast.PaLab (loc, i, Some p) : 'patt)); - [Gramext.Stoken ("", "#"); - Gramext.Snterm - (Grammar.Entry.obj (mod_ident : 'mod_ident Grammar.Entry.e))], - Gramext.action - (fun (sl : 'mod_ident) _ (loc : int * int) -> - (MLast.PaTyp (loc, sl) : 'patt)); - [Gramext.Stoken ("", "`"); - Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e))], - Gramext.action - (fun (s : 'ident) _ (loc : int * int) -> - (MLast.PaVrn (loc, s) : 'patt))]]; - Grammar.Entry.obj (patt_tcon : 'patt_tcon Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e))], - Gramext.action (fun (p : 'patt) (loc : int * int) -> (p : 'patt_tcon)); - [Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e)); - Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], - Gramext.action - (fun (t : 'ctyp) _ (p : 'patt) (loc : int * int) -> - (MLast.PaTyc (loc, p, t) : 'patt_tcon))]]; - Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "?"); Gramext.Stoken ("", "("); - Gramext.Snterm - (Grammar.Entry.obj (ipatt_tcon : 'ipatt_tcon Grammar.Entry.e)); - Gramext.Sopt - (Gramext.Snterm - (Grammar.Entry.obj (eq_expr : 'eq_expr Grammar.Entry.e))); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (eo : 'eq_expr option) (p : 'ipatt_tcon) _ _ - (loc : int * int) -> - (MLast.PaOlb (loc, "", Some (p, eo)) : 'ipatt)); - [Gramext.Stoken ("QUESTIONIDENT", "")], - Gramext.action - (fun (i : string) (loc : int * int) -> - (MLast.PaOlb (loc, i, None) : 'ipatt)); - [Gramext.Stoken ("OPTLABEL", ""); Gramext.Stoken ("", "("); - Gramext.Snterm - (Grammar.Entry.obj (ipatt_tcon : 'ipatt_tcon Grammar.Entry.e)); - Gramext.Sopt - (Gramext.Snterm - (Grammar.Entry.obj (eq_expr : 'eq_expr Grammar.Entry.e))); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (eo : 'eq_expr option) (p : 'ipatt_tcon) _ (i : string) - (loc : int * int) -> - (MLast.PaOlb (loc, i, Some (p, eo)) : 'ipatt)); - [Gramext.Stoken ("QUESTIONIDENT", ""); Gramext.Stoken ("", ":"); - Gramext.Stoken ("", "("); - Gramext.Snterm - (Grammar.Entry.obj (ipatt_tcon : 'ipatt_tcon Grammar.Entry.e)); - Gramext.Sopt - (Gramext.Snterm - (Grammar.Entry.obj (eq_expr : 'eq_expr Grammar.Entry.e))); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (eo : 'eq_expr option) (p : 'ipatt_tcon) _ _ (i : string) - (loc : int * int) -> - (MLast.PaOlb (loc, i, Some (p, eo)) : 'ipatt)); - [Gramext.Stoken ("TILDEIDENT", "")], - Gramext.action - (fun (i : string) (loc : int * int) -> - (MLast.PaLab (loc, i, None) : 'ipatt)); - [Gramext.Stoken ("LABEL", ""); Gramext.Sself], - Gramext.action - (fun (p : 'ipatt) (i : string) (loc : int * int) -> - (MLast.PaLab (loc, i, Some p) : 'ipatt)); - [Gramext.Stoken ("TILDEIDENT", ""); Gramext.Stoken ("", ":"); - Gramext.Sself], - Gramext.action - (fun (p : 'ipatt) _ (i : string) (loc : int * int) -> - (MLast.PaLab (loc, i, Some p) : 'ipatt))]]; - Grammar.Entry.obj (ipatt_tcon : 'ipatt_tcon Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e))], - Gramext.action - (fun (p : 'ipatt) (loc : int * int) -> (p : 'ipatt_tcon)); - [Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e)); - Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], - Gramext.action - (fun (t : 'ctyp) _ (p : 'ipatt) (loc : int * int) -> - (MLast.PaTyc (loc, p, t) : 'ipatt_tcon))]]; - Grammar.Entry.obj (eq_expr : 'eq_expr Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) _ (loc : int * int) -> (e : 'eq_expr))]]; - Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), - Some (Gramext.After "apply"), - [Some "label", Some Gramext.NonA, - [[Gramext.Stoken ("QUESTIONIDENT", "")], - Gramext.action - (fun (i : string) (loc : int * int) -> - (MLast.ExOlb (loc, i, None) : 'expr)); - [Gramext.Stoken ("OPTLABEL", ""); Gramext.Sself], - Gramext.action - (fun (e : 'expr) (i : string) (loc : int * int) -> - (MLast.ExOlb (loc, i, Some e) : 'expr)); - [Gramext.Stoken ("QUESTIONIDENT", ""); Gramext.Stoken ("", ":"); - Gramext.Sself], - Gramext.action - (fun (e : 'expr) _ (i : string) (loc : int * int) -> - (MLast.ExOlb (loc, i, Some e) : 'expr)); - [Gramext.Stoken ("TILDEIDENT", "")], - Gramext.action - (fun (i : string) (loc : int * int) -> - (MLast.ExLab (loc, i, None) : 'expr)); - [Gramext.Stoken ("LABEL", ""); Gramext.Sself], - Gramext.action - (fun (e : 'expr) (i : string) (loc : int * int) -> - (MLast.ExLab (loc, i, Some e) : 'expr)); - [Gramext.Stoken ("TILDEIDENT", ""); Gramext.Stoken ("", ":"); - Gramext.Sself], - Gramext.action - (fun (e : 'expr) _ (i : string) (loc : int * int) -> - (MLast.ExLab (loc, i, Some e) : 'expr))]]; - Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), - Some (Gramext.Level "simple"), - [None, None, - [[Gramext.Stoken ("", "`"); - Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e))], - Gramext.action - (fun (s : 'ident) _ (loc : int * int) -> - (MLast.ExVrn (loc, s) : 'expr))]]; - Grammar.Entry.obj (direction_flag : 'direction_flag Grammar.Entry.e), - None, - [None, None, - [[Gramext.Stoken ("", "downto")], - Gramext.action (fun _ (loc : int * int) -> (false : 'direction_flag)); - [Gramext.Stoken ("", "to")], - Gramext.action (fun _ (loc : int * int) -> (true : 'direction_flag))]]; - Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e), - Some (Gramext.Level "simple"), - [None, None, - [[Gramext.Stoken ("", "[|"); - Gramext.Snterm - (Grammar.Entry.obj - (warning_variant : 'warning_variant Grammar.Entry.e)); - Gramext.Stoken ("", "<"); - Gramext.Snterm - (Grammar.Entry.obj - (row_field_list : 'row_field_list Grammar.Entry.e)); - Gramext.Stoken ("", ">"); - Gramext.Slist1 - (Gramext.Snterm - (Grammar.Entry.obj (name_tag : 'name_tag Grammar.Entry.e))); - Gramext.Stoken ("", "|]")], - Gramext.action - (fun _ (ntl : 'name_tag list) _ (rfl : 'row_field_list) _ _ _ - (loc : int * int) -> - (MLast.TyVrn (loc, rfl, Some (Some ntl)) : 'ctyp)); - [Gramext.Stoken ("", "[|"); - Gramext.Snterm - (Grammar.Entry.obj - (warning_variant : 'warning_variant Grammar.Entry.e)); - Gramext.Stoken ("", "<"); - Gramext.Snterm - (Grammar.Entry.obj - (row_field_list : 'row_field_list Grammar.Entry.e)); - Gramext.Stoken ("", "|]")], - Gramext.action - (fun _ (rfl : 'row_field_list) _ _ _ (loc : int * int) -> - (MLast.TyVrn (loc, rfl, Some (Some [])) : 'ctyp)); - [Gramext.Stoken ("", "[|"); - Gramext.Snterm - (Grammar.Entry.obj - (warning_variant : 'warning_variant Grammar.Entry.e)); - Gramext.Stoken ("", ">"); - Gramext.Snterm - (Grammar.Entry.obj - (row_field_list : 'row_field_list Grammar.Entry.e)); - Gramext.Stoken ("", "|]")], - Gramext.action - (fun _ (rfl : 'row_field_list) _ _ _ (loc : int * int) -> - (MLast.TyVrn (loc, rfl, Some None) : 'ctyp)); - [Gramext.Stoken ("", "[|"); - Gramext.Snterm - (Grammar.Entry.obj - (warning_variant : 'warning_variant Grammar.Entry.e)); - Gramext.Snterm - (Grammar.Entry.obj - (row_field_list : 'row_field_list Grammar.Entry.e)); - Gramext.Stoken ("", "|]")], - Gramext.action - (fun _ (rfl : 'row_field_list) _ _ (loc : int * int) -> - (MLast.TyVrn (loc, rfl, None) : 'ctyp))]]; - Grammar.Entry.obj (warning_variant : 'warning_variant Grammar.Entry.e), - None, - [None, None, - [[], - Gramext.action - (fun (loc : int * int) -> (warn_variant loc : 'warning_variant))]]; - Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), - Some (Gramext.Level "top"), - [None, None, - [[Gramext.Stoken ("", "while"); Gramext.Sself; Gramext.Stoken ("", "do"); - Gramext.Slist0 - (Gramext.srules - [[Gramext.Snterm - (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e)); - Gramext.Stoken ("", ";")], - Gramext.action - (fun _ (e : 'expr) (loc : int * int) -> (e : 'e__12))]); - Gramext.Snterm - (Grammar.Entry.obj - (warning_sequence : 'warning_sequence Grammar.Entry.e)); - Gramext.Stoken ("", "done")], - Gramext.action - (fun _ _ (seq : 'e__12 list) _ (e : 'expr) _ (loc : int * int) -> - (MLast.ExWhi (loc, e, seq) : 'expr)); - [Gramext.Stoken ("", "for"); Gramext.Stoken ("LIDENT", ""); - Gramext.Stoken ("", "="); Gramext.Sself; - Gramext.Snterm - (Grammar.Entry.obj - (direction_flag : 'direction_flag Grammar.Entry.e)); - Gramext.Sself; Gramext.Stoken ("", "do"); - Gramext.Slist0 - (Gramext.srules - [[Gramext.Snterm - (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e)); - Gramext.Stoken ("", ";")], - Gramext.action - (fun _ (e : 'expr) (loc : int * int) -> (e : 'e__11))]); - Gramext.Snterm - (Grammar.Entry.obj - (warning_sequence : 'warning_sequence Grammar.Entry.e)); - Gramext.Stoken ("", "done")], - Gramext.action - (fun _ _ (seq : 'e__11 list) _ (e2 : 'expr) (df : 'direction_flag) - (e1 : 'expr) _ (i : string) _ (loc : int * int) -> - (MLast.ExFor (loc, i, e1, e2, df, seq) : 'expr)); - [Gramext.Stoken ("", "do"); - Gramext.Slist0 - (Gramext.srules - [[Gramext.Snterm - (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e)); - Gramext.Stoken ("", ";")], - Gramext.action - (fun _ (e : 'expr) (loc : int * int) -> (e : 'e__10))]); - Gramext.Stoken ("", "return"); - Gramext.Snterm - (Grammar.Entry.obj - (warning_sequence : 'warning_sequence Grammar.Entry.e)); - Gramext.Sself], - Gramext.action - (fun (e : 'expr) _ _ (seq : 'e__10 list) _ (loc : int * int) -> - (MLast.ExSeq (loc, append_elem seq e) : 'expr))]]; - Grammar.Entry.obj (warning_sequence : 'warning_sequence Grammar.Entry.e), - None, - [None, None, - [[], - Gramext.action - (fun (loc : int * int) -> - (warn_sequence loc : 'warning_sequence))]]]);; - -Grammar.extend - (let _ = (interf : 'interf Grammar.Entry.e) - and _ = (implem : 'implem Grammar.Entry.e) - and _ = (use_file : 'use_file Grammar.Entry.e) - and _ = (top_phrase : 'top_phrase Grammar.Entry.e) - and _ = (expr : 'expr Grammar.Entry.e) - and _ = (patt : 'patt Grammar.Entry.e) in - let grammar_entry_create s = - Grammar.Entry.create (Grammar.of_entry interf) s - in - let sig_item_semi : 'sig_item_semi Grammar.Entry.e = - grammar_entry_create "sig_item_semi" - and str_item_semi : 'str_item_semi Grammar.Entry.e = - grammar_entry_create "str_item_semi" - and phrase : 'phrase Grammar.Entry.e = grammar_entry_create "phrase" in - [Grammar.Entry.obj (interf : 'interf Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("EOI", "")], - Gramext.action (fun _ (loc : int * int) -> ([], false : 'interf)); - [Gramext.Snterm - (Grammar.Entry.obj (sig_item_semi : 'sig_item_semi Grammar.Entry.e)); - Gramext.Sself], - Gramext.action - (fun (sil, stopped : 'interf) (si : 'sig_item_semi) - (loc : int * int) -> - (si :: sil, stopped : 'interf)); - [Gramext.Stoken ("", "#"); Gramext.Stoken ("LIDENT", ""); - Gramext.Sopt - (Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))); - Gramext.Stoken ("", ";")], - Gramext.action - (fun _ (dp : 'expr option) (n : string) _ (loc : int * int) -> - ([MLast.SgDir (loc, n, dp), loc], true : 'interf))]]; - Grammar.Entry.obj (sig_item_semi : 'sig_item_semi Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj (sig_item : 'sig_item Grammar.Entry.e)); - Gramext.Stoken ("", ";")], - Gramext.action - (fun _ (si : 'sig_item) (loc : int * int) -> - (si, loc : 'sig_item_semi))]]; - Grammar.Entry.obj (implem : 'implem Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("EOI", "")], - Gramext.action (fun _ (loc : int * int) -> ([], false : 'implem)); - [Gramext.Snterm - (Grammar.Entry.obj (str_item_semi : 'str_item_semi Grammar.Entry.e)); - Gramext.Sself], - Gramext.action - (fun (sil, stopped : 'implem) (si : 'str_item_semi) - (loc : int * int) -> - (si :: sil, stopped : 'implem)); - [Gramext.Stoken ("", "#"); Gramext.Stoken ("LIDENT", ""); - Gramext.Sopt - (Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))); - Gramext.Stoken ("", ";")], - Gramext.action - (fun _ (dp : 'expr option) (n : string) _ (loc : int * int) -> - ([MLast.StDir (loc, n, dp), loc], true : 'implem))]]; - Grammar.Entry.obj (str_item_semi : 'str_item_semi Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj (str_item : 'str_item Grammar.Entry.e)); - Gramext.Stoken ("", ";")], - Gramext.action - (fun _ (si : 'str_item) (loc : int * int) -> - (si, loc : 'str_item_semi))]]; - Grammar.Entry.obj (top_phrase : 'top_phrase Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("EOI", "")], - Gramext.action (fun _ (loc : int * int) -> (None : 'top_phrase)); - [Gramext.Snterm (Grammar.Entry.obj (phrase : 'phrase Grammar.Entry.e))], - Gramext.action - (fun (ph : 'phrase) (loc : int * int) -> (Some ph : 'top_phrase))]]; - Grammar.Entry.obj (use_file : 'use_file Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("EOI", "")], - Gramext.action (fun _ (loc : int * int) -> ([], false : 'use_file)); - [Gramext.Snterm - (Grammar.Entry.obj (str_item : 'str_item Grammar.Entry.e)); - Gramext.Stoken ("", ";"); Gramext.Sself], - Gramext.action - (fun (sil, stopped : 'use_file) _ (si : 'str_item) - (loc : int * int) -> - (si :: sil, stopped : 'use_file)); - [Gramext.Stoken ("", "#"); Gramext.Stoken ("LIDENT", ""); - Gramext.Sopt - (Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))); - Gramext.Stoken ("", ";")], - Gramext.action - (fun _ (dp : 'expr option) (n : string) _ (loc : int * int) -> - ([MLast.StDir (loc, n, dp)], true : 'use_file))]]; - Grammar.Entry.obj (phrase : 'phrase Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj (str_item : 'str_item Grammar.Entry.e)); - Gramext.Stoken ("", ";")], - Gramext.action - (fun _ (sti : 'str_item) (loc : int * int) -> (sti : 'phrase)); - [Gramext.Stoken ("", "#"); Gramext.Stoken ("LIDENT", ""); - Gramext.Sopt - (Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))); - Gramext.Stoken ("", ";")], - Gramext.action - (fun _ (dp : 'expr option) (n : string) _ (loc : int * int) -> - (MLast.StDir (loc, n, dp) : 'phrase))]]; - Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), - Some (Gramext.Level "simple"), - [None, None, - [[Gramext.Stoken ("QUOTATION", "")], - Gramext.action - (fun (x : string) (loc : int * int) -> - (let x = - try - let i = String.index x ':' in - String.sub x 0 i, - String.sub x (i + 1) (String.length x - i - 1) - with - Not_found -> "", x - in - Pcaml.handle_expr_quotation loc x : - 'expr)); - [Gramext.Stoken ("LOCATE", "")], - Gramext.action - (fun (x : string) (loc : int * int) -> - (let x = - try - let i = String.index x ':' in - int_of_string (String.sub x 0 i), - String.sub x (i + 1) (String.length x - i - 1) - with - Not_found | Failure _ -> 0, x - in - Pcaml.handle_expr_locate loc x : - 'expr))]]; - Grammar.Entry.obj (patt : 'patt Grammar.Entry.e), - Some (Gramext.Level "simple"), - [None, None, - [[Gramext.Stoken ("QUOTATION", "")], - Gramext.action - (fun (x : string) (loc : int * int) -> - (let x = - try - let i = String.index x ':' in - String.sub x 0 i, - String.sub x (i + 1) (String.length x - i - 1) - with - Not_found -> "", x - in - Pcaml.handle_patt_quotation loc x : - 'patt)); - [Gramext.Stoken ("LOCATE", "")], - Gramext.action - (fun (x : string) (loc : int * int) -> - (let x = - try - let i = String.index x ':' in - int_of_string (String.sub x 0 i), - String.sub x (i + 1) (String.length x - i - 1) - with - Not_found | Failure _ -> 0, x - in - Pcaml.handle_patt_locate loc x : - 'patt))]]]);; diff --git a/camlp4/ocaml_src/meta/pa_rp.ml b/camlp4/ocaml_src/meta/pa_rp.ml deleted file mode 100644 index ad743e8708..0000000000 --- a/camlp4/ocaml_src/meta/pa_rp.ml +++ /dev/null @@ -1,641 +0,0 @@ -(* camlp4r pa_extend.cmo q_MLast.cmo *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1998 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* This file has been generated by program: do not edit! *) - -open Pcaml;; - -type spat_comp = - SpTrm of MLast.loc * MLast.patt * MLast.expr option - | SpNtr of MLast.loc * MLast.patt * MLast.expr - | SpStr of MLast.loc * MLast.patt -;; -type sexp_comp = - SeTrm of MLast.loc * MLast.expr - | SeNtr of MLast.loc * MLast.expr -;; - -let strm_n = "strm__";; -let peek_fun loc = - MLast.ExAcc (loc, MLast.ExUid (loc, "Stream"), MLast.ExLid (loc, "peek")) -;; -let junk_fun loc = - MLast.ExAcc (loc, MLast.ExUid (loc, "Stream"), MLast.ExLid (loc, "junk")) -;; - -(* Parsers. *) -(* In syntax generated, many cases are optimisations. *) - -let rec pattern_eq_expression p e = - match p, e with - MLast.PaLid (_, a), MLast.ExLid (_, b) -> a = b - | MLast.PaUid (_, a), MLast.ExUid (_, b) -> a = b - | MLast.PaApp (_, p1, p2), MLast.ExApp (_, e1, e2) -> - pattern_eq_expression p1 e1 && pattern_eq_expression p2 e2 - | _ -> false -;; - -let is_raise e = - match e with - MLast.ExApp (_, MLast.ExLid (_, "raise"), _) -> true - | _ -> false -;; - -let is_raise_failure e = - match e with - MLast.ExApp - (_, MLast.ExLid (_, "raise"), - MLast.ExAcc - (_, MLast.ExUid (_, "Stream"), MLast.ExUid (_, "Failure"))) -> - true - | _ -> false -;; - -let rec handle_failure e = - match e with - MLast.ExTry - (_, te, - [MLast.PaAcc - (_, MLast.PaUid (_, "Stream"), MLast.PaUid (_, "Failure")), None, - e]) -> - handle_failure e - | MLast.ExMat (_, me, pel) -> - handle_failure me && - List.for_all - (function - _, None, e -> handle_failure e - | _ -> false) - pel - | MLast.ExLet (_, false, pel, e) -> - List.for_all (fun (p, e) -> handle_failure e) pel && handle_failure e - | MLast.ExLid (_, _) | MLast.ExInt (_, _) | MLast.ExStr (_, _) | - MLast.ExChr (_, _) | MLast.ExFun (_, _) | MLast.ExUid (_, _) -> - true - | MLast.ExApp (_, MLast.ExLid (_, "raise"), e) -> - begin match e with - MLast.ExAcc - (_, MLast.ExUid (_, "Stream"), MLast.ExUid (_, "Failure")) -> - false - | _ -> true - end - | MLast.ExApp (_, f, x) -> - is_constr_apply f && handle_failure f && handle_failure x - | _ -> false -and is_constr_apply = - function - MLast.ExUid (_, _) -> true - | MLast.ExLid (_, _) -> false - | MLast.ExApp (_, x, _) -> is_constr_apply x - | _ -> false -;; - -let rec subst v e = - let loc = MLast.loc_of_expr e in - match e with - MLast.ExLid (_, x) -> - let x = if x = v then strm_n else x in MLast.ExLid (loc, x) - | MLast.ExUid (_, _) -> e - | MLast.ExInt (_, _) -> e - | MLast.ExChr (_, _) -> e - | MLast.ExStr (_, _) -> e - | MLast.ExAcc (_, _, _) -> e - | MLast.ExLet (_, rf, pel, e) -> - MLast.ExLet (loc, rf, List.map (subst_pe v) pel, subst v e) - | MLast.ExApp (_, e1, e2) -> MLast.ExApp (loc, subst v e1, subst v e2) - | MLast.ExTup (_, el) -> MLast.ExTup (loc, List.map (subst v) el) - | _ -> raise Not_found -and subst_pe v (p, e) = - match p with - MLast.PaLid (_, v') when v <> v' -> p, subst v e - | _ -> raise Not_found -;; - -let stream_pattern_component skont ckont = - function - SpTrm (loc, p, wo) -> - MLast.ExMat - (loc, MLast.ExApp (loc, peek_fun loc, MLast.ExLid (loc, strm_n)), - [MLast.PaApp (loc, MLast.PaUid (loc, "Some"), p), wo, - MLast.ExSeq - (loc, - [MLast.ExApp (loc, junk_fun loc, MLast.ExLid (loc, strm_n)); - skont]); - MLast.PaAny loc, None, ckont]) - | SpNtr (loc, p, e) -> - let e = - match e with - MLast.ExFun - (_, - [MLast.PaTyc - (_, MLast.PaLid (_, v), - MLast.TyApp - (_, - MLast.TyAcc - (_, MLast.TyUid (_, "Stream"), MLast.TyLid (_, "t")), - MLast.TyAny _)), None, e]) - when v = strm_n -> - e - | _ -> MLast.ExApp (loc, e, MLast.ExLid (loc, strm_n)) - in - if pattern_eq_expression p skont then - if is_raise_failure ckont then e - else if handle_failure e then e - else - MLast.ExTry - (loc, e, - [MLast.PaAcc - (loc, MLast.PaUid (loc, "Stream"), - MLast.PaUid (loc, "Failure")), - None, ckont]) - else if is_raise_failure ckont then - MLast.ExLet (loc, false, [p, e], skont) - else if - pattern_eq_expression - (MLast.PaApp (loc, MLast.PaUid (loc, "Some"), p)) skont - then - MLast.ExTry - (loc, MLast.ExApp (loc, MLast.ExUid (loc, "Some"), e), - [MLast.PaAcc - (loc, MLast.PaUid (loc, "Stream"), - MLast.PaUid (loc, "Failure")), - None, ckont]) - else if is_raise ckont then - let tst = - if handle_failure e then e - else - MLast.ExTry - (loc, e, - [MLast.PaAcc - (loc, MLast.PaUid (loc, "Stream"), - MLast.PaUid (loc, "Failure")), - None, ckont]) - in - MLast.ExLet (loc, false, [p, tst], skont) - else - MLast.ExMat - (loc, - MLast.ExTry - (loc, MLast.ExApp (loc, MLast.ExUid (loc, "Some"), e), - [MLast.PaAcc - (loc, MLast.PaUid (loc, "Stream"), - MLast.PaUid (loc, "Failure")), - None, MLast.ExUid (loc, "None")]), - [MLast.PaApp (loc, MLast.PaUid (loc, "Some"), p), None, skont; - MLast.PaAny loc, None, ckont]) - | SpStr (loc, p) -> - try - match p with - MLast.PaLid (_, v) -> subst v skont - | _ -> raise Not_found - with - Not_found -> - MLast.ExLet (loc, false, [p, MLast.ExLid (loc, strm_n)], skont) -;; - -let rec stream_pattern loc epo e ekont = - function - [] -> - begin match epo with - Some ep -> - MLast.ExLet - (loc, false, - [ep, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "Stream"), - MLast.ExLid (loc, "count")), - MLast.ExLid (loc, strm_n))], - e) - | _ -> e - end - | (spc, err) :: spcl -> - let skont = - let ekont err = - let str = - match err with - Some estr -> estr - | _ -> MLast.ExStr (loc, "") - in - MLast.ExApp - (loc, MLast.ExLid (loc, "raise"), - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "Stream"), - MLast.ExUid (loc, "Error")), - str)) - in - stream_pattern loc epo e ekont spcl - in - let ckont = ekont err in stream_pattern_component skont ckont spc -;; - -let stream_patterns_term loc ekont tspel = - let pel = - List.map - (fun (p, w, loc, spcl, epo, e) -> - let p = MLast.PaApp (loc, MLast.PaUid (loc, "Some"), p) in - let e = - let ekont err = - let str = - match err with - Some estr -> estr - | _ -> MLast.ExStr (loc, "") - in - MLast.ExApp - (loc, MLast.ExLid (loc, "raise"), - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "Stream"), - MLast.ExUid (loc, "Error")), - str)) - in - let skont = stream_pattern loc epo e ekont spcl in - MLast.ExSeq - (loc, - [MLast.ExApp (loc, junk_fun loc, MLast.ExLid (loc, strm_n)); - skont]) - in - p, w, e) - tspel - in - let pel = pel @ [MLast.PaAny loc, None, ekont ()] in - MLast.ExMat - (loc, MLast.ExApp (loc, peek_fun loc, MLast.ExLid (loc, strm_n)), pel) -;; - -let rec group_terms = - function - ((SpTrm (loc, p, w), None) :: spcl, epo, e) :: spel -> - let (tspel, spel) = group_terms spel in - (p, w, loc, spcl, epo, e) :: tspel, spel - | spel -> [], spel -;; - -let rec parser_cases loc = - function - [] -> - MLast.ExApp - (loc, MLast.ExLid (loc, "raise"), - MLast.ExAcc - (loc, MLast.ExUid (loc, "Stream"), MLast.ExUid (loc, "Failure"))) - | spel -> - match group_terms spel with - [], (spcl, epo, e) :: spel -> - stream_pattern loc epo e (fun _ -> parser_cases loc spel) spcl - | tspel, spel -> - stream_patterns_term loc (fun _ -> parser_cases loc spel) tspel -;; - -let cparser loc bpo pc = - let e = parser_cases loc pc in - let e = - match bpo with - Some bp -> - MLast.ExLet - (loc, false, - [bp, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "Stream"), - MLast.ExLid (loc, "count")), - MLast.ExLid (loc, strm_n))], - e) - | None -> e - in - let p = - MLast.PaTyc - (loc, MLast.PaLid (loc, strm_n), - MLast.TyApp - (loc, - MLast.TyAcc - (loc, MLast.TyUid (loc, "Stream"), MLast.TyLid (loc, "t")), - MLast.TyAny loc)) - in - MLast.ExFun (loc, [p, None, e]) -;; - -let cparser_match loc me bpo pc = - let pc = parser_cases loc pc in - let e = - match bpo with - Some bp -> - MLast.ExLet - (loc, false, - [bp, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "Stream"), - MLast.ExLid (loc, "count")), - MLast.ExLid (loc, strm_n))], - pc) - | None -> pc - in - match me with - MLast.ExLid (_, x) when x = strm_n -> e - | _ -> - MLast.ExLet - (loc, false, - [MLast.PaTyc - (loc, MLast.PaLid (loc, strm_n), - MLast.TyApp - (loc, - MLast.TyAcc - (loc, MLast.TyUid (loc, "Stream"), MLast.TyLid (loc, "t")), - MLast.TyAny loc)), - me], - e) -;; - -(* streams *) - -let rec not_computing = - function - MLast.ExLid (_, _) | MLast.ExUid (_, _) | MLast.ExInt (_, _) | - MLast.ExFlo (_, _) | MLast.ExChr (_, _) | MLast.ExStr (_, _) -> - true - | MLast.ExApp (_, x, y) -> is_cons_apply_not_computing x && not_computing y - | _ -> false -and is_cons_apply_not_computing = - function - MLast.ExUid (_, _) -> true - | MLast.ExLid (_, _) -> false - | MLast.ExApp (_, x, y) -> is_cons_apply_not_computing x && not_computing y - | _ -> false -;; - -let slazy loc e = - match e with - MLast.ExApp (_, f, MLast.ExUid (_, "()")) -> - begin match f with - MLast.ExLid (_, _) -> f - | _ -> MLast.ExFun (loc, [MLast.PaAny loc, None, e]) - end - | _ -> MLast.ExFun (loc, [MLast.PaAny loc, None, e]) -;; - -let rec cstream gloc = - function - [] -> - let loc = gloc in - MLast.ExAcc - (loc, MLast.ExUid (loc, "Stream"), MLast.ExLid (loc, "sempty")) - | [SeTrm (loc, e)] -> - if not_computing e then - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "Stream"), MLast.ExLid (loc, "ising")), - e) - else - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "Stream"), MLast.ExLid (loc, "lsing")), - slazy loc e) - | SeTrm (loc, e) :: secl -> - if not_computing e then - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "Stream"), - MLast.ExLid (loc, "icons")), - e), - cstream gloc secl) - else - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "Stream"), - MLast.ExLid (loc, "lcons")), - slazy loc e), - cstream gloc secl) - | [SeNtr (loc, e)] -> - if not_computing e then e - else - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "Stream"), MLast.ExLid (loc, "slazy")), - slazy loc e) - | SeNtr (loc, e) :: secl -> - if not_computing e then - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "Stream"), MLast.ExLid (loc, "iapp")), - e), - cstream gloc secl) - else - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "Stream"), MLast.ExLid (loc, "lapp")), - slazy loc e), - cstream gloc secl) -;; - -(* Syntax extensions in Revised Syntax grammar *) - -Grammar.extend - (let _ = (expr : 'expr Grammar.Entry.e) in - let grammar_entry_create s = - Grammar.Entry.create (Grammar.of_entry expr) s - in - let parser_case : 'parser_case Grammar.Entry.e = - grammar_entry_create "parser_case" - and stream_patt : 'stream_patt Grammar.Entry.e = - grammar_entry_create "stream_patt" - and stream_patt_comp_err : 'stream_patt_comp_err Grammar.Entry.e = - grammar_entry_create "stream_patt_comp_err" - and stream_patt_comp : 'stream_patt_comp Grammar.Entry.e = - grammar_entry_create "stream_patt_comp" - and ipatt : 'ipatt Grammar.Entry.e = grammar_entry_create "ipatt" - and stream_expr_comp : 'stream_expr_comp Grammar.Entry.e = - grammar_entry_create "stream_expr_comp" - in - [Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), - Some (Gramext.Level "top"), - [None, None, - [[Gramext.Stoken ("", "match"); Gramext.Sself; - Gramext.Stoken ("", "with"); Gramext.Stoken ("", "parser"); - Gramext.Sopt - (Gramext.Snterm - (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e))); - Gramext.Snterm - (Grammar.Entry.obj (parser_case : 'parser_case Grammar.Entry.e))], - Gramext.action - (fun (pc : 'parser_case) (po : 'ipatt option) _ _ (e : 'expr) _ - (loc : int * int) -> - (cparser_match loc e po [pc] : 'expr)); - [Gramext.Stoken ("", "match"); Gramext.Sself; - Gramext.Stoken ("", "with"); Gramext.Stoken ("", "parser"); - Gramext.Sopt - (Gramext.Snterm - (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e))); - Gramext.Stoken ("", "["); - Gramext.Slist0sep - (Gramext.Snterm - (Grammar.Entry.obj (parser_case : 'parser_case Grammar.Entry.e)), - Gramext.Stoken ("", "|")); - Gramext.Stoken ("", "]")], - Gramext.action - (fun _ (pcl : 'parser_case list) _ (po : 'ipatt option) _ _ - (e : 'expr) _ (loc : int * int) -> - (cparser_match loc e po pcl : 'expr)); - [Gramext.Stoken ("", "parser"); - Gramext.Sopt - (Gramext.Snterm - (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e))); - Gramext.Snterm - (Grammar.Entry.obj (parser_case : 'parser_case Grammar.Entry.e))], - Gramext.action - (fun (pc : 'parser_case) (po : 'ipatt option) _ (loc : int * int) -> - (cparser loc po [pc] : 'expr)); - [Gramext.Stoken ("", "parser"); - Gramext.Sopt - (Gramext.Snterm - (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e))); - Gramext.Stoken ("", "["); - Gramext.Slist0sep - (Gramext.Snterm - (Grammar.Entry.obj (parser_case : 'parser_case Grammar.Entry.e)), - Gramext.Stoken ("", "|")); - Gramext.Stoken ("", "]")], - Gramext.action - (fun _ (pcl : 'parser_case list) _ (po : 'ipatt option) _ - (loc : int * int) -> - (cparser loc po pcl : 'expr))]]; - Grammar.Entry.obj (parser_case : 'parser_case Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "[:"); - Gramext.Snterm - (Grammar.Entry.obj (stream_patt : 'stream_patt Grammar.Entry.e)); - Gramext.Stoken ("", ":]"); - Gramext.Sopt - (Gramext.Snterm - (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e))); - Gramext.Stoken ("", "->"); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) _ (po : 'ipatt option) _ (sp : 'stream_patt) _ - (loc : int * int) -> - (sp, po, e : 'parser_case))]]; - Grammar.Entry.obj (stream_patt : 'stream_patt Grammar.Entry.e), None, - [None, None, - [[], Gramext.action (fun (loc : int * int) -> ([] : 'stream_patt)); - [Gramext.Snterm - (Grammar.Entry.obj - (stream_patt_comp : 'stream_patt_comp Grammar.Entry.e)); - Gramext.Stoken ("", ";"); - Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj - (stream_patt_comp_err : - 'stream_patt_comp_err Grammar.Entry.e)), - Gramext.Stoken ("", ";"))], - Gramext.action - (fun (sp : 'stream_patt_comp_err list) _ (spc : 'stream_patt_comp) - (loc : int * int) -> - ((spc, None) :: sp : 'stream_patt)); - [Gramext.Snterm - (Grammar.Entry.obj - (stream_patt_comp : 'stream_patt_comp Grammar.Entry.e))], - Gramext.action - (fun (spc : 'stream_patt_comp) (loc : int * int) -> - ([spc, None] : 'stream_patt))]]; - Grammar.Entry.obj - (stream_patt_comp_err : 'stream_patt_comp_err Grammar.Entry.e), - None, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj - (stream_patt_comp : 'stream_patt_comp Grammar.Entry.e)); - Gramext.Sopt - (Gramext.srules - [[Gramext.Stoken ("", "?"); - Gramext.Snterm - (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) _ (loc : int * int) -> (e : 'e__1))])], - Gramext.action - (fun (eo : 'e__1 option) (spc : 'stream_patt_comp) - (loc : int * int) -> - (spc, eo : 'stream_patt_comp_err))]]; - Grammar.Entry.obj (stream_patt_comp : 'stream_patt_comp Grammar.Entry.e), - None, - [None, None, - [[Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e))], - Gramext.action - (fun (p : 'patt) (loc : int * int) -> - (SpStr (loc, p) : 'stream_patt_comp)); - [Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) _ (p : 'patt) (loc : int * int) -> - (SpNtr (loc, p, e) : 'stream_patt_comp)); - [Gramext.Stoken ("", "`"); - Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e)); - Gramext.Sopt - (Gramext.srules - [[Gramext.Stoken ("", "when"); - Gramext.Snterm - (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) _ (loc : int * int) -> (e : 'e__2))])], - Gramext.action - (fun (eo : 'e__2 option) (p : 'patt) _ (loc : int * int) -> - (SpTrm (loc, p, eo) : 'stream_patt_comp))]]; - Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("LIDENT", "")], - Gramext.action - (fun (i : string) (loc : int * int) -> - (MLast.PaLid (loc, i) : 'ipatt))]]; - Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), - Some (Gramext.Level "simple"), - [None, None, - [[Gramext.Stoken ("", "[:"); - Gramext.Slist0sep - (Gramext.Snterm - (Grammar.Entry.obj - (stream_expr_comp : 'stream_expr_comp Grammar.Entry.e)), - Gramext.Stoken ("", ";")); - Gramext.Stoken ("", ":]")], - Gramext.action - (fun _ (se : 'stream_expr_comp list) _ (loc : int * int) -> - (cstream loc se : 'expr))]]; - Grammar.Entry.obj (stream_expr_comp : 'stream_expr_comp Grammar.Entry.e), - None, - [None, None, - [[Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) (loc : int * int) -> - (SeNtr (loc, e) : 'stream_expr_comp)); - [Gramext.Stoken ("", "`"); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) _ (loc : int * int) -> - (SeTrm (loc, e) : 'stream_expr_comp))]]]);; diff --git a/camlp4/ocaml_src/meta/pr_dump.ml b/camlp4/ocaml_src/meta/pr_dump.ml deleted file mode 100644 index db42285310..0000000000 --- a/camlp4/ocaml_src/meta/pr_dump.ml +++ /dev/null @@ -1,48 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2001 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* This file has been generated by program: do not edit! *) - -let open_out_file () = - match !(Pcaml.output_file) with - Some f -> open_out_bin f - | None -> set_binary_mode_out stdout true; stdout -;; - -let interf ast = - let pt = Ast2pt.interf (List.map fst ast) in - let oc = open_out_file () in - let fname = !(Pcaml.input_file) in - output_string oc Config.ast_intf_magic_number; - output_value oc (if fname = "-" then "" else fname); - output_value oc pt; - flush oc; - match !(Pcaml.output_file) with - Some _ -> close_out oc - | None -> () -;; - -let implem ast = - let pt = Ast2pt.implem (List.map fst ast) in - let oc = open_out_file () in - let fname = !(Pcaml.input_file) in - output_string oc Config.ast_impl_magic_number; - output_value oc (if fname = "-" then "" else fname); - output_value oc pt; - flush oc; - match !(Pcaml.output_file) with - Some _ -> close_out oc - | None -> () -;; - -Pcaml.print_interf := interf;; -Pcaml.print_implem := implem;; diff --git a/camlp4/ocaml_src/meta/q_MLast.ml b/camlp4/ocaml_src/meta/q_MLast.ml deleted file mode 100644 index 70540af642..0000000000 --- a/camlp4/ocaml_src/meta/q_MLast.ml +++ /dev/null @@ -1,4700 +0,0 @@ -(* camlp4r pa_extend.cmo pa_extend_m.cmo q_MLast.cmo *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* This file has been generated by program: do not edit! *) - -let gram = Grammar.gcreate (Plexer.gmake ());; - -module Qast = - struct - type t = - Node of string * t list - | List of t list - | Tuple of t list - | Option of t option - | Int of string - | Str of string - | Bool of bool - | Cons of t * t - | Apply of string * t list - | Record of (string * t) list - | Loc - | Antiquot of MLast.loc * string - ;; - let loc = 0, 0;; - let rec to_expr = - function - Node (n, al) -> - List.fold_left (fun e a -> MLast.ExApp (loc, e, to_expr a)) - (MLast.ExAcc - (loc, MLast.ExUid (loc, "MLast"), MLast.ExUid (loc, n))) - al - | List al -> - List.fold_right - (fun a e -> - MLast.ExApp - (loc, MLast.ExApp (loc, MLast.ExUid (loc, "::"), to_expr a), - e)) - al (MLast.ExUid (loc, "[]")) - | Tuple al -> MLast.ExTup (loc, List.map to_expr al) - | Option None -> MLast.ExUid (loc, "None") - | Option (Some a) -> - MLast.ExApp (loc, MLast.ExUid (loc, "Some"), to_expr a) - | Int s -> MLast.ExInt (loc, s) - | Str s -> MLast.ExStr (loc, s) - | Bool true -> MLast.ExUid (loc, "True") - | Bool false -> MLast.ExUid (loc, "False") - | Cons (a1, a2) -> - MLast.ExApp - (loc, MLast.ExApp (loc, MLast.ExUid (loc, "::"), to_expr a1), - to_expr a2) - | Apply (f, al) -> - List.fold_left (fun e a -> MLast.ExApp (loc, e, to_expr a)) - (MLast.ExLid (loc, f)) al - | Record lal -> MLast.ExRec (loc, List.map to_expr_label lal, None) - | Loc -> MLast.ExLid (loc, !(Stdpp.loc_name)) - | Antiquot (loc, s) -> - let e = - try Grammar.Entry.parse Pcaml.expr_eoi (Stream.of_string s) with - Stdpp.Exc_located ((bp, ep), exc) -> - raise (Stdpp.Exc_located ((fst loc + bp, fst loc + ep), exc)) - in - MLast.ExAnt (loc, e) - and to_expr_label (l, a) = - MLast.PaAcc (loc, MLast.PaUid (loc, "MLast"), MLast.PaLid (loc, l)), - to_expr a - ;; - let rec to_patt = - function - Node (n, al) -> - List.fold_left (fun e a -> MLast.PaApp (loc, e, to_patt a)) - (MLast.PaAcc - (loc, MLast.PaUid (loc, "MLast"), MLast.PaUid (loc, n))) - al - | List al -> - List.fold_right - (fun a p -> - MLast.PaApp - (loc, MLast.PaApp (loc, MLast.PaUid (loc, "::"), to_patt a), - p)) - al (MLast.PaUid (loc, "[]")) - | Tuple al -> MLast.PaTup (loc, List.map to_patt al) - | Option None -> MLast.PaUid (loc, "None") - | Option (Some a) -> - MLast.PaApp (loc, MLast.PaUid (loc, "Some"), to_patt a) - | Int s -> MLast.PaInt (loc, s) - | Str s -> MLast.PaStr (loc, s) - | Bool true -> MLast.PaUid (loc, "True") - | Bool false -> MLast.PaUid (loc, "False") - | Cons (a1, a2) -> - MLast.PaApp - (loc, MLast.PaApp (loc, MLast.PaUid (loc, "::"), to_patt a1), - to_patt a2) - | Apply (_, _) -> failwith "bad pattern" - | Record lal -> MLast.PaRec (loc, List.map to_patt_label lal) - | Loc -> MLast.PaAny loc - | Antiquot (loc, s) -> - let p = - try Grammar.Entry.parse Pcaml.patt_eoi (Stream.of_string s) with - Stdpp.Exc_located ((bp, ep), exc) -> - raise (Stdpp.Exc_located ((fst loc + bp, fst loc + ep), exc)) - in - MLast.PaAnt (loc, p) - and to_patt_label (l, a) = - MLast.PaAcc (loc, MLast.PaUid (loc, "MLast"), MLast.PaLid (loc, l)), - to_patt a - ;; - end -;; - -let antiquot k (bp, ep) x = - let shift = - if k = "" then String.length "$" - else String.length "$" + String.length k + String.length ":" - in - Qast.Antiquot ((shift + bp, shift + ep), x) -;; - -let sig_item = Grammar.Entry.create gram "signature item";; -let str_item = Grammar.Entry.create gram "structure item";; -let ctyp = Grammar.Entry.create gram "type";; -let patt = Grammar.Entry.create gram "pattern";; -let expr = Grammar.Entry.create gram "expression";; - -let module_type = Grammar.Entry.create gram "module type";; -let module_expr = Grammar.Entry.create gram "module expression";; - -let class_type = Grammar.Entry.create gram "class type";; -let class_expr = Grammar.Entry.create gram "class expr";; -let class_sig_item = Grammar.Entry.create gram "class signature item";; -let class_str_item = Grammar.Entry.create gram "class structure item";; - -let ipatt = Grammar.Entry.create gram "ipatt";; -let let_binding = Grammar.Entry.create gram "let_binding";; -let type_declaration = Grammar.Entry.create gram "type_declaration";; -let with_constr = Grammar.Entry.create gram "with_constr";; -let row_field = Grammar.Entry.create gram "row_field";; - -let a_list = Grammar.Entry.create gram "a_list";; -let a_opt = Grammar.Entry.create gram "a_opt";; -let a_UIDENT = Grammar.Entry.create gram "a_UIDENT";; -let a_LIDENT = Grammar.Entry.create gram "a_LIDENT";; -let a_INT = Grammar.Entry.create gram "a_INT";; -let a_FLOAT = Grammar.Entry.create gram "a_FLOAT";; -let a_STRING = Grammar.Entry.create gram "a_STRING";; -let a_CHAR = Grammar.Entry.create gram "a_CHAR";; -let a_TILDEIDENT = Grammar.Entry.create gram "a_TILDEIDENT";; -let a_LABEL = Grammar.Entry.create gram "a_LABEL";; -let a_QUESTIONIDENT = Grammar.Entry.create gram "a_QUESTIONIDENT";; -let a_OPTLABEL = Grammar.Entry.create gram "a_OPTLABEL";; - -let o2b = - function - Qast.Option (Some _) -> Qast.Bool true - | Qast.Option None -> Qast.Bool false - | x -> x -;; - -let mksequence _ = - function - Qast.List [e] -> e - | el -> Qast.Node ("ExSeq", [Qast.Loc; el]) -;; - -let mkmatchcase _ p aso w e = - let p = - match aso with - Qast.Option (Some p2) -> Qast.Node ("PaAli", [Qast.Loc; p; p2]) - | Qast.Option None -> p - | _ -> Qast.Node ("PaAli", [Qast.Loc; p; aso]) - in - Qast.Tuple [p; w; e] -;; - -let neg_string n = - let len = String.length n in - if len > 0 && n.[0] = '-' then String.sub n 1 (len - 1) else "-" ^ n -;; - -let mkumin _ f arg = - match arg with - Qast.Node ("ExInt", [Qast.Loc; Qast.Str n]) when int_of_string n > 0 -> - let n = neg_string n in Qast.Node ("ExInt", [Qast.Loc; Qast.Str n]) - | Qast.Node ("ExFlo", [Qast.Loc; Qast.Str n]) - when float_of_string n > 0.0 -> - let n = neg_string n in Qast.Node ("ExFlo", [Qast.Loc; Qast.Str n]) - | _ -> - match f with - Qast.Str f -> - let f = "~" ^ f in - Qast.Node - ("ExApp", - [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str f]); arg]) - | _ -> assert false -;; - -let mkuminpat _ f is_int s = - let s = - match s with - Qast.Str s -> Qast.Str (neg_string s) - | s -> failwith "bad unary minus" - in - match is_int with - Qast.Bool true -> Qast.Node ("PaInt", [Qast.Loc; s]) - | Qast.Bool false -> Qast.Node ("PaFlo", [Qast.Loc; s]) - | _ -> assert false -;; - -let mklistexp _ last = - let rec loop top = - function - Qast.List [] -> - begin match last with - Qast.Option (Some e) -> e - | Qast.Option None -> Qast.Node ("ExUid", [Qast.Loc; Qast.Str "[]"]) - | a -> a - end - | Qast.List (e1 :: el) -> - Qast.Node - ("ExApp", - [Qast.Loc; - Qast.Node - ("ExApp", - [Qast.Loc; Qast.Node ("ExUid", [Qast.Loc; Qast.Str "::"]); - e1]); - loop false (Qast.List el)]) - | a -> a - in - loop true -;; - -let mklistpat _ last = - let rec loop top = - function - Qast.List [] -> - begin match last with - Qast.Option (Some p) -> p - | Qast.Option None -> Qast.Node ("PaUid", [Qast.Loc; Qast.Str "[]"]) - | a -> a - end - | Qast.List (p1 :: pl) -> - Qast.Node - ("PaApp", - [Qast.Loc; - Qast.Node - ("PaApp", - [Qast.Loc; Qast.Node ("PaUid", [Qast.Loc; Qast.Str "::"]); - p1]); - loop false (Qast.List pl)]) - | a -> a - in - loop true -;; - -let mkexprident loc i j = - let rec loop m = - function - Qast.Node ("ExAcc", [_; x; y]) -> - loop (Qast.Node ("ExAcc", [Qast.Loc; m; x])) y - | e -> Qast.Node ("ExAcc", [Qast.Loc; m; e]) - in - loop (Qast.Node ("ExUid", [Qast.Loc; i])) j -;; - -let mkassert _ e = - match e with - Qast.Node ("ExUid", [_; Qast.Str "False"]) -> - Qast.Node ("ExAsf", [Qast.Loc]) - | _ -> Qast.Node ("ExAsr", [Qast.Loc; e]) -;; - -let append_elem el e = Qast.Apply ("@", [el; Qast.List [e]]);; - -let not_yet_warned_antiq = ref true;; -let warn_antiq loc vers = - if !not_yet_warned_antiq then - begin - not_yet_warned_antiq := false; - !(Pcaml.warning) loc - (Printf.sprintf - "use of antiquotation syntax deprecated since version %s" vers) - end -;; - -let not_yet_warned_variant = ref true;; -let warn_variant _ = - if !not_yet_warned_variant then - begin - not_yet_warned_variant := false; - !(Pcaml.warning) (0, 1) - (Printf.sprintf - "use of syntax of variants types deprecated since version 3.05") - end -;; - -let not_yet_warned_seq = ref true;; -let warn_sequence _ = - if !not_yet_warned_seq then - begin - not_yet_warned_seq := false; - !(Pcaml.warning) (0, 1) - (Printf.sprintf - "use of syntax of sequences deprecated since version 3.01.1") - end -;; - -Grammar.extend - (let _ = (sig_item : 'sig_item Grammar.Entry.e) - and _ = (str_item : 'str_item Grammar.Entry.e) - and _ = (ctyp : 'ctyp Grammar.Entry.e) - and _ = (patt : 'patt Grammar.Entry.e) - and _ = (expr : 'expr Grammar.Entry.e) - and _ = (module_type : 'module_type Grammar.Entry.e) - and _ = (module_expr : 'module_expr Grammar.Entry.e) - and _ = (class_type : 'class_type Grammar.Entry.e) - and _ = (class_expr : 'class_expr Grammar.Entry.e) - and _ = (class_sig_item : 'class_sig_item Grammar.Entry.e) - and _ = (class_str_item : 'class_str_item Grammar.Entry.e) - and _ = (let_binding : 'let_binding Grammar.Entry.e) - and _ = (type_declaration : 'type_declaration Grammar.Entry.e) - and _ = (ipatt : 'ipatt Grammar.Entry.e) - and _ = (with_constr : 'with_constr Grammar.Entry.e) - and _ = (row_field : 'row_field Grammar.Entry.e) in - let grammar_entry_create s = - Grammar.Entry.create (Grammar.of_entry sig_item) s - in - let rebind_exn : 'rebind_exn Grammar.Entry.e = - grammar_entry_create "rebind_exn" - and module_binding : 'module_binding Grammar.Entry.e = - grammar_entry_create "module_binding" - and module_rec_binding : 'module_rec_binding Grammar.Entry.e = - grammar_entry_create "module_rec_binding" - and module_declaration : 'module_declaration Grammar.Entry.e = - grammar_entry_create "module_declaration" - and module_rec_declaration : 'module_rec_declaration Grammar.Entry.e = - grammar_entry_create "module_rec_declaration" - and cons_expr_opt : 'cons_expr_opt Grammar.Entry.e = - grammar_entry_create "cons_expr_opt" - and dummy : 'dummy Grammar.Entry.e = grammar_entry_create "dummy" - and fun_binding : 'fun_binding Grammar.Entry.e = - grammar_entry_create "fun_binding" - and match_case : 'match_case Grammar.Entry.e = - grammar_entry_create "match_case" - and as_patt_opt : 'as_patt_opt Grammar.Entry.e = - grammar_entry_create "as_patt_opt" - and label_expr : 'label_expr Grammar.Entry.e = - grammar_entry_create "label_expr" - and fun_def : 'fun_def Grammar.Entry.e = grammar_entry_create "fun_def" - and cons_patt_opt : 'cons_patt_opt Grammar.Entry.e = - grammar_entry_create "cons_patt_opt" - and label_patt : 'label_patt Grammar.Entry.e = - grammar_entry_create "label_patt" - and label_ipatt : 'label_ipatt Grammar.Entry.e = - grammar_entry_create "label_ipatt" - and type_patt : 'type_patt Grammar.Entry.e = - grammar_entry_create "type_patt" - and constrain : 'constrain Grammar.Entry.e = - grammar_entry_create "constrain" - and type_parameter : 'type_parameter Grammar.Entry.e = - grammar_entry_create "type_parameter" - and constructor_declaration : 'constructor_declaration Grammar.Entry.e = - grammar_entry_create "constructor_declaration" - and label_declaration : 'label_declaration Grammar.Entry.e = - grammar_entry_create "label_declaration" - and ident : 'ident Grammar.Entry.e = grammar_entry_create "ident" - and class_declaration : 'class_declaration Grammar.Entry.e = - grammar_entry_create "class_declaration" - and class_fun_binding : 'class_fun_binding Grammar.Entry.e = - grammar_entry_create "class_fun_binding" - and class_type_parameters : 'class_type_parameters Grammar.Entry.e = - grammar_entry_create "class_type_parameters" - and class_fun_def : 'class_fun_def Grammar.Entry.e = - grammar_entry_create "class_fun_def" - and class_structure : 'class_structure Grammar.Entry.e = - grammar_entry_create "class_structure" - and class_self_patt : 'class_self_patt Grammar.Entry.e = - grammar_entry_create "class_self_patt" - and as_lident : 'as_lident Grammar.Entry.e = - grammar_entry_create "as_lident" - and polyt : 'polyt Grammar.Entry.e = grammar_entry_create "polyt" - and cvalue_binding : 'cvalue_binding Grammar.Entry.e = - grammar_entry_create "cvalue_binding" - and label : 'label Grammar.Entry.e = grammar_entry_create "label" - and class_self_type : 'class_self_type Grammar.Entry.e = - grammar_entry_create "class_self_type" - and class_description : 'class_description Grammar.Entry.e = - grammar_entry_create "class_description" - and class_type_declaration : 'class_type_declaration Grammar.Entry.e = - grammar_entry_create "class_type_declaration" - and field_expr : 'field_expr Grammar.Entry.e = - grammar_entry_create "field_expr" - and field : 'field Grammar.Entry.e = grammar_entry_create "field" - and typevar : 'typevar Grammar.Entry.e = grammar_entry_create "typevar" - and row_field_list : 'row_field_list Grammar.Entry.e = - grammar_entry_create "row_field_list" - and name_tag : 'name_tag Grammar.Entry.e = grammar_entry_create "name_tag" - and patt_tcon : 'patt_tcon Grammar.Entry.e = - grammar_entry_create "patt_tcon" - and ipatt_tcon : 'ipatt_tcon Grammar.Entry.e = - grammar_entry_create "ipatt_tcon" - and eq_expr : 'eq_expr Grammar.Entry.e = grammar_entry_create "eq_expr" - and warning_variant : 'warning_variant Grammar.Entry.e = - grammar_entry_create "warning_variant" - and warning_sequence : 'warning_sequence Grammar.Entry.e = - grammar_entry_create "warning_sequence" - and sequence : 'sequence Grammar.Entry.e = grammar_entry_create "sequence" - and expr_ident : 'expr_ident Grammar.Entry.e = - grammar_entry_create "expr_ident" - and patt_label_ident : 'patt_label_ident Grammar.Entry.e = - grammar_entry_create "patt_label_ident" - and when_expr_opt : 'when_expr_opt Grammar.Entry.e = - grammar_entry_create "when_expr_opt" - and mod_ident : 'mod_ident Grammar.Entry.e = - grammar_entry_create "mod_ident" - and clty_longident : 'clty_longident Grammar.Entry.e = - grammar_entry_create "clty_longident" - and class_longident : 'class_longident Grammar.Entry.e = - grammar_entry_create "class_longident" - and direction_flag : 'direction_flag Grammar.Entry.e = - grammar_entry_create "direction_flag" - in - [Grammar.Entry.obj (module_expr : 'module_expr Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "struct"); - Gramext.srules - [[Gramext.Slist0 - (Gramext.srules - [[Gramext.Snterm - (Grammar.Entry.obj - (str_item : 'str_item Grammar.Entry.e)); - Gramext.Stoken ("", ";")], - Gramext.action - (fun _ (s : 'str_item) (loc : int * int) -> - (s : 'e__1))])], - Gramext.action - (fun (a : 'e__1 list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]; - Gramext.Stoken ("", "end")], - Gramext.action - (fun _ (st : 'a_list) _ (loc : int * int) -> - (Qast.Node ("MeStr", [Qast.Loc; st]) : 'module_expr)); - [Gramext.Stoken ("", "functor"); Gramext.Stoken ("", "("); - Gramext.Snterm - (Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e)); - Gramext.Stoken ("", ":"); - Gramext.Snterm - (Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e)); - Gramext.Stoken ("", ")"); Gramext.Stoken ("", "->"); Gramext.Sself], - Gramext.action - (fun (me : 'module_expr) _ _ (t : 'module_type) _ (i : 'a_UIDENT) _ _ - (loc : int * int) -> - (Qast.Node ("MeFun", [Qast.Loc; i; t; me]) : 'module_expr))]; - None, None, - [[Gramext.Sself; Gramext.Sself], - Gramext.action - (fun (me2 : 'module_expr) (me1 : 'module_expr) (loc : int * int) -> - (Qast.Node ("MeApp", [Qast.Loc; me1; me2]) : 'module_expr))]; - None, None, - [[Gramext.Sself; Gramext.Stoken ("", "."); Gramext.Sself], - Gramext.action - (fun (me2 : 'module_expr) _ (me1 : 'module_expr) (loc : int * int) -> - (Qast.Node ("MeAcc", [Qast.Loc; me1; me2]) : 'module_expr))]; - Some "simple", None, - [[Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (me : 'module_expr) _ (loc : int * int) -> - (me : 'module_expr)); - [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ":"); - Gramext.Snterm - (Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e)); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (mt : 'module_type) _ (me : 'module_expr) _ - (loc : int * int) -> - (Qast.Node ("MeTyc", [Qast.Loc; me; mt]) : 'module_expr)); - [Gramext.Snterm - (Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e))], - Gramext.action - (fun (i : 'a_UIDENT) (loc : int * int) -> - (Qast.Node ("MeUid", [Qast.Loc; i]) : 'module_expr))]]; - Grammar.Entry.obj (str_item : 'str_item Grammar.Entry.e), None, - [Some "top", None, - [[Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) (loc : int * int) -> - (Qast.Node ("StExp", [Qast.Loc; e]) : 'str_item)); - [Gramext.Stoken ("", "value"); - Gramext.srules - [[Gramext.Sopt - (Gramext.srules - [[Gramext.Stoken ("", "rec")], - Gramext.action - (fun (x : string) (loc : int * int) -> - (Qast.Str x : 'e__3))])], - Gramext.action - (fun (a : 'e__3 option) (loc : int * int) -> - (Qast.Option a : 'a_opt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_opt) (loc : int * int) -> (a : 'a_opt))]; - Gramext.srules - [[Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj - (let_binding : 'let_binding Grammar.Entry.e)), - Gramext.Stoken ("", "and"))], - Gramext.action - (fun (a : 'let_binding list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]], - Gramext.action - (fun (l : 'a_list) (r : 'a_opt) _ (loc : int * int) -> - (Qast.Node ("StVal", [Qast.Loc; o2b r; l]) : 'str_item)); - [Gramext.Stoken ("", "type"); - Gramext.srules - [[Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj - (type_declaration : 'type_declaration Grammar.Entry.e)), - Gramext.Stoken ("", "and"))], - Gramext.action - (fun (a : 'type_declaration list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]], - Gramext.action - (fun (tdl : 'a_list) _ (loc : int * int) -> - (Qast.Node ("StTyp", [Qast.Loc; tdl]) : 'str_item)); - [Gramext.Stoken ("", "open"); - Gramext.Snterm - (Grammar.Entry.obj (mod_ident : 'mod_ident Grammar.Entry.e))], - Gramext.action - (fun (i : 'mod_ident) _ (loc : int * int) -> - (Qast.Node ("StOpn", [Qast.Loc; i]) : 'str_item)); - [Gramext.Stoken ("", "module"); Gramext.Stoken ("", "type"); - Gramext.Snterm - (Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm - (Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e))], - Gramext.action - (fun (mt : 'module_type) _ (i : 'a_UIDENT) _ _ (loc : int * int) -> - (Qast.Node ("StMty", [Qast.Loc; i; mt]) : 'str_item)); - [Gramext.Stoken ("", "module"); Gramext.Stoken ("", "rec"); - Gramext.srules - [[Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj - (module_rec_binding : - 'module_rec_binding Grammar.Entry.e)), - Gramext.Stoken ("", "and"))], - Gramext.action - (fun (a : 'module_rec_binding list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]], - Gramext.action - (fun (nmtmes : 'a_list) _ _ (loc : int * int) -> - (Qast.Node ("StRecMod", [Qast.Loc; nmtmes]) : 'str_item)); - [Gramext.Stoken ("", "module"); - Gramext.Snterm - (Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e)); - Gramext.Snterm - (Grammar.Entry.obj - (module_binding : 'module_binding Grammar.Entry.e))], - Gramext.action - (fun (mb : 'module_binding) (i : 'a_UIDENT) _ (loc : int * int) -> - (Qast.Node ("StMod", [Qast.Loc; i; mb]) : 'str_item)); - [Gramext.Stoken ("", "include"); - Gramext.Snterm - (Grammar.Entry.obj (module_expr : 'module_expr Grammar.Entry.e))], - Gramext.action - (fun (me : 'module_expr) _ (loc : int * int) -> - (Qast.Node ("StInc", [Qast.Loc; me]) : 'str_item)); - [Gramext.Stoken ("", "external"); - Gramext.Snterm - (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e)); - Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.srules - [[Gramext.Slist1 - (Gramext.Snterm - (Grammar.Entry.obj (a_STRING : 'a_STRING Grammar.Entry.e)))], - Gramext.action - (fun (a : 'a_STRING list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]], - Gramext.action - (fun (pd : 'a_list) _ (t : 'ctyp) _ (i : 'a_LIDENT) _ - (loc : int * int) -> - (Qast.Node ("StExt", [Qast.Loc; i; t; pd]) : 'str_item)); - [Gramext.Stoken ("", "exception"); - Gramext.Snterm - (Grammar.Entry.obj - (constructor_declaration : - 'constructor_declaration Grammar.Entry.e)); - Gramext.Snterm - (Grammar.Entry.obj (rebind_exn : 'rebind_exn Grammar.Entry.e))], - Gramext.action - (fun (b : 'rebind_exn) (ctl : 'constructor_declaration) _ - (loc : int * int) -> - (let (_, c, tl) = - match ctl with - Qast.Tuple [xx1; xx2; xx3] -> xx1, xx2, xx3 - | _ -> - match () with - _ -> raise (Match_failure ("q_MLast.ml", 302, 19)) - in - Qast.Node ("StExc", [Qast.Loc; c; tl; b]) : - 'str_item)); - [Gramext.Stoken ("", "declare"); - Gramext.srules - [[Gramext.Slist0 - (Gramext.srules - [[Gramext.Snterm - (Grammar.Entry.obj - (str_item : 'str_item Grammar.Entry.e)); - Gramext.Stoken ("", ";")], - Gramext.action - (fun _ (s : 'str_item) (loc : int * int) -> - (s : 'e__2))])], - Gramext.action - (fun (a : 'e__2 list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]; - Gramext.Stoken ("", "end")], - Gramext.action - (fun _ (st : 'a_list) _ (loc : int * int) -> - (Qast.Node ("StDcl", [Qast.Loc; st]) : 'str_item))]]; - Grammar.Entry.obj (rebind_exn : 'rebind_exn Grammar.Entry.e), None, - [None, None, - [[], - Gramext.action (fun (loc : int * int) -> (Qast.List [] : 'rebind_exn)); - [Gramext.Stoken ("", "="); - Gramext.Snterm - (Grammar.Entry.obj (mod_ident : 'mod_ident Grammar.Entry.e))], - Gramext.action - (fun (sl : 'mod_ident) _ (loc : int * int) -> (sl : 'rebind_exn))]]; - Grammar.Entry.obj (module_binding : 'module_binding Grammar.Entry.e), - None, - [None, Some Gramext.RightA, - [[Gramext.Stoken ("", "="); - Gramext.Snterm - (Grammar.Entry.obj (module_expr : 'module_expr Grammar.Entry.e))], - Gramext.action - (fun (me : 'module_expr) _ (loc : int * int) -> - (me : 'module_binding)); - [Gramext.Stoken ("", ":"); - Gramext.Snterm - (Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm - (Grammar.Entry.obj (module_expr : 'module_expr Grammar.Entry.e))], - Gramext.action - (fun (me : 'module_expr) _ (mt : 'module_type) _ (loc : int * int) -> - (Qast.Node ("MeTyc", [Qast.Loc; me; mt]) : 'module_binding)); - [Gramext.Stoken ("", "("); - Gramext.Snterm - (Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e)); - Gramext.Stoken ("", ":"); - Gramext.Snterm - (Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e)); - Gramext.Stoken ("", ")"); Gramext.Sself], - Gramext.action - (fun (mb : 'module_binding) _ (mt : 'module_type) _ (m : 'a_UIDENT) _ - (loc : int * int) -> - (Qast.Node ("MeFun", [Qast.Loc; m; mt; mb]) : 'module_binding))]]; - Grammar.Entry.obj - (module_rec_binding : 'module_rec_binding Grammar.Entry.e), - None, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e)); - Gramext.Stoken ("", ":"); - Gramext.Snterm - (Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm - (Grammar.Entry.obj (module_expr : 'module_expr Grammar.Entry.e))], - Gramext.action - (fun (me : 'module_expr) _ (mt : 'module_type) _ (m : 'a_UIDENT) - (loc : int * int) -> - (Qast.Tuple [m; me; mt] : 'module_rec_binding))]]; - Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "functor"); Gramext.Stoken ("", "("); - Gramext.Snterm - (Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e)); - Gramext.Stoken ("", ":"); Gramext.Sself; Gramext.Stoken ("", ")"); - Gramext.Stoken ("", "->"); Gramext.Sself], - Gramext.action - (fun (mt : 'module_type) _ _ (t : 'module_type) _ (i : 'a_UIDENT) _ _ - (loc : int * int) -> - (Qast.Node ("MtFun", [Qast.Loc; i; t; mt]) : 'module_type))]; - None, None, - [[Gramext.Sself; Gramext.Stoken ("", "with"); - Gramext.srules - [[Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj - (with_constr : 'with_constr Grammar.Entry.e)), - Gramext.Stoken ("", "and"))], - Gramext.action - (fun (a : 'with_constr list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]], - Gramext.action - (fun (wcl : 'a_list) _ (mt : 'module_type) (loc : int * int) -> - (Qast.Node ("MtWit", [Qast.Loc; mt; wcl]) : 'module_type))]; - None, None, - [[Gramext.Stoken ("", "sig"); - Gramext.srules - [[Gramext.Slist0 - (Gramext.srules - [[Gramext.Snterm - (Grammar.Entry.obj - (sig_item : 'sig_item Grammar.Entry.e)); - Gramext.Stoken ("", ";")], - Gramext.action - (fun _ (s : 'sig_item) (loc : int * int) -> - (s : 'e__4))])], - Gramext.action - (fun (a : 'e__4 list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]; - Gramext.Stoken ("", "end")], - Gramext.action - (fun _ (sg : 'a_list) _ (loc : int * int) -> - (Qast.Node ("MtSig", [Qast.Loc; sg]) : 'module_type))]; - None, None, - [[Gramext.Sself; Gramext.Sself], - Gramext.action - (fun (m2 : 'module_type) (m1 : 'module_type) (loc : int * int) -> - (Qast.Node ("MtApp", [Qast.Loc; m1; m2]) : 'module_type))]; - None, None, - [[Gramext.Sself; Gramext.Stoken ("", "."); Gramext.Sself], - Gramext.action - (fun (m2 : 'module_type) _ (m1 : 'module_type) (loc : int * int) -> - (Qast.Node ("MtAcc", [Qast.Loc; m1; m2]) : 'module_type))]; - Some "simple", None, - [[Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (mt : 'module_type) _ (loc : int * int) -> - (mt : 'module_type)); - [Gramext.Stoken ("", "'"); - Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e))], - Gramext.action - (fun (i : 'ident) _ (loc : int * int) -> - (Qast.Node ("MtQuo", [Qast.Loc; i]) : 'module_type)); - [Gramext.Snterm - (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e))], - Gramext.action - (fun (i : 'a_LIDENT) (loc : int * int) -> - (Qast.Node ("MtLid", [Qast.Loc; i]) : 'module_type)); - [Gramext.Snterm - (Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e))], - Gramext.action - (fun (i : 'a_UIDENT) (loc : int * int) -> - (Qast.Node ("MtUid", [Qast.Loc; i]) : 'module_type))]]; - Grammar.Entry.obj (sig_item : 'sig_item Grammar.Entry.e), None, - [Some "top", None, - [[Gramext.Stoken ("", "value"); - Gramext.Snterm - (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e)); - Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], - Gramext.action - (fun (t : 'ctyp) _ (i : 'a_LIDENT) _ (loc : int * int) -> - (Qast.Node ("SgVal", [Qast.Loc; i; t]) : 'sig_item)); - [Gramext.Stoken ("", "type"); - Gramext.srules - [[Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj - (type_declaration : 'type_declaration Grammar.Entry.e)), - Gramext.Stoken ("", "and"))], - Gramext.action - (fun (a : 'type_declaration list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]], - Gramext.action - (fun (tdl : 'a_list) _ (loc : int * int) -> - (Qast.Node ("SgTyp", [Qast.Loc; tdl]) : 'sig_item)); - [Gramext.Stoken ("", "open"); - Gramext.Snterm - (Grammar.Entry.obj (mod_ident : 'mod_ident Grammar.Entry.e))], - Gramext.action - (fun (i : 'mod_ident) _ (loc : int * int) -> - (Qast.Node ("SgOpn", [Qast.Loc; i]) : 'sig_item)); - [Gramext.Stoken ("", "module"); Gramext.Stoken ("", "rec"); - Gramext.srules - [[Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj - (module_rec_declaration : - 'module_rec_declaration Grammar.Entry.e)), - Gramext.Stoken ("", "and"))], - Gramext.action - (fun (a : 'module_rec_declaration list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]], - Gramext.action - (fun (mds : 'a_list) _ _ (loc : int * int) -> - (Qast.Node ("SgRecMod", [Qast.Loc; mds]) : 'sig_item)); - [Gramext.Stoken ("", "module"); Gramext.Stoken ("", "type"); - Gramext.Snterm - (Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm - (Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e))], - Gramext.action - (fun (mt : 'module_type) _ (i : 'a_UIDENT) _ _ (loc : int * int) -> - (Qast.Node ("SgMty", [Qast.Loc; i; mt]) : 'sig_item)); - [Gramext.Stoken ("", "module"); - Gramext.Snterm - (Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e)); - Gramext.Snterm - (Grammar.Entry.obj - (module_declaration : 'module_declaration Grammar.Entry.e))], - Gramext.action - (fun (mt : 'module_declaration) (i : 'a_UIDENT) _ (loc : int * int) -> - (Qast.Node ("SgMod", [Qast.Loc; i; mt]) : 'sig_item)); - [Gramext.Stoken ("", "include"); - Gramext.Snterm - (Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e))], - Gramext.action - (fun (mt : 'module_type) _ (loc : int * int) -> - (Qast.Node ("SgInc", [Qast.Loc; mt]) : 'sig_item)); - [Gramext.Stoken ("", "external"); - Gramext.Snterm - (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e)); - Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.srules - [[Gramext.Slist1 - (Gramext.Snterm - (Grammar.Entry.obj (a_STRING : 'a_STRING Grammar.Entry.e)))], - Gramext.action - (fun (a : 'a_STRING list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]], - Gramext.action - (fun (pd : 'a_list) _ (t : 'ctyp) _ (i : 'a_LIDENT) _ - (loc : int * int) -> - (Qast.Node ("SgExt", [Qast.Loc; i; t; pd]) : 'sig_item)); - [Gramext.Stoken ("", "exception"); - Gramext.Snterm - (Grammar.Entry.obj - (constructor_declaration : - 'constructor_declaration Grammar.Entry.e))], - Gramext.action - (fun (ctl : 'constructor_declaration) _ (loc : int * int) -> - (let (_, c, tl) = - match ctl with - Qast.Tuple [xx1; xx2; xx3] -> xx1, xx2, xx3 - | _ -> - match () with - _ -> raise (Match_failure ("q_MLast.ml", 360, 19)) - in - Qast.Node ("SgExc", [Qast.Loc; c; tl]) : - 'sig_item)); - [Gramext.Stoken ("", "declare"); - Gramext.srules - [[Gramext.Slist0 - (Gramext.srules - [[Gramext.Snterm - (Grammar.Entry.obj - (sig_item : 'sig_item Grammar.Entry.e)); - Gramext.Stoken ("", ";")], - Gramext.action - (fun _ (s : 'sig_item) (loc : int * int) -> - (s : 'e__5))])], - Gramext.action - (fun (a : 'e__5 list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]; - Gramext.Stoken ("", "end")], - Gramext.action - (fun _ (st : 'a_list) _ (loc : int * int) -> - (Qast.Node ("SgDcl", [Qast.Loc; st]) : 'sig_item))]]; - Grammar.Entry.obj - (module_declaration : 'module_declaration Grammar.Entry.e), - None, - [None, Some Gramext.RightA, - [[Gramext.Stoken ("", "("); - Gramext.Snterm - (Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e)); - Gramext.Stoken ("", ":"); - Gramext.Snterm - (Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e)); - Gramext.Stoken ("", ")"); Gramext.Sself], - Gramext.action - (fun (mt : 'module_declaration) _ (t : 'module_type) _ (i : 'a_UIDENT) - _ (loc : int * int) -> - (Qast.Node ("MtFun", [Qast.Loc; i; t; mt]) : 'module_declaration)); - [Gramext.Stoken ("", ":"); - Gramext.Snterm - (Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e))], - Gramext.action - (fun (mt : 'module_type) _ (loc : int * int) -> - (mt : 'module_declaration))]]; - Grammar.Entry.obj - (module_rec_declaration : 'module_rec_declaration Grammar.Entry.e), - None, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e)); - Gramext.Stoken ("", ":"); - Gramext.Snterm - (Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e))], - Gramext.action - (fun (mt : 'module_type) _ (m : 'a_UIDENT) (loc : int * int) -> - (Qast.Tuple [m; mt] : 'module_rec_declaration))]]; - Grammar.Entry.obj (with_constr : 'with_constr Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "module"); - Gramext.Snterm - (Grammar.Entry.obj (mod_ident : 'mod_ident Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm - (Grammar.Entry.obj (module_expr : 'module_expr Grammar.Entry.e))], - Gramext.action - (fun (me : 'module_expr) _ (i : 'mod_ident) _ (loc : int * int) -> - (Qast.Node ("WcMod", [Qast.Loc; i; me]) : 'with_constr)); - [Gramext.Stoken ("", "type"); - Gramext.Snterm - (Grammar.Entry.obj (mod_ident : 'mod_ident Grammar.Entry.e)); - Gramext.srules - [[Gramext.Slist0 - (Gramext.Snterm - (Grammar.Entry.obj - (type_parameter : 'type_parameter Grammar.Entry.e)))], - Gramext.action - (fun (a : 'type_parameter list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]; - Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], - Gramext.action - (fun (t : 'ctyp) _ (tpl : 'a_list) (i : 'mod_ident) _ - (loc : int * int) -> - (Qast.Node ("WcTyp", [Qast.Loc; i; tpl; t]) : 'with_constr))]]; - Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), None, - [Some "top", Some Gramext.RightA, - [[Gramext.Stoken ("", "while"); Gramext.Sself; Gramext.Stoken ("", "do"); - Gramext.Stoken ("", "{"); - Gramext.Snterm - (Grammar.Entry.obj (sequence : 'sequence Grammar.Entry.e)); - Gramext.Stoken ("", "}")], - Gramext.action - (fun _ (seq : 'sequence) _ _ (e : 'expr) _ (loc : int * int) -> - (Qast.Node ("ExWhi", [Qast.Loc; e; seq]) : 'expr)); - [Gramext.Stoken ("", "for"); - Gramext.Snterm - (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e)); - Gramext.Stoken ("", "="); Gramext.Sself; - Gramext.Snterm - (Grammar.Entry.obj - (direction_flag : 'direction_flag Grammar.Entry.e)); - Gramext.Sself; Gramext.Stoken ("", "do"); Gramext.Stoken ("", "{"); - Gramext.Snterm - (Grammar.Entry.obj (sequence : 'sequence Grammar.Entry.e)); - Gramext.Stoken ("", "}")], - Gramext.action - (fun _ (seq : 'sequence) _ _ (e2 : 'expr) (df : 'direction_flag) - (e1 : 'expr) _ (i : 'a_LIDENT) _ (loc : int * int) -> - (Qast.Node ("ExFor", [Qast.Loc; i; e1; e2; df; seq]) : 'expr)); - [Gramext.Stoken ("", "do"); Gramext.Stoken ("", "{"); - Gramext.Snterm - (Grammar.Entry.obj (sequence : 'sequence Grammar.Entry.e)); - Gramext.Stoken ("", "}")], - Gramext.action - (fun _ (seq : 'sequence) _ _ (loc : int * int) -> - (mksequence Qast.Loc seq : 'expr)); - [Gramext.Stoken ("", "if"); Gramext.Sself; Gramext.Stoken ("", "then"); - Gramext.Sself; Gramext.Stoken ("", "else"); Gramext.Sself], - Gramext.action - (fun (e3 : 'expr) _ (e2 : 'expr) _ (e1 : 'expr) _ (loc : int * int) -> - (Qast.Node ("ExIfe", [Qast.Loc; e1; e2; e3]) : 'expr)); - [Gramext.Stoken ("", "try"); Gramext.Sself; Gramext.Stoken ("", "with"); - Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e)); - Gramext.Stoken ("", "->"); Gramext.Sself], - Gramext.action - (fun (e1 : 'expr) _ (p1 : 'ipatt) _ (e : 'expr) _ (loc : int * int) -> - (Qast.Node - ("ExTry", - [Qast.Loc; e; - Qast.List [Qast.Tuple [p1; Qast.Option None; e1]]]) : - 'expr)); - [Gramext.Stoken ("", "try"); Gramext.Sself; Gramext.Stoken ("", "with"); - Gramext.Stoken ("", "["); - Gramext.srules - [[Gramext.Slist0sep - (Gramext.Snterm - (Grammar.Entry.obj - (match_case : 'match_case Grammar.Entry.e)), - Gramext.Stoken ("", "|"))], - Gramext.action - (fun (a : 'match_case list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]; - Gramext.Stoken ("", "]")], - Gramext.action - (fun _ (l : 'a_list) _ _ (e : 'expr) _ (loc : int * int) -> - (Qast.Node ("ExTry", [Qast.Loc; e; l]) : 'expr)); - [Gramext.Stoken ("", "match"); Gramext.Sself; - Gramext.Stoken ("", "with"); - Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e)); - Gramext.Stoken ("", "->"); Gramext.Sself], - Gramext.action - (fun (e1 : 'expr) _ (p1 : 'ipatt) _ (e : 'expr) _ (loc : int * int) -> - (Qast.Node - ("ExMat", - [Qast.Loc; e; - Qast.List [Qast.Tuple [p1; Qast.Option None; e1]]]) : - 'expr)); - [Gramext.Stoken ("", "match"); Gramext.Sself; - Gramext.Stoken ("", "with"); Gramext.Stoken ("", "["); - Gramext.srules - [[Gramext.Slist0sep - (Gramext.Snterm - (Grammar.Entry.obj - (match_case : 'match_case Grammar.Entry.e)), - Gramext.Stoken ("", "|"))], - Gramext.action - (fun (a : 'match_case list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]; - Gramext.Stoken ("", "]")], - Gramext.action - (fun _ (l : 'a_list) _ _ (e : 'expr) _ (loc : int * int) -> - (Qast.Node ("ExMat", [Qast.Loc; e; l]) : 'expr)); - [Gramext.Stoken ("", "fun"); - Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e)); - Gramext.Snterm - (Grammar.Entry.obj (fun_def : 'fun_def Grammar.Entry.e))], - Gramext.action - (fun (e : 'fun_def) (p : 'ipatt) _ (loc : int * int) -> - (Qast.Node - ("ExFun", - [Qast.Loc; Qast.List [Qast.Tuple [p; Qast.Option None; e]]]) : - 'expr)); - [Gramext.Stoken ("", "fun"); Gramext.Stoken ("", "["); - Gramext.srules - [[Gramext.Slist0sep - (Gramext.Snterm - (Grammar.Entry.obj - (match_case : 'match_case Grammar.Entry.e)), - Gramext.Stoken ("", "|"))], - Gramext.action - (fun (a : 'match_case list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]; - Gramext.Stoken ("", "]")], - Gramext.action - (fun _ (l : 'a_list) _ _ (loc : int * int) -> - (Qast.Node ("ExFun", [Qast.Loc; l]) : 'expr)); - [Gramext.Stoken ("", "let"); Gramext.Stoken ("", "module"); - Gramext.Snterm - (Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e)); - Gramext.Snterm - (Grammar.Entry.obj - (module_binding : 'module_binding Grammar.Entry.e)); - Gramext.Stoken ("", "in"); Gramext.Sself], - Gramext.action - (fun (e : 'expr) _ (mb : 'module_binding) (m : 'a_UIDENT) _ _ - (loc : int * int) -> - (Qast.Node ("ExLmd", [Qast.Loc; m; mb; e]) : 'expr)); - [Gramext.Stoken ("", "let"); - Gramext.srules - [[Gramext.Sopt - (Gramext.srules - [[Gramext.Stoken ("", "rec")], - Gramext.action - (fun (x : string) (loc : int * int) -> - (Qast.Str x : 'e__6))])], - Gramext.action - (fun (a : 'e__6 option) (loc : int * int) -> - (Qast.Option a : 'a_opt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_opt) (loc : int * int) -> (a : 'a_opt))]; - Gramext.srules - [[Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj - (let_binding : 'let_binding Grammar.Entry.e)), - Gramext.Stoken ("", "and"))], - Gramext.action - (fun (a : 'let_binding list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]; - Gramext.Stoken ("", "in"); Gramext.Sself], - Gramext.action - (fun (x : 'expr) _ (l : 'a_list) (r : 'a_opt) _ (loc : int * int) -> - (Qast.Node ("ExLet", [Qast.Loc; o2b r; l; x]) : 'expr))]; - Some "where", None, - [[Gramext.Sself; Gramext.Stoken ("", "where"); - Gramext.srules - [[Gramext.Sopt - (Gramext.srules - [[Gramext.Stoken ("", "rec")], - Gramext.action - (fun (x : string) (loc : int * int) -> - (Qast.Str x : 'e__7))])], - Gramext.action - (fun (a : 'e__7 option) (loc : int * int) -> - (Qast.Option a : 'a_opt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_opt) (loc : int * int) -> (a : 'a_opt))]; - Gramext.Snterm - (Grammar.Entry.obj (let_binding : 'let_binding Grammar.Entry.e))], - Gramext.action - (fun (lb : 'let_binding) (rf : 'a_opt) _ (e : 'expr) - (loc : int * int) -> - (Qast.Node ("ExLet", [Qast.Loc; o2b rf; Qast.List [lb]; e]) : - 'expr))]; - Some ":=", Some Gramext.NonA, - [[Gramext.Sself; Gramext.Stoken ("", ":="); Gramext.Sself; - Gramext.Snterm (Grammar.Entry.obj (dummy : 'dummy Grammar.Entry.e))], - Gramext.action - (fun _ (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (Qast.Node ("ExAss", [Qast.Loc; e1; e2]) : 'expr))]; - Some "||", Some Gramext.RightA, - [[Gramext.Sself; Gramext.Stoken ("", "||"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (Qast.Node - ("ExApp", - [Qast.Loc; - Qast.Node - ("ExApp", - [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str "||"]); - e1]); - e2]) : - 'expr))]; - Some "&&", Some Gramext.RightA, - [[Gramext.Sself; Gramext.Stoken ("", "&&"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (Qast.Node - ("ExApp", - [Qast.Loc; - Qast.Node - ("ExApp", - [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str "&&"]); - e1]); - e2]) : - 'expr))]; - Some "<", Some Gramext.LeftA, - [[Gramext.Sself; Gramext.Stoken ("", "!="); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (Qast.Node - ("ExApp", - [Qast.Loc; - Qast.Node - ("ExApp", - [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str "!="]); - e1]); - e2]) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "=="); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (Qast.Node - ("ExApp", - [Qast.Loc; - Qast.Node - ("ExApp", - [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str "=="]); - e1]); - e2]) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "<>"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (Qast.Node - ("ExApp", - [Qast.Loc; - Qast.Node - ("ExApp", - [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str "<>"]); - e1]); - e2]) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "="); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (Qast.Node - ("ExApp", - [Qast.Loc; - Qast.Node - ("ExApp", - [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str "="]); - e1]); - e2]) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", ">="); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (Qast.Node - ("ExApp", - [Qast.Loc; - Qast.Node - ("ExApp", - [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str ">="]); - e1]); - e2]) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "<="); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (Qast.Node - ("ExApp", - [Qast.Loc; - Qast.Node - ("ExApp", - [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str "<="]); - e1]); - e2]) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", ">"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (Qast.Node - ("ExApp", - [Qast.Loc; - Qast.Node - ("ExApp", - [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str ">"]); - e1]); - e2]) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "<"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (Qast.Node - ("ExApp", - [Qast.Loc; - Qast.Node - ("ExApp", - [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str "<"]); - e1]); - e2]) : - 'expr))]; - Some "^", Some Gramext.RightA, - [[Gramext.Sself; Gramext.Stoken ("", "@"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (Qast.Node - ("ExApp", - [Qast.Loc; - Qast.Node - ("ExApp", - [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str "@"]); - e1]); - e2]) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "^"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (Qast.Node - ("ExApp", - [Qast.Loc; - Qast.Node - ("ExApp", - [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str "^"]); - e1]); - e2]) : - 'expr))]; - Some "+", Some Gramext.LeftA, - [[Gramext.Sself; Gramext.Stoken ("", "-."); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (Qast.Node - ("ExApp", - [Qast.Loc; - Qast.Node - ("ExApp", - [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str "-."]); - e1]); - e2]) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "+."); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (Qast.Node - ("ExApp", - [Qast.Loc; - Qast.Node - ("ExApp", - [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str "+."]); - e1]); - e2]) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "-"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (Qast.Node - ("ExApp", - [Qast.Loc; - Qast.Node - ("ExApp", - [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str "-"]); - e1]); - e2]) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "+"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (Qast.Node - ("ExApp", - [Qast.Loc; - Qast.Node - ("ExApp", - [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str "+"]); - e1]); - e2]) : - 'expr))]; - Some "*", Some Gramext.LeftA, - [[Gramext.Sself; Gramext.Stoken ("", "mod"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (Qast.Node - ("ExApp", - [Qast.Loc; - Qast.Node - ("ExApp", - [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str "mod"]); - e1]); - e2]) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "lxor"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (Qast.Node - ("ExApp", - [Qast.Loc; - Qast.Node - ("ExApp", - [Qast.Loc; - Qast.Node ("ExLid", [Qast.Loc; Qast.Str "lxor"]); e1]); - e2]) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "lor"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (Qast.Node - ("ExApp", - [Qast.Loc; - Qast.Node - ("ExApp", - [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str "lor"]); - e1]); - e2]) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "land"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (Qast.Node - ("ExApp", - [Qast.Loc; - Qast.Node - ("ExApp", - [Qast.Loc; - Qast.Node ("ExLid", [Qast.Loc; Qast.Str "land"]); e1]); - e2]) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "/."); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (Qast.Node - ("ExApp", - [Qast.Loc; - Qast.Node - ("ExApp", - [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str "/."]); - e1]); - e2]) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "*."); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (Qast.Node - ("ExApp", - [Qast.Loc; - Qast.Node - ("ExApp", - [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str "*."]); - e1]); - e2]) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "/"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (Qast.Node - ("ExApp", - [Qast.Loc; - Qast.Node - ("ExApp", - [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str "/"]); - e1]); - e2]) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "*"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (Qast.Node - ("ExApp", - [Qast.Loc; - Qast.Node - ("ExApp", - [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str "*"]); - e1]); - e2]) : - 'expr))]; - Some "**", Some Gramext.RightA, - [[Gramext.Sself; Gramext.Stoken ("", "lsr"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (Qast.Node - ("ExApp", - [Qast.Loc; - Qast.Node - ("ExApp", - [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str "lsr"]); - e1]); - e2]) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "lsl"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (Qast.Node - ("ExApp", - [Qast.Loc; - Qast.Node - ("ExApp", - [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str "lsl"]); - e1]); - e2]) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "asr"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (Qast.Node - ("ExApp", - [Qast.Loc; - Qast.Node - ("ExApp", - [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str "asr"]); - e1]); - e2]) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "**"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (Qast.Node - ("ExApp", - [Qast.Loc; - Qast.Node - ("ExApp", - [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str "**"]); - e1]); - e2]) : - 'expr))]; - Some "unary minus", Some Gramext.NonA, - [[Gramext.Stoken ("", "-."); Gramext.Sself], - Gramext.action - (fun (e : 'expr) _ (loc : int * int) -> - (mkumin Qast.Loc (Qast.Str "-.") e : 'expr)); - [Gramext.Stoken ("", "-"); Gramext.Sself], - Gramext.action - (fun (e : 'expr) _ (loc : int * int) -> - (mkumin Qast.Loc (Qast.Str "-") e : 'expr))]; - Some "apply", Some Gramext.LeftA, - [[Gramext.Stoken ("", "lazy"); Gramext.Sself], - Gramext.action - (fun (e : 'expr) _ (loc : int * int) -> - (Qast.Node ("ExLaz", [Qast.Loc; e]) : 'expr)); - [Gramext.Stoken ("", "assert"); Gramext.Sself], - Gramext.action - (fun (e : 'expr) _ (loc : int * int) -> - (mkassert Qast.Loc e : 'expr)); - [Gramext.Sself; Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) (e1 : 'expr) (loc : int * int) -> - (Qast.Node ("ExApp", [Qast.Loc; e1; e2]) : 'expr))]; - Some ".", Some Gramext.LeftA, - [[Gramext.Sself; Gramext.Stoken ("", "."); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (Qast.Node ("ExAcc", [Qast.Loc; e1; e2]) : 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "."); Gramext.Stoken ("", "["); - Gramext.Sself; Gramext.Stoken ("", "]")], - Gramext.action - (fun _ (e2 : 'expr) _ _ (e1 : 'expr) (loc : int * int) -> - (Qast.Node ("ExSte", [Qast.Loc; e1; e2]) : 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "."); Gramext.Stoken ("", "("); - Gramext.Sself; Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (e2 : 'expr) _ _ (e1 : 'expr) (loc : int * int) -> - (Qast.Node ("ExAre", [Qast.Loc; e1; e2]) : 'expr))]; - Some "~-", Some Gramext.NonA, - [[Gramext.Stoken ("", "~-."); Gramext.Sself], - Gramext.action - (fun (e : 'expr) _ (loc : int * int) -> - (Qast.Node - ("ExApp", - [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str "~-."]); - e]) : - 'expr)); - [Gramext.Stoken ("", "~-"); Gramext.Sself], - Gramext.action - (fun (e : 'expr) _ (loc : int * int) -> - (Qast.Node - ("ExApp", - [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str "~-"]); - e]) : - 'expr))]; - Some "simple", None, - [[Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ")")], - Gramext.action (fun _ (e : 'expr) _ (loc : int * int) -> (e : 'expr)); - [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ","); - Gramext.srules - [[Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e)), - Gramext.Stoken ("", ","))], - Gramext.action - (fun (a : 'expr list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]; - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (el : 'a_list) _ (e : 'expr) _ (loc : int * int) -> - (Qast.Node ("ExTup", [Qast.Loc; Qast.Cons (e, el)]) : 'expr)); - [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (t : 'ctyp) _ (e : 'expr) _ (loc : int * int) -> - (Qast.Node ("ExTyc", [Qast.Loc; e; t]) : 'expr)); - [Gramext.Stoken ("", "("); Gramext.Stoken ("", ")")], - Gramext.action - (fun _ _ (loc : int * int) -> - (Qast.Node ("ExUid", [Qast.Loc; Qast.Str "()"]) : 'expr)); - [Gramext.Stoken ("", "{"); Gramext.Stoken ("", "("); Gramext.Sself; - Gramext.Stoken ("", ")"); Gramext.Stoken ("", "with"); - Gramext.srules - [[Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj - (label_expr : 'label_expr Grammar.Entry.e)), - Gramext.Stoken ("", ";"))], - Gramext.action - (fun (a : 'label_expr list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]; - Gramext.Stoken ("", "}")], - Gramext.action - (fun _ (lel : 'a_list) _ _ (e : 'expr) _ _ (loc : int * int) -> - (Qast.Node ("ExRec", [Qast.Loc; lel; Qast.Option (Some e)]) : - 'expr)); - [Gramext.Stoken ("", "{"); - Gramext.srules - [[Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj - (label_expr : 'label_expr Grammar.Entry.e)), - Gramext.Stoken ("", ";"))], - Gramext.action - (fun (a : 'label_expr list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]; - Gramext.Stoken ("", "}")], - Gramext.action - (fun _ (lel : 'a_list) _ (loc : int * int) -> - (Qast.Node ("ExRec", [Qast.Loc; lel; Qast.Option None]) : 'expr)); - [Gramext.Stoken ("", "[|"); - Gramext.srules - [[Gramext.Slist0sep - (Gramext.Snterm - (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e)), - Gramext.Stoken ("", ";"))], - Gramext.action - (fun (a : 'expr list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]; - Gramext.Stoken ("", "|]")], - Gramext.action - (fun _ (el : 'a_list) _ (loc : int * int) -> - (Qast.Node ("ExArr", [Qast.Loc; el]) : 'expr)); - [Gramext.Stoken ("", "["); - Gramext.srules - [[Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e)), - Gramext.Stoken ("", ";"))], - Gramext.action - (fun (a : 'expr list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]; - Gramext.Snterm - (Grammar.Entry.obj (cons_expr_opt : 'cons_expr_opt Grammar.Entry.e)); - Gramext.Stoken ("", "]")], - Gramext.action - (fun _ (last : 'cons_expr_opt) (el : 'a_list) _ (loc : int * int) -> - (mklistexp Qast.Loc last el : 'expr)); - [Gramext.Stoken ("", "["); Gramext.Stoken ("", "]")], - Gramext.action - (fun _ _ (loc : int * int) -> - (Qast.Node ("ExUid", [Qast.Loc; Qast.Str "[]"]) : 'expr)); - [Gramext.Snterm - (Grammar.Entry.obj (expr_ident : 'expr_ident Grammar.Entry.e))], - Gramext.action (fun (i : 'expr_ident) (loc : int * int) -> (i : 'expr)); - [Gramext.Snterm (Grammar.Entry.obj (a_CHAR : 'a_CHAR Grammar.Entry.e))], - Gramext.action - (fun (s : 'a_CHAR) (loc : int * int) -> - (Qast.Node ("ExChr", [Qast.Loc; s]) : 'expr)); - [Gramext.Snterm - (Grammar.Entry.obj (a_STRING : 'a_STRING Grammar.Entry.e))], - Gramext.action - (fun (s : 'a_STRING) (loc : int * int) -> - (Qast.Node ("ExStr", [Qast.Loc; s]) : 'expr)); - [Gramext.Snterm - (Grammar.Entry.obj (a_FLOAT : 'a_FLOAT Grammar.Entry.e))], - Gramext.action - (fun (s : 'a_FLOAT) (loc : int * int) -> - (Qast.Node ("ExFlo", [Qast.Loc; s]) : 'expr)); - [Gramext.Snterm (Grammar.Entry.obj (a_INT : 'a_INT Grammar.Entry.e))], - Gramext.action - (fun (s : 'a_INT) (loc : int * int) -> - (Qast.Node ("ExInt", [Qast.Loc; s]) : 'expr))]]; - Grammar.Entry.obj (cons_expr_opt : 'cons_expr_opt Grammar.Entry.e), None, - [None, None, - [[], - Gramext.action - (fun (loc : int * int) -> (Qast.Option None : 'cons_expr_opt)); - [Gramext.Stoken ("", "::"); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) _ (loc : int * int) -> - (Qast.Option (Some e) : 'cons_expr_opt))]]; - Grammar.Entry.obj (dummy : 'dummy Grammar.Entry.e), None, - [None, None, - [[], Gramext.action (fun (loc : int * int) -> (() : 'dummy))]]; - Grammar.Entry.obj (sequence : 'sequence Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) (loc : int * int) -> (Qast.List [e] : 'sequence)); - [Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e)); - Gramext.Stoken ("", ";")], - Gramext.action - (fun _ (e : 'expr) (loc : int * int) -> (Qast.List [e] : 'sequence)); - [Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e)); - Gramext.Stoken ("", ";"); Gramext.Sself], - Gramext.action - (fun (el : 'sequence) _ (e : 'expr) (loc : int * int) -> - (Qast.Cons (e, el) : 'sequence)); - [Gramext.Stoken ("", "let"); - Gramext.srules - [[Gramext.Sopt - (Gramext.srules - [[Gramext.Stoken ("", "rec")], - Gramext.action - (fun (x : string) (loc : int * int) -> - (Qast.Str x : 'e__8))])], - Gramext.action - (fun (a : 'e__8 option) (loc : int * int) -> - (Qast.Option a : 'a_opt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_opt) (loc : int * int) -> (a : 'a_opt))]; - Gramext.srules - [[Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj - (let_binding : 'let_binding Grammar.Entry.e)), - Gramext.Stoken ("", "and"))], - Gramext.action - (fun (a : 'let_binding list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]; - Gramext.srules - [[Gramext.Stoken ("", ";")], - Gramext.action (fun (x : string) (loc : int * int) -> (x : 'e__9)); - [Gramext.Stoken ("", "in")], - Gramext.action (fun (x : string) (loc : int * int) -> (x : 'e__9))]; - Gramext.Sself], - Gramext.action - (fun (el : 'sequence) _ (l : 'a_list) (rf : 'a_opt) _ - (loc : int * int) -> - (Qast.List - [Qast.Node - ("ExLet", [Qast.Loc; o2b rf; l; mksequence Qast.Loc el])] : - 'sequence))]]; - Grammar.Entry.obj (let_binding : 'let_binding Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e)); - Gramext.Snterm - (Grammar.Entry.obj (fun_binding : 'fun_binding Grammar.Entry.e))], - Gramext.action - (fun (e : 'fun_binding) (p : 'ipatt) (loc : int * int) -> - (Qast.Tuple [p; e] : 'let_binding))]]; - Grammar.Entry.obj (fun_binding : 'fun_binding Grammar.Entry.e), None, - [None, Some Gramext.RightA, - [[Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) _ (t : 'ctyp) _ (loc : int * int) -> - (Qast.Node ("ExTyc", [Qast.Loc; e; t]) : 'fun_binding)); - [Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) _ (loc : int * int) -> (e : 'fun_binding)); - [Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e)); - Gramext.Sself], - Gramext.action - (fun (e : 'fun_binding) (p : 'ipatt) (loc : int * int) -> - (Qast.Node - ("ExFun", - [Qast.Loc; Qast.List [Qast.Tuple [p; Qast.Option None; e]]]) : - 'fun_binding))]]; - Grammar.Entry.obj (match_case : 'match_case Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e)); - Gramext.Snterm - (Grammar.Entry.obj (as_patt_opt : 'as_patt_opt Grammar.Entry.e)); - Gramext.Snterm - (Grammar.Entry.obj (when_expr_opt : 'when_expr_opt Grammar.Entry.e)); - Gramext.Stoken ("", "->"); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) _ (w : 'when_expr_opt) (aso : 'as_patt_opt) - (p : 'patt) (loc : int * int) -> - (mkmatchcase Qast.Loc p aso w e : 'match_case))]]; - Grammar.Entry.obj (as_patt_opt : 'as_patt_opt Grammar.Entry.e), None, - [None, None, - [[], - Gramext.action - (fun (loc : int * int) -> (Qast.Option None : 'as_patt_opt)); - [Gramext.Stoken ("", "as"); - Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e))], - Gramext.action - (fun (p : 'patt) _ (loc : int * int) -> - (Qast.Option (Some p) : 'as_patt_opt))]]; - Grammar.Entry.obj (when_expr_opt : 'when_expr_opt Grammar.Entry.e), None, - [None, None, - [[], - Gramext.action - (fun (loc : int * int) -> (Qast.Option None : 'when_expr_opt)); - [Gramext.Stoken ("", "when"); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) _ (loc : int * int) -> - (Qast.Option (Some e) : 'when_expr_opt))]]; - Grammar.Entry.obj (label_expr : 'label_expr Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj - (patt_label_ident : 'patt_label_ident Grammar.Entry.e)); - Gramext.Snterm - (Grammar.Entry.obj (fun_binding : 'fun_binding Grammar.Entry.e))], - Gramext.action - (fun (e : 'fun_binding) (i : 'patt_label_ident) (loc : int * int) -> - (Qast.Tuple [i; e] : 'label_expr))]]; - Grammar.Entry.obj (expr_ident : 'expr_ident Grammar.Entry.e), None, - [None, Some Gramext.RightA, - [[Gramext.Snterm - (Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e)); - Gramext.Stoken ("", "."); Gramext.Sself], - Gramext.action - (fun (j : 'expr_ident) _ (i : 'a_UIDENT) (loc : int * int) -> - (mkexprident Qast.Loc i j : 'expr_ident)); - [Gramext.Snterm - (Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e))], - Gramext.action - (fun (i : 'a_UIDENT) (loc : int * int) -> - (Qast.Node ("ExUid", [Qast.Loc; i]) : 'expr_ident)); - [Gramext.Snterm - (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e))], - Gramext.action - (fun (i : 'a_LIDENT) (loc : int * int) -> - (Qast.Node ("ExLid", [Qast.Loc; i]) : 'expr_ident))]]; - Grammar.Entry.obj (fun_def : 'fun_def Grammar.Entry.e), None, - [None, Some Gramext.RightA, - [[Gramext.Stoken ("", "->"); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action (fun (e : 'expr) _ (loc : int * int) -> (e : 'fun_def)); - [Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e)); - Gramext.Sself], - Gramext.action - (fun (e : 'fun_def) (p : 'ipatt) (loc : int * int) -> - (Qast.Node - ("ExFun", - [Qast.Loc; Qast.List [Qast.Tuple [p; Qast.Option None; e]]]) : - 'fun_def))]]; - Grammar.Entry.obj (patt : 'patt Grammar.Entry.e), None, - [None, Some Gramext.LeftA, - [[Gramext.Sself; Gramext.Stoken ("", "|"); Gramext.Sself], - Gramext.action - (fun (p2 : 'patt) _ (p1 : 'patt) (loc : int * int) -> - (Qast.Node ("PaOrp", [Qast.Loc; p1; p2]) : 'patt))]; - None, Some Gramext.NonA, - [[Gramext.Sself; Gramext.Stoken ("", ".."); Gramext.Sself], - Gramext.action - (fun (p2 : 'patt) _ (p1 : 'patt) (loc : int * int) -> - (Qast.Node ("PaRng", [Qast.Loc; p1; p2]) : 'patt))]; - None, Some Gramext.LeftA, - [[Gramext.Sself; Gramext.Sself], - Gramext.action - (fun (p2 : 'patt) (p1 : 'patt) (loc : int * int) -> - (Qast.Node ("PaApp", [Qast.Loc; p1; p2]) : 'patt))]; - None, Some Gramext.LeftA, - [[Gramext.Sself; Gramext.Stoken ("", "."); Gramext.Sself], - Gramext.action - (fun (p2 : 'patt) _ (p1 : 'patt) (loc : int * int) -> - (Qast.Node ("PaAcc", [Qast.Loc; p1; p2]) : 'patt))]; - Some "simple", None, - [[Gramext.Stoken ("", "_")], - Gramext.action - (fun _ (loc : int * int) -> - (Qast.Node ("PaAny", [Qast.Loc]) : 'patt)); - [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ","); - Gramext.srules - [[Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e)), - Gramext.Stoken ("", ","))], - Gramext.action - (fun (a : 'patt list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]; - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (pl : 'a_list) _ (p : 'patt) _ (loc : int * int) -> - (Qast.Node ("PaTup", [Qast.Loc; Qast.Cons (p, pl)]) : 'patt)); - [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", "as"); - Gramext.Sself; Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (p2 : 'patt) _ (p : 'patt) _ (loc : int * int) -> - (Qast.Node ("PaAli", [Qast.Loc; p; p2]) : 'patt)); - [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (t : 'ctyp) _ (p : 'patt) _ (loc : int * int) -> - (Qast.Node ("PaTyc", [Qast.Loc; p; t]) : 'patt)); - [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ")")], - Gramext.action (fun _ (p : 'patt) _ (loc : int * int) -> (p : 'patt)); - [Gramext.Stoken ("", "("); Gramext.Stoken ("", ")")], - Gramext.action - (fun _ _ (loc : int * int) -> - (Qast.Node ("PaUid", [Qast.Loc; Qast.Str "()"]) : 'patt)); - [Gramext.Stoken ("", "{"); - Gramext.srules - [[Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj - (label_patt : 'label_patt Grammar.Entry.e)), - Gramext.Stoken ("", ";"))], - Gramext.action - (fun (a : 'label_patt list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]; - Gramext.Stoken ("", "}")], - Gramext.action - (fun _ (lpl : 'a_list) _ (loc : int * int) -> - (Qast.Node ("PaRec", [Qast.Loc; lpl]) : 'patt)); - [Gramext.Stoken ("", "[|"); - Gramext.srules - [[Gramext.Slist0sep - (Gramext.Snterm - (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e)), - Gramext.Stoken ("", ";"))], - Gramext.action - (fun (a : 'patt list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]; - Gramext.Stoken ("", "|]")], - Gramext.action - (fun _ (pl : 'a_list) _ (loc : int * int) -> - (Qast.Node ("PaArr", [Qast.Loc; pl]) : 'patt)); - [Gramext.Stoken ("", "["); - Gramext.srules - [[Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e)), - Gramext.Stoken ("", ";"))], - Gramext.action - (fun (a : 'patt list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]; - Gramext.Snterm - (Grammar.Entry.obj (cons_patt_opt : 'cons_patt_opt Grammar.Entry.e)); - Gramext.Stoken ("", "]")], - Gramext.action - (fun _ (last : 'cons_patt_opt) (pl : 'a_list) _ (loc : int * int) -> - (mklistpat Qast.Loc last pl : 'patt)); - [Gramext.Stoken ("", "["); Gramext.Stoken ("", "]")], - Gramext.action - (fun _ _ (loc : int * int) -> - (Qast.Node ("PaUid", [Qast.Loc; Qast.Str "[]"]) : 'patt)); - [Gramext.Stoken ("", "-"); - Gramext.Snterm - (Grammar.Entry.obj (a_FLOAT : 'a_FLOAT Grammar.Entry.e))], - Gramext.action - (fun (s : 'a_FLOAT) _ (loc : int * int) -> - (mkuminpat Qast.Loc (Qast.Str "-") (Qast.Bool false) s : 'patt)); - [Gramext.Stoken ("", "-"); - Gramext.Snterm (Grammar.Entry.obj (a_INT : 'a_INT Grammar.Entry.e))], - Gramext.action - (fun (s : 'a_INT) _ (loc : int * int) -> - (mkuminpat Qast.Loc (Qast.Str "-") (Qast.Bool true) s : 'patt)); - [Gramext.Snterm (Grammar.Entry.obj (a_CHAR : 'a_CHAR Grammar.Entry.e))], - Gramext.action - (fun (s : 'a_CHAR) (loc : int * int) -> - (Qast.Node ("PaChr", [Qast.Loc; s]) : 'patt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_STRING : 'a_STRING Grammar.Entry.e))], - Gramext.action - (fun (s : 'a_STRING) (loc : int * int) -> - (Qast.Node ("PaStr", [Qast.Loc; s]) : 'patt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_FLOAT : 'a_FLOAT Grammar.Entry.e))], - Gramext.action - (fun (s : 'a_FLOAT) (loc : int * int) -> - (Qast.Node ("PaFlo", [Qast.Loc; s]) : 'patt)); - [Gramext.Snterm (Grammar.Entry.obj (a_INT : 'a_INT Grammar.Entry.e))], - Gramext.action - (fun (s : 'a_INT) (loc : int * int) -> - (Qast.Node ("PaInt", [Qast.Loc; s]) : 'patt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e))], - Gramext.action - (fun (s : 'a_UIDENT) (loc : int * int) -> - (Qast.Node ("PaUid", [Qast.Loc; s]) : 'patt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e))], - Gramext.action - (fun (s : 'a_LIDENT) (loc : int * int) -> - (Qast.Node ("PaLid", [Qast.Loc; s]) : 'patt))]]; - Grammar.Entry.obj (cons_patt_opt : 'cons_patt_opt Grammar.Entry.e), None, - [None, None, - [[], - Gramext.action - (fun (loc : int * int) -> (Qast.Option None : 'cons_patt_opt)); - [Gramext.Stoken ("", "::"); - Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e))], - Gramext.action - (fun (p : 'patt) _ (loc : int * int) -> - (Qast.Option (Some p) : 'cons_patt_opt))]]; - Grammar.Entry.obj (label_patt : 'label_patt Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj - (patt_label_ident : 'patt_label_ident Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e))], - Gramext.action - (fun (p : 'patt) _ (i : 'patt_label_ident) (loc : int * int) -> - (Qast.Tuple [i; p] : 'label_patt))]]; - Grammar.Entry.obj (patt_label_ident : 'patt_label_ident Grammar.Entry.e), - None, - [None, Some Gramext.LeftA, - [[Gramext.Sself; Gramext.Stoken ("", "."); Gramext.Sself], - Gramext.action - (fun (p2 : 'patt_label_ident) _ (p1 : 'patt_label_ident) - (loc : int * int) -> - (Qast.Node ("PaAcc", [Qast.Loc; p1; p2]) : 'patt_label_ident))]; - Some "simple", Some Gramext.RightA, - [[Gramext.Snterm - (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e))], - Gramext.action - (fun (i : 'a_LIDENT) (loc : int * int) -> - (Qast.Node ("PaLid", [Qast.Loc; i]) : 'patt_label_ident)); - [Gramext.Snterm - (Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e))], - Gramext.action - (fun (i : 'a_UIDENT) (loc : int * int) -> - (Qast.Node ("PaUid", [Qast.Loc; i]) : 'patt_label_ident))]]; - Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "_")], - Gramext.action - (fun _ (loc : int * int) -> - (Qast.Node ("PaAny", [Qast.Loc]) : 'ipatt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e))], - Gramext.action - (fun (s : 'a_LIDENT) (loc : int * int) -> - (Qast.Node ("PaLid", [Qast.Loc; s]) : 'ipatt)); - [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ","); - Gramext.srules - [[Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e)), - Gramext.Stoken ("", ","))], - Gramext.action - (fun (a : 'ipatt list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]; - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (pl : 'a_list) _ (p : 'ipatt) _ (loc : int * int) -> - (Qast.Node ("PaTup", [Qast.Loc; Qast.Cons (p, pl)]) : 'ipatt)); - [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", "as"); - Gramext.Sself; Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (p2 : 'ipatt) _ (p : 'ipatt) _ (loc : int * int) -> - (Qast.Node ("PaAli", [Qast.Loc; p; p2]) : 'ipatt)); - [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (t : 'ctyp) _ (p : 'ipatt) _ (loc : int * int) -> - (Qast.Node ("PaTyc", [Qast.Loc; p; t]) : 'ipatt)); - [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ")")], - Gramext.action (fun _ (p : 'ipatt) _ (loc : int * int) -> (p : 'ipatt)); - [Gramext.Stoken ("", "("); Gramext.Stoken ("", ")")], - Gramext.action - (fun _ _ (loc : int * int) -> - (Qast.Node ("PaUid", [Qast.Loc; Qast.Str "()"]) : 'ipatt)); - [Gramext.Stoken ("", "{"); - Gramext.srules - [[Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj - (label_ipatt : 'label_ipatt Grammar.Entry.e)), - Gramext.Stoken ("", ";"))], - Gramext.action - (fun (a : 'label_ipatt list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]; - Gramext.Stoken ("", "}")], - Gramext.action - (fun _ (lpl : 'a_list) _ (loc : int * int) -> - (Qast.Node ("PaRec", [Qast.Loc; lpl]) : 'ipatt))]]; - Grammar.Entry.obj (label_ipatt : 'label_ipatt Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj - (patt_label_ident : 'patt_label_ident Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e))], - Gramext.action - (fun (p : 'ipatt) _ (i : 'patt_label_ident) (loc : int * int) -> - (Qast.Tuple [i; p] : 'label_ipatt))]]; - Grammar.Entry.obj (type_declaration : 'type_declaration Grammar.Entry.e), - None, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj (type_patt : 'type_patt Grammar.Entry.e)); - Gramext.srules - [[Gramext.Slist0 - (Gramext.Snterm - (Grammar.Entry.obj - (type_parameter : 'type_parameter Grammar.Entry.e)))], - Gramext.action - (fun (a : 'type_parameter list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]; - Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.srules - [[Gramext.Slist0 - (Gramext.Snterm - (Grammar.Entry.obj - (constrain : 'constrain Grammar.Entry.e)))], - Gramext.action - (fun (a : 'constrain list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]], - Gramext.action - (fun (cl : 'a_list) (tk : 'ctyp) _ (tpl : 'a_list) (n : 'type_patt) - (loc : int * int) -> - (Qast.Tuple [n; tpl; tk; cl] : 'type_declaration))]]; - Grammar.Entry.obj (type_patt : 'type_patt Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e))], - Gramext.action - (fun (n : 'a_LIDENT) (loc : int * int) -> - (Qast.Tuple [Qast.Loc; n] : 'type_patt))]]; - Grammar.Entry.obj (constrain : 'constrain Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "constraint"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], - Gramext.action - (fun (t2 : 'ctyp) _ (t1 : 'ctyp) _ (loc : int * int) -> - (Qast.Tuple [t1; t2] : 'constrain))]]; - Grammar.Entry.obj (type_parameter : 'type_parameter Grammar.Entry.e), - None, - [None, None, - [[Gramext.Stoken ("", "-"); Gramext.Stoken ("", "'"); - Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e))], - Gramext.action - (fun (i : 'ident) _ _ (loc : int * int) -> - (Qast.Tuple [i; Qast.Tuple [Qast.Bool false; Qast.Bool true]] : - 'type_parameter)); - [Gramext.Stoken ("", "+"); Gramext.Stoken ("", "'"); - Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e))], - Gramext.action - (fun (i : 'ident) _ _ (loc : int * int) -> - (Qast.Tuple [i; Qast.Tuple [Qast.Bool true; Qast.Bool false]] : - 'type_parameter)); - [Gramext.Stoken ("", "'"); - Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e))], - Gramext.action - (fun (i : 'ident) _ (loc : int * int) -> - (Qast.Tuple [i; Qast.Tuple [Qast.Bool false; Qast.Bool false]] : - 'type_parameter))]]; - Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e), None, - [None, Some Gramext.LeftA, - [[Gramext.Sself; Gramext.Stoken ("", "=="); Gramext.Sself], - Gramext.action - (fun (t2 : 'ctyp) _ (t1 : 'ctyp) (loc : int * int) -> - (Qast.Node ("TyMan", [Qast.Loc; t1; t2]) : 'ctyp))]; - None, Some Gramext.LeftA, - [[Gramext.Sself; Gramext.Stoken ("", "as"); Gramext.Sself], - Gramext.action - (fun (t2 : 'ctyp) _ (t1 : 'ctyp) (loc : int * int) -> - (Qast.Node ("TyAli", [Qast.Loc; t1; t2]) : 'ctyp))]; - None, Some Gramext.LeftA, - [[Gramext.Stoken ("", "!"); - Gramext.srules - [[Gramext.Slist1 - (Gramext.Snterm - (Grammar.Entry.obj (typevar : 'typevar Grammar.Entry.e)))], - Gramext.action - (fun (a : 'typevar list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]; - Gramext.Stoken ("", "."); Gramext.Sself], - Gramext.action - (fun (t : 'ctyp) _ (pl : 'a_list) _ (loc : int * int) -> - (Qast.Node ("TyPol", [Qast.Loc; pl; t]) : 'ctyp))]; - Some "arrow", Some Gramext.RightA, - [[Gramext.Sself; Gramext.Stoken ("", "->"); Gramext.Sself], - Gramext.action - (fun (t2 : 'ctyp) _ (t1 : 'ctyp) (loc : int * int) -> - (Qast.Node ("TyArr", [Qast.Loc; t1; t2]) : 'ctyp))]; - Some "label", Some Gramext.NonA, - [[Gramext.Snterm - (Grammar.Entry.obj (a_OPTLABEL : 'a_OPTLABEL Grammar.Entry.e)); - Gramext.Sself], - Gramext.action - (fun (t : 'ctyp) (i : 'a_OPTLABEL) (loc : int * int) -> - (Qast.Node ("TyOlb", [Qast.Loc; i; t]) : 'ctyp)); - [Gramext.Snterm - (Grammar.Entry.obj - (a_QUESTIONIDENT : 'a_QUESTIONIDENT Grammar.Entry.e)); - Gramext.Stoken ("", ":"); Gramext.Sself], - Gramext.action - (fun (t : 'ctyp) _ (i : 'a_QUESTIONIDENT) (loc : int * int) -> - (Qast.Node ("TyOlb", [Qast.Loc; i; t]) : 'ctyp)); - [Gramext.Snterm - (Grammar.Entry.obj (a_LABEL : 'a_LABEL Grammar.Entry.e)); - Gramext.Sself], - Gramext.action - (fun (t : 'ctyp) (i : 'a_LABEL) (loc : int * int) -> - (Qast.Node ("TyLab", [Qast.Loc; i; t]) : 'ctyp)); - [Gramext.Snterm - (Grammar.Entry.obj (a_TILDEIDENT : 'a_TILDEIDENT Grammar.Entry.e)); - Gramext.Stoken ("", ":"); Gramext.Sself], - Gramext.action - (fun (t : 'ctyp) _ (i : 'a_TILDEIDENT) (loc : int * int) -> - (Qast.Node ("TyLab", [Qast.Loc; i; t]) : 'ctyp))]; - None, Some Gramext.LeftA, - [[Gramext.Sself; Gramext.Sself], - Gramext.action - (fun (t2 : 'ctyp) (t1 : 'ctyp) (loc : int * int) -> - (Qast.Node ("TyApp", [Qast.Loc; t1; t2]) : 'ctyp))]; - None, Some Gramext.LeftA, - [[Gramext.Sself; Gramext.Stoken ("", "."); Gramext.Sself], - Gramext.action - (fun (t2 : 'ctyp) _ (t1 : 'ctyp) (loc : int * int) -> - (Qast.Node ("TyAcc", [Qast.Loc; t1; t2]) : 'ctyp))]; - Some "simple", None, - [[Gramext.Stoken ("", "{"); - Gramext.srules - [[Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj - (label_declaration : 'label_declaration Grammar.Entry.e)), - Gramext.Stoken ("", ";"))], - Gramext.action - (fun (a : 'label_declaration list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]; - Gramext.Stoken ("", "}")], - Gramext.action - (fun _ (ldl : 'a_list) _ (loc : int * int) -> - (Qast.Node ("TyRec", [Qast.Loc; Qast.Bool false; ldl]) : 'ctyp)); - [Gramext.Stoken ("", "["); - Gramext.srules - [[Gramext.Slist0sep - (Gramext.Snterm - (Grammar.Entry.obj - (constructor_declaration : - 'constructor_declaration Grammar.Entry.e)), - Gramext.Stoken ("", "|"))], - Gramext.action - (fun (a : 'constructor_declaration list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]; - Gramext.Stoken ("", "]")], - Gramext.action - (fun _ (cdl : 'a_list) _ (loc : int * int) -> - (Qast.Node ("TySum", [Qast.Loc; Qast.Bool false; cdl]) : 'ctyp)); - [Gramext.Stoken ("", "private"); Gramext.Stoken ("", "{"); - Gramext.srules - [[Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj - (label_declaration : 'label_declaration Grammar.Entry.e)), - Gramext.Stoken ("", ";"))], - Gramext.action - (fun (a : 'label_declaration list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]; - Gramext.Stoken ("", "}")], - Gramext.action - (fun _ (ldl : 'a_list) _ _ (loc : int * int) -> - (Qast.Node ("TyRec", [Qast.Loc; Qast.Bool true; ldl]) : 'ctyp)); - [Gramext.Stoken ("", "private"); Gramext.Stoken ("", "["); - Gramext.srules - [[Gramext.Slist0sep - (Gramext.Snterm - (Grammar.Entry.obj - (constructor_declaration : - 'constructor_declaration Grammar.Entry.e)), - Gramext.Stoken ("", "|"))], - Gramext.action - (fun (a : 'constructor_declaration list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]; - Gramext.Stoken ("", "]")], - Gramext.action - (fun _ (cdl : 'a_list) _ _ (loc : int * int) -> - (Qast.Node ("TySum", [Qast.Loc; Qast.Bool true; cdl]) : 'ctyp)); - [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ")")], - Gramext.action (fun _ (t : 'ctyp) _ (loc : int * int) -> (t : 'ctyp)); - [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", "*"); - Gramext.srules - [[Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)), - Gramext.Stoken ("", "*"))], - Gramext.action - (fun (a : 'ctyp list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]; - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (tl : 'a_list) _ (t : 'ctyp) _ (loc : int * int) -> - (Qast.Node ("TyTup", [Qast.Loc; Qast.Cons (t, tl)]) : 'ctyp)); - [Gramext.Snterm - (Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e))], - Gramext.action - (fun (i : 'a_UIDENT) (loc : int * int) -> - (Qast.Node ("TyUid", [Qast.Loc; i]) : 'ctyp)); - [Gramext.Snterm - (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e))], - Gramext.action - (fun (i : 'a_LIDENT) (loc : int * int) -> - (Qast.Node ("TyLid", [Qast.Loc; i]) : 'ctyp)); - [Gramext.Stoken ("", "_")], - Gramext.action - (fun _ (loc : int * int) -> - (Qast.Node ("TyAny", [Qast.Loc]) : 'ctyp)); - [Gramext.Stoken ("", "'"); - Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e))], - Gramext.action - (fun (i : 'ident) _ (loc : int * int) -> - (Qast.Node ("TyQuo", [Qast.Loc; i]) : 'ctyp))]]; - Grammar.Entry.obj - (constructor_declaration : 'constructor_declaration Grammar.Entry.e), - None, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e))], - Gramext.action - (fun (ci : 'a_UIDENT) (loc : int * int) -> - (Qast.Tuple [Qast.Loc; ci; Qast.List []] : - 'constructor_declaration)); - [Gramext.Snterm - (Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e)); - Gramext.Stoken ("", "of"); - Gramext.srules - [[Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)), - Gramext.Stoken ("", "and"))], - Gramext.action - (fun (a : 'ctyp list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]], - Gramext.action - (fun (cal : 'a_list) _ (ci : 'a_UIDENT) (loc : int * int) -> - (Qast.Tuple [Qast.Loc; ci; cal] : 'constructor_declaration))]]; - Grammar.Entry.obj - (label_declaration : 'label_declaration Grammar.Entry.e), - None, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e)); - Gramext.Stoken ("", ":"); - Gramext.srules - [[Gramext.Sopt - (Gramext.srules - [[Gramext.Stoken ("", "mutable")], - Gramext.action - (fun (x : string) (loc : int * int) -> - (Qast.Str x : 'e__10))])], - Gramext.action - (fun (a : 'e__10 option) (loc : int * int) -> - (Qast.Option a : 'a_opt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_opt) (loc : int * int) -> (a : 'a_opt))]; - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], - Gramext.action - (fun (t : 'ctyp) (mf : 'a_opt) _ (i : 'a_LIDENT) (loc : int * int) -> - (Qast.Tuple [Qast.Loc; i; o2b mf; t] : 'label_declaration))]]; - Grammar.Entry.obj (ident : 'ident Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e))], - Gramext.action (fun (i : 'a_UIDENT) (loc : int * int) -> (i : 'ident)); - [Gramext.Snterm - (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e))], - Gramext.action - (fun (i : 'a_LIDENT) (loc : int * int) -> (i : 'ident))]]; - Grammar.Entry.obj (mod_ident : 'mod_ident Grammar.Entry.e), None, - [None, Some Gramext.RightA, - [[Gramext.Snterm - (Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e)); - Gramext.Stoken ("", "."); Gramext.Sself], - Gramext.action - (fun (j : 'mod_ident) _ (i : 'a_UIDENT) (loc : int * int) -> - (Qast.Cons (i, j) : 'mod_ident)); - [Gramext.Snterm - (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e))], - Gramext.action - (fun (i : 'a_LIDENT) (loc : int * int) -> - (Qast.List [i] : 'mod_ident)); - [Gramext.Snterm - (Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e))], - Gramext.action - (fun (i : 'a_UIDENT) (loc : int * int) -> - (Qast.List [i] : 'mod_ident))]]; - Grammar.Entry.obj (str_item : 'str_item Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "class"); Gramext.Stoken ("", "type"); - Gramext.srules - [[Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj - (class_type_declaration : - 'class_type_declaration Grammar.Entry.e)), - Gramext.Stoken ("", "and"))], - Gramext.action - (fun (a : 'class_type_declaration list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]], - Gramext.action - (fun (ctd : 'a_list) _ _ (loc : int * int) -> - (Qast.Node ("StClt", [Qast.Loc; ctd]) : 'str_item)); - [Gramext.Stoken ("", "class"); - Gramext.srules - [[Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj - (class_declaration : 'class_declaration Grammar.Entry.e)), - Gramext.Stoken ("", "and"))], - Gramext.action - (fun (a : 'class_declaration list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]], - Gramext.action - (fun (cd : 'a_list) _ (loc : int * int) -> - (Qast.Node ("StCls", [Qast.Loc; cd]) : 'str_item))]]; - Grammar.Entry.obj (sig_item : 'sig_item Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "class"); Gramext.Stoken ("", "type"); - Gramext.srules - [[Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj - (class_type_declaration : - 'class_type_declaration Grammar.Entry.e)), - Gramext.Stoken ("", "and"))], - Gramext.action - (fun (a : 'class_type_declaration list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]], - Gramext.action - (fun (ctd : 'a_list) _ _ (loc : int * int) -> - (Qast.Node ("SgClt", [Qast.Loc; ctd]) : 'sig_item)); - [Gramext.Stoken ("", "class"); - Gramext.srules - [[Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj - (class_description : 'class_description Grammar.Entry.e)), - Gramext.Stoken ("", "and"))], - Gramext.action - (fun (a : 'class_description list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]], - Gramext.action - (fun (cd : 'a_list) _ (loc : int * int) -> - (Qast.Node ("SgCls", [Qast.Loc; cd]) : 'sig_item))]]; - Grammar.Entry.obj - (class_declaration : 'class_declaration Grammar.Entry.e), - None, - [None, None, - [[Gramext.srules - [[Gramext.Sopt - (Gramext.srules - [[Gramext.Stoken ("", "virtual")], - Gramext.action - (fun (x : string) (loc : int * int) -> - (Qast.Str x : 'e__11))])], - Gramext.action - (fun (a : 'e__11 option) (loc : int * int) -> - (Qast.Option a : 'a_opt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_opt) (loc : int * int) -> (a : 'a_opt))]; - Gramext.Snterm - (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e)); - Gramext.Snterm - (Grammar.Entry.obj - (class_type_parameters : 'class_type_parameters Grammar.Entry.e)); - Gramext.Snterm - (Grammar.Entry.obj - (class_fun_binding : 'class_fun_binding Grammar.Entry.e))], - Gramext.action - (fun (cfb : 'class_fun_binding) (ctp : 'class_type_parameters) - (i : 'a_LIDENT) (vf : 'a_opt) (loc : int * int) -> - (Qast.Record - ["ciLoc", Qast.Loc; "ciVir", o2b vf; "ciPrm", ctp; "ciNam", i; - "ciExp", cfb] : - 'class_declaration))]]; - Grammar.Entry.obj - (class_fun_binding : 'class_fun_binding Grammar.Entry.e), - None, - [None, None, - [[Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e)); - Gramext.Sself], - Gramext.action - (fun (cfb : 'class_fun_binding) (p : 'ipatt) (loc : int * int) -> - (Qast.Node ("CeFun", [Qast.Loc; p; cfb]) : 'class_fun_binding)); - [Gramext.Stoken ("", ":"); - Gramext.Snterm - (Grammar.Entry.obj (class_type : 'class_type Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm - (Grammar.Entry.obj (class_expr : 'class_expr Grammar.Entry.e))], - Gramext.action - (fun (ce : 'class_expr) _ (ct : 'class_type) _ (loc : int * int) -> - (Qast.Node ("CeTyc", [Qast.Loc; ce; ct]) : 'class_fun_binding)); - [Gramext.Stoken ("", "="); - Gramext.Snterm - (Grammar.Entry.obj (class_expr : 'class_expr Grammar.Entry.e))], - Gramext.action - (fun (ce : 'class_expr) _ (loc : int * int) -> - (ce : 'class_fun_binding))]]; - Grammar.Entry.obj - (class_type_parameters : 'class_type_parameters Grammar.Entry.e), - None, - [None, None, - [[Gramext.Stoken ("", "["); - Gramext.srules - [[Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj - (type_parameter : 'type_parameter Grammar.Entry.e)), - Gramext.Stoken ("", ","))], - Gramext.action - (fun (a : 'type_parameter list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]; - Gramext.Stoken ("", "]")], - Gramext.action - (fun _ (tpl : 'a_list) _ (loc : int * int) -> - (Qast.Tuple [Qast.Loc; tpl] : 'class_type_parameters)); - [], - Gramext.action - (fun (loc : int * int) -> - (Qast.Tuple [Qast.Loc; Qast.List []] : 'class_type_parameters))]]; - Grammar.Entry.obj (class_fun_def : 'class_fun_def Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "->"); - Gramext.Snterm - (Grammar.Entry.obj (class_expr : 'class_expr Grammar.Entry.e))], - Gramext.action - (fun (ce : 'class_expr) _ (loc : int * int) -> (ce : 'class_fun_def)); - [Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e)); - Gramext.Sself], - Gramext.action - (fun (ce : 'class_fun_def) (p : 'ipatt) (loc : int * int) -> - (Qast.Node ("CeFun", [Qast.Loc; p; ce]) : 'class_fun_def))]]; - Grammar.Entry.obj (class_expr : 'class_expr Grammar.Entry.e), None, - [Some "top", None, - [[Gramext.Stoken ("", "let"); - Gramext.srules - [[Gramext.Sopt - (Gramext.srules - [[Gramext.Stoken ("", "rec")], - Gramext.action - (fun (x : string) (loc : int * int) -> - (Qast.Str x : 'e__12))])], - Gramext.action - (fun (a : 'e__12 option) (loc : int * int) -> - (Qast.Option a : 'a_opt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_opt) (loc : int * int) -> (a : 'a_opt))]; - Gramext.srules - [[Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj - (let_binding : 'let_binding Grammar.Entry.e)), - Gramext.Stoken ("", "and"))], - Gramext.action - (fun (a : 'let_binding list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]; - Gramext.Stoken ("", "in"); Gramext.Sself], - Gramext.action - (fun (ce : 'class_expr) _ (lb : 'a_list) (rf : 'a_opt) _ - (loc : int * int) -> - (Qast.Node ("CeLet", [Qast.Loc; o2b rf; lb; ce]) : 'class_expr)); - [Gramext.Stoken ("", "fun"); - Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e)); - Gramext.Snterm - (Grammar.Entry.obj - (class_fun_def : 'class_fun_def Grammar.Entry.e))], - Gramext.action - (fun (ce : 'class_fun_def) (p : 'ipatt) _ (loc : int * int) -> - (Qast.Node ("CeFun", [Qast.Loc; p; ce]) : 'class_expr))]; - Some "apply", Some Gramext.NonA, - [[Gramext.Sself; - Gramext.Snterml - (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), "label")], - Gramext.action - (fun (e : 'expr) (ce : 'class_expr) (loc : int * int) -> - (Qast.Node ("CeApp", [Qast.Loc; ce; e]) : 'class_expr))]; - Some "simple", None, - [[Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (ce : 'class_expr) _ (loc : int * int) -> (ce : 'class_expr)); - [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ":"); - Gramext.Snterm - (Grammar.Entry.obj (class_type : 'class_type Grammar.Entry.e)); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (ct : 'class_type) _ (ce : 'class_expr) _ (loc : int * int) -> - (Qast.Node ("CeTyc", [Qast.Loc; ce; ct]) : 'class_expr)); - [Gramext.Stoken ("", "object"); - Gramext.srules - [[Gramext.Sopt - (Gramext.Snterm - (Grammar.Entry.obj - (class_self_patt : 'class_self_patt Grammar.Entry.e)))], - Gramext.action - (fun (a : 'class_self_patt option) (loc : int * int) -> - (Qast.Option a : 'a_opt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_opt) (loc : int * int) -> (a : 'a_opt))]; - Gramext.Snterm - (Grammar.Entry.obj - (class_structure : 'class_structure Grammar.Entry.e)); - Gramext.Stoken ("", "end")], - Gramext.action - (fun _ (cf : 'class_structure) (cspo : 'a_opt) _ (loc : int * int) -> - (Qast.Node ("CeStr", [Qast.Loc; cspo; cf]) : 'class_expr)); - [Gramext.Snterm - (Grammar.Entry.obj - (class_longident : 'class_longident Grammar.Entry.e))], - Gramext.action - (fun (ci : 'class_longident) (loc : int * int) -> - (Qast.Node ("CeCon", [Qast.Loc; ci; Qast.List []]) : 'class_expr)); - [Gramext.Snterm - (Grammar.Entry.obj - (class_longident : 'class_longident Grammar.Entry.e)); - Gramext.Stoken ("", "["); - Gramext.srules - [[Gramext.Slist0sep - (Gramext.Snterm - (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)), - Gramext.Stoken ("", ","))], - Gramext.action - (fun (a : 'ctyp list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]; - Gramext.Stoken ("", "]")], - Gramext.action - (fun _ (ctcl : 'a_list) _ (ci : 'class_longident) (loc : int * int) -> - (Qast.Node ("CeCon", [Qast.Loc; ci; ctcl]) : 'class_expr))]]; - Grammar.Entry.obj (class_structure : 'class_structure Grammar.Entry.e), - None, - [None, None, - [[Gramext.srules - [[Gramext.Slist0 - (Gramext.srules - [[Gramext.Snterm - (Grammar.Entry.obj - (class_str_item : 'class_str_item Grammar.Entry.e)); - Gramext.Stoken ("", ";")], - Gramext.action - (fun _ (cf : 'class_str_item) (loc : int * int) -> - (cf : 'e__13))])], - Gramext.action - (fun (a : 'e__13 list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]], - Gramext.action - (fun (cf : 'a_list) (loc : int * int) -> (cf : 'class_structure))]]; - Grammar.Entry.obj (class_self_patt : 'class_self_patt Grammar.Entry.e), - None, - [None, None, - [[Gramext.Stoken ("", "("); - Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e)); - Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (t : 'ctyp) _ (p : 'patt) _ (loc : int * int) -> - (Qast.Node ("PaTyc", [Qast.Loc; p; t]) : 'class_self_patt)); - [Gramext.Stoken ("", "("); - Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e)); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (p : 'patt) _ (loc : int * int) -> (p : 'class_self_patt))]]; - Grammar.Entry.obj (class_str_item : 'class_str_item Grammar.Entry.e), - None, - [None, None, - [[Gramext.Stoken ("", "initializer"); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (se : 'expr) _ (loc : int * int) -> - (Qast.Node ("CrIni", [Qast.Loc; se]) : 'class_str_item)); - [Gramext.Stoken ("", "type"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], - Gramext.action - (fun (t2 : 'ctyp) _ (t1 : 'ctyp) _ (loc : int * int) -> - (Qast.Node ("CrCtr", [Qast.Loc; t1; t2]) : 'class_str_item)); - [Gramext.Stoken ("", "method"); - Gramext.srules - [[Gramext.Sopt - (Gramext.srules - [[Gramext.Stoken ("", "private")], - Gramext.action - (fun (x : string) (loc : int * int) -> - (Qast.Str x : 'e__17))])], - Gramext.action - (fun (a : 'e__17 option) (loc : int * int) -> - (Qast.Option a : 'a_opt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_opt) (loc : int * int) -> (a : 'a_opt))]; - Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e)); - Gramext.srules - [[Gramext.Sopt - (Gramext.Snterm - (Grammar.Entry.obj (polyt : 'polyt Grammar.Entry.e)))], - Gramext.action - (fun (a : 'polyt option) (loc : int * int) -> - (Qast.Option a : 'a_opt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_opt) (loc : int * int) -> (a : 'a_opt))]; - Gramext.Snterm - (Grammar.Entry.obj (fun_binding : 'fun_binding Grammar.Entry.e))], - Gramext.action - (fun (e : 'fun_binding) (topt : 'a_opt) (l : 'label) (pf : 'a_opt) _ - (loc : int * int) -> - (Qast.Node ("CrMth", [Qast.Loc; l; o2b pf; e; topt]) : - 'class_str_item)); - [Gramext.Stoken ("", "method"); Gramext.Stoken ("", "virtual"); - Gramext.srules - [[Gramext.Sopt - (Gramext.srules - [[Gramext.Stoken ("", "private")], - Gramext.action - (fun (x : string) (loc : int * int) -> - (Qast.Str x : 'e__16))])], - Gramext.action - (fun (a : 'e__16 option) (loc : int * int) -> - (Qast.Option a : 'a_opt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_opt) (loc : int * int) -> (a : 'a_opt))]; - Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e)); - Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], - Gramext.action - (fun (t : 'ctyp) _ (l : 'label) (pf : 'a_opt) _ _ (loc : int * int) -> - (Qast.Node ("CrVir", [Qast.Loc; l; o2b pf; t]) : 'class_str_item)); - [Gramext.Stoken ("", "value"); - Gramext.srules - [[Gramext.Sopt - (Gramext.srules - [[Gramext.Stoken ("", "mutable")], - Gramext.action - (fun (x : string) (loc : int * int) -> - (Qast.Str x : 'e__15))])], - Gramext.action - (fun (a : 'e__15 option) (loc : int * int) -> - (Qast.Option a : 'a_opt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_opt) (loc : int * int) -> (a : 'a_opt))]; - Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e)); - Gramext.Snterm - (Grammar.Entry.obj - (cvalue_binding : 'cvalue_binding Grammar.Entry.e))], - Gramext.action - (fun (e : 'cvalue_binding) (lab : 'label) (mf : 'a_opt) _ - (loc : int * int) -> - (Qast.Node ("CrVal", [Qast.Loc; lab; o2b mf; e]) : - 'class_str_item)); - [Gramext.Stoken ("", "inherit"); - Gramext.Snterm - (Grammar.Entry.obj (class_expr : 'class_expr Grammar.Entry.e)); - Gramext.srules - [[Gramext.Sopt - (Gramext.Snterm - (Grammar.Entry.obj - (as_lident : 'as_lident Grammar.Entry.e)))], - Gramext.action - (fun (a : 'as_lident option) (loc : int * int) -> - (Qast.Option a : 'a_opt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_opt) (loc : int * int) -> (a : 'a_opt))]], - Gramext.action - (fun (pb : 'a_opt) (ce : 'class_expr) _ (loc : int * int) -> - (Qast.Node ("CrInh", [Qast.Loc; ce; pb]) : 'class_str_item)); - [Gramext.Stoken ("", "declare"); - Gramext.srules - [[Gramext.Slist0 - (Gramext.srules - [[Gramext.Snterm - (Grammar.Entry.obj - (class_str_item : 'class_str_item Grammar.Entry.e)); - Gramext.Stoken ("", ";")], - Gramext.action - (fun _ (s : 'class_str_item) (loc : int * int) -> - (s : 'e__14))])], - Gramext.action - (fun (a : 'e__14 list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]; - Gramext.Stoken ("", "end")], - Gramext.action - (fun _ (st : 'a_list) _ (loc : int * int) -> - (Qast.Node ("CrDcl", [Qast.Loc; st]) : 'class_str_item))]]; - Grammar.Entry.obj (as_lident : 'as_lident Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "as"); - Gramext.Snterm - (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e))], - Gramext.action - (fun (i : 'a_LIDENT) _ (loc : int * int) -> (i : 'as_lident))]]; - Grammar.Entry.obj (polyt : 'polyt Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], - Gramext.action (fun (t : 'ctyp) _ (loc : int * int) -> (t : 'polyt))]]; - Grammar.Entry.obj (cvalue_binding : 'cvalue_binding Grammar.Entry.e), - None, - [None, None, - [[Gramext.Stoken ("", ":>"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) _ (t : 'ctyp) _ (loc : int * int) -> - (Qast.Node ("ExCoe", [Qast.Loc; e; Qast.Option None; t]) : - 'cvalue_binding)); - [Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", ":>"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) _ (t2 : 'ctyp) _ (t : 'ctyp) _ (loc : int * int) -> - (Qast.Node ("ExCoe", [Qast.Loc; e; Qast.Option (Some t); t2]) : - 'cvalue_binding)); - [Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) _ (t : 'ctyp) _ (loc : int * int) -> - (Qast.Node ("ExTyc", [Qast.Loc; e; t]) : 'cvalue_binding)); - [Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) _ (loc : int * int) -> (e : 'cvalue_binding))]]; - Grammar.Entry.obj (label : 'label Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e))], - Gramext.action - (fun (i : 'a_LIDENT) (loc : int * int) -> (i : 'label))]]; - Grammar.Entry.obj (class_type : 'class_type Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "object"); - Gramext.srules - [[Gramext.Sopt - (Gramext.Snterm - (Grammar.Entry.obj - (class_self_type : 'class_self_type Grammar.Entry.e)))], - Gramext.action - (fun (a : 'class_self_type option) (loc : int * int) -> - (Qast.Option a : 'a_opt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_opt) (loc : int * int) -> (a : 'a_opt))]; - Gramext.srules - [[Gramext.Slist0 - (Gramext.srules - [[Gramext.Snterm - (Grammar.Entry.obj - (class_sig_item : 'class_sig_item Grammar.Entry.e)); - Gramext.Stoken ("", ";")], - Gramext.action - (fun _ (csf : 'class_sig_item) (loc : int * int) -> - (csf : 'e__18))])], - Gramext.action - (fun (a : 'e__18 list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]; - Gramext.Stoken ("", "end")], - Gramext.action - (fun _ (csf : 'a_list) (cst : 'a_opt) _ (loc : int * int) -> - (Qast.Node ("CtSig", [Qast.Loc; cst; csf]) : 'class_type)); - [Gramext.Snterm - (Grammar.Entry.obj - (clty_longident : 'clty_longident Grammar.Entry.e))], - Gramext.action - (fun (id : 'clty_longident) (loc : int * int) -> - (Qast.Node ("CtCon", [Qast.Loc; id; Qast.List []]) : 'class_type)); - [Gramext.Snterm - (Grammar.Entry.obj - (clty_longident : 'clty_longident Grammar.Entry.e)); - Gramext.Stoken ("", "["); - Gramext.srules - [[Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)), - Gramext.Stoken ("", ","))], - Gramext.action - (fun (a : 'ctyp list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]; - Gramext.Stoken ("", "]")], - Gramext.action - (fun _ (tl : 'a_list) _ (id : 'clty_longident) (loc : int * int) -> - (Qast.Node ("CtCon", [Qast.Loc; id; tl]) : 'class_type)); - [Gramext.Stoken ("", "["); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", "]"); Gramext.Stoken ("", "->"); Gramext.Sself], - Gramext.action - (fun (ct : 'class_type) _ _ (t : 'ctyp) _ (loc : int * int) -> - (Qast.Node ("CtFun", [Qast.Loc; t; ct]) : 'class_type))]]; - Grammar.Entry.obj (class_self_type : 'class_self_type Grammar.Entry.e), - None, - [None, None, - [[Gramext.Stoken ("", "("); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (t : 'ctyp) _ (loc : int * int) -> (t : 'class_self_type))]]; - Grammar.Entry.obj (class_sig_item : 'class_sig_item Grammar.Entry.e), - None, - [None, None, - [[Gramext.Stoken ("", "type"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], - Gramext.action - (fun (t2 : 'ctyp) _ (t1 : 'ctyp) _ (loc : int * int) -> - (Qast.Node ("CgCtr", [Qast.Loc; t1; t2]) : 'class_sig_item)); - [Gramext.Stoken ("", "method"); - Gramext.srules - [[Gramext.Sopt - (Gramext.srules - [[Gramext.Stoken ("", "private")], - Gramext.action - (fun (x : string) (loc : int * int) -> - (Qast.Str x : 'e__22))])], - Gramext.action - (fun (a : 'e__22 option) (loc : int * int) -> - (Qast.Option a : 'a_opt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_opt) (loc : int * int) -> (a : 'a_opt))]; - Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e)); - Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], - Gramext.action - (fun (t : 'ctyp) _ (l : 'label) (pf : 'a_opt) _ (loc : int * int) -> - (Qast.Node ("CgMth", [Qast.Loc; l; o2b pf; t]) : 'class_sig_item)); - [Gramext.Stoken ("", "method"); Gramext.Stoken ("", "virtual"); - Gramext.srules - [[Gramext.Sopt - (Gramext.srules - [[Gramext.Stoken ("", "private")], - Gramext.action - (fun (x : string) (loc : int * int) -> - (Qast.Str x : 'e__21))])], - Gramext.action - (fun (a : 'e__21 option) (loc : int * int) -> - (Qast.Option a : 'a_opt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_opt) (loc : int * int) -> (a : 'a_opt))]; - Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e)); - Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], - Gramext.action - (fun (t : 'ctyp) _ (l : 'label) (pf : 'a_opt) _ _ (loc : int * int) -> - (Qast.Node ("CgVir", [Qast.Loc; l; o2b pf; t]) : 'class_sig_item)); - [Gramext.Stoken ("", "value"); - Gramext.srules - [[Gramext.Sopt - (Gramext.srules - [[Gramext.Stoken ("", "mutable")], - Gramext.action - (fun (x : string) (loc : int * int) -> - (Qast.Str x : 'e__20))])], - Gramext.action - (fun (a : 'e__20 option) (loc : int * int) -> - (Qast.Option a : 'a_opt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_opt) (loc : int * int) -> (a : 'a_opt))]; - Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e)); - Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], - Gramext.action - (fun (t : 'ctyp) _ (l : 'label) (mf : 'a_opt) _ (loc : int * int) -> - (Qast.Node ("CgVal", [Qast.Loc; l; o2b mf; t]) : 'class_sig_item)); - [Gramext.Stoken ("", "inherit"); - Gramext.Snterm - (Grammar.Entry.obj (class_type : 'class_type Grammar.Entry.e))], - Gramext.action - (fun (cs : 'class_type) _ (loc : int * int) -> - (Qast.Node ("CgInh", [Qast.Loc; cs]) : 'class_sig_item)); - [Gramext.Stoken ("", "declare"); - Gramext.srules - [[Gramext.Slist0 - (Gramext.srules - [[Gramext.Snterm - (Grammar.Entry.obj - (class_sig_item : 'class_sig_item Grammar.Entry.e)); - Gramext.Stoken ("", ";")], - Gramext.action - (fun _ (s : 'class_sig_item) (loc : int * int) -> - (s : 'e__19))])], - Gramext.action - (fun (a : 'e__19 list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]; - Gramext.Stoken ("", "end")], - Gramext.action - (fun _ (st : 'a_list) _ (loc : int * int) -> - (Qast.Node ("CgDcl", [Qast.Loc; st]) : 'class_sig_item))]]; - Grammar.Entry.obj - (class_description : 'class_description Grammar.Entry.e), - None, - [None, None, - [[Gramext.srules - [[Gramext.Sopt - (Gramext.srules - [[Gramext.Stoken ("", "virtual")], - Gramext.action - (fun (x : string) (loc : int * int) -> - (Qast.Str x : 'e__23))])], - Gramext.action - (fun (a : 'e__23 option) (loc : int * int) -> - (Qast.Option a : 'a_opt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_opt) (loc : int * int) -> (a : 'a_opt))]; - Gramext.Snterm - (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e)); - Gramext.Snterm - (Grammar.Entry.obj - (class_type_parameters : 'class_type_parameters Grammar.Entry.e)); - Gramext.Stoken ("", ":"); - Gramext.Snterm - (Grammar.Entry.obj (class_type : 'class_type Grammar.Entry.e))], - Gramext.action - (fun (ct : 'class_type) _ (ctp : 'class_type_parameters) - (n : 'a_LIDENT) (vf : 'a_opt) (loc : int * int) -> - (Qast.Record - ["ciLoc", Qast.Loc; "ciVir", o2b vf; "ciPrm", ctp; "ciNam", n; - "ciExp", ct] : - 'class_description))]]; - Grammar.Entry.obj - (class_type_declaration : 'class_type_declaration Grammar.Entry.e), - None, - [None, None, - [[Gramext.srules - [[Gramext.Sopt - (Gramext.srules - [[Gramext.Stoken ("", "virtual")], - Gramext.action - (fun (x : string) (loc : int * int) -> - (Qast.Str x : 'e__24))])], - Gramext.action - (fun (a : 'e__24 option) (loc : int * int) -> - (Qast.Option a : 'a_opt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_opt) (loc : int * int) -> (a : 'a_opt))]; - Gramext.Snterm - (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e)); - Gramext.Snterm - (Grammar.Entry.obj - (class_type_parameters : 'class_type_parameters Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm - (Grammar.Entry.obj (class_type : 'class_type Grammar.Entry.e))], - Gramext.action - (fun (cs : 'class_type) _ (ctp : 'class_type_parameters) - (n : 'a_LIDENT) (vf : 'a_opt) (loc : int * int) -> - (Qast.Record - ["ciLoc", Qast.Loc; "ciVir", o2b vf; "ciPrm", ctp; "ciNam", n; - "ciExp", cs] : - 'class_type_declaration))]]; - Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), - Some (Gramext.Level "apply"), - [None, Some Gramext.LeftA, - [[Gramext.Stoken ("", "new"); - Gramext.Snterm - (Grammar.Entry.obj - (class_longident : 'class_longident Grammar.Entry.e))], - Gramext.action - (fun (i : 'class_longident) _ (loc : int * int) -> - (Qast.Node ("ExNew", [Qast.Loc; i]) : 'expr))]]; - Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), - Some (Gramext.Level "."), - [None, None, - [[Gramext.Sself; Gramext.Stoken ("", "#"); - Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e))], - Gramext.action - (fun (lab : 'label) _ (e : 'expr) (loc : int * int) -> - (Qast.Node ("ExSnd", [Qast.Loc; e; lab]) : 'expr))]]; - Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), - Some (Gramext.Level "simple"), - [None, None, - [[Gramext.Stoken ("", "{<"); - Gramext.srules - [[Gramext.Slist0sep - (Gramext.Snterm - (Grammar.Entry.obj - (field_expr : 'field_expr Grammar.Entry.e)), - Gramext.Stoken ("", ";"))], - Gramext.action - (fun (a : 'field_expr list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]; - Gramext.Stoken ("", ">}")], - Gramext.action - (fun _ (fel : 'a_list) _ (loc : int * int) -> - (Qast.Node ("ExOvr", [Qast.Loc; fel]) : 'expr)); - [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ":>"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (t : 'ctyp) _ (e : 'expr) _ (loc : int * int) -> - (Qast.Node ("ExCoe", [Qast.Loc; e; Qast.Option None; t]) : 'expr)); - [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", ":>"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (t2 : 'ctyp) _ (t : 'ctyp) _ (e : 'expr) _ (loc : int * int) -> - (Qast.Node ("ExCoe", [Qast.Loc; e; Qast.Option (Some t); t2]) : - 'expr))]]; - Grammar.Entry.obj (field_expr : 'field_expr Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) _ (l : 'label) (loc : int * int) -> - (Qast.Tuple [l; e] : 'field_expr))]]; - Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e), - Some (Gramext.Level "simple"), - [None, None, - [[Gramext.Stoken ("", "<"); - Gramext.srules - [[Gramext.Slist0sep - (Gramext.Snterm - (Grammar.Entry.obj (field : 'field Grammar.Entry.e)), - Gramext.Stoken ("", ";"))], - Gramext.action - (fun (a : 'field list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]; - Gramext.srules - [[Gramext.Sopt - (Gramext.srules - [[Gramext.Stoken ("", "..")], - Gramext.action - (fun (x : string) (loc : int * int) -> - (Qast.Str x : 'e__25))])], - Gramext.action - (fun (a : 'e__25 option) (loc : int * int) -> - (Qast.Option a : 'a_opt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_opt) (loc : int * int) -> (a : 'a_opt))]; - Gramext.Stoken ("", ">")], - Gramext.action - (fun _ (v : 'a_opt) (ml : 'a_list) _ (loc : int * int) -> - (Qast.Node ("TyObj", [Qast.Loc; ml; o2b v]) : 'ctyp)); - [Gramext.Stoken ("", "#"); - Gramext.Snterm - (Grammar.Entry.obj - (class_longident : 'class_longident Grammar.Entry.e))], - Gramext.action - (fun (id : 'class_longident) _ (loc : int * int) -> - (Qast.Node ("TyCls", [Qast.Loc; id]) : 'ctyp))]]; - Grammar.Entry.obj (field : 'field Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e)); - Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], - Gramext.action - (fun (t : 'ctyp) _ (lab : 'a_LIDENT) (loc : int * int) -> - (Qast.Tuple [lab; t] : 'field))]]; - Grammar.Entry.obj (typevar : 'typevar Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "'"); - Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e))], - Gramext.action - (fun (i : 'ident) _ (loc : int * int) -> (i : 'typevar))]]; - Grammar.Entry.obj (clty_longident : 'clty_longident Grammar.Entry.e), - None, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e))], - Gramext.action - (fun (i : 'a_LIDENT) (loc : int * int) -> - (Qast.List [i] : 'clty_longident)); - [Gramext.Snterm - (Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e)); - Gramext.Stoken ("", "."); Gramext.Sself], - Gramext.action - (fun (l : 'clty_longident) _ (m : 'a_UIDENT) (loc : int * int) -> - (Qast.Cons (m, l) : 'clty_longident))]]; - Grammar.Entry.obj (class_longident : 'class_longident Grammar.Entry.e), - None, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e))], - Gramext.action - (fun (i : 'a_LIDENT) (loc : int * int) -> - (Qast.List [i] : 'class_longident)); - [Gramext.Snterm - (Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e)); - Gramext.Stoken ("", "."); Gramext.Sself], - Gramext.action - (fun (l : 'class_longident) _ (m : 'a_UIDENT) (loc : int * int) -> - (Qast.Cons (m, l) : 'class_longident))]]; - Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e), - Some (Gramext.Level "simple"), - [None, None, - [[Gramext.Stoken ("", "["); Gramext.Stoken ("", "<"); - Gramext.Snterm - (Grammar.Entry.obj - (row_field_list : 'row_field_list Grammar.Entry.e)); - Gramext.Stoken ("", ">"); - Gramext.srules - [[Gramext.Slist1 - (Gramext.Snterm - (Grammar.Entry.obj (name_tag : 'name_tag Grammar.Entry.e)))], - Gramext.action - (fun (a : 'name_tag list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]; - Gramext.Stoken ("", "]")], - Gramext.action - (fun _ (ntl : 'a_list) _ (rfl : 'row_field_list) _ _ - (loc : int * int) -> - (Qast.Node - ("TyVrn", - [Qast.Loc; rfl; Qast.Option (Some (Qast.Option (Some ntl)))]) : - 'ctyp)); - [Gramext.Stoken ("", "["); Gramext.Stoken ("", "<"); - Gramext.Snterm - (Grammar.Entry.obj - (row_field_list : 'row_field_list Grammar.Entry.e)); - Gramext.Stoken ("", "]")], - Gramext.action - (fun _ (rfl : 'row_field_list) _ _ (loc : int * int) -> - (Qast.Node - ("TyVrn", - [Qast.Loc; rfl; - Qast.Option (Some (Qast.Option (Some (Qast.List []))))]) : - 'ctyp)); - [Gramext.Stoken ("", "["); Gramext.Stoken ("", ">"); - Gramext.Snterm - (Grammar.Entry.obj - (row_field_list : 'row_field_list Grammar.Entry.e)); - Gramext.Stoken ("", "]")], - Gramext.action - (fun _ (rfl : 'row_field_list) _ _ (loc : int * int) -> - (Qast.Node - ("TyVrn", - [Qast.Loc; rfl; Qast.Option (Some (Qast.Option None))]) : - 'ctyp)); - [Gramext.Stoken ("", "["); Gramext.Stoken ("", "="); - Gramext.Snterm - (Grammar.Entry.obj - (row_field_list : 'row_field_list Grammar.Entry.e)); - Gramext.Stoken ("", "]")], - Gramext.action - (fun _ (rfl : 'row_field_list) _ _ (loc : int * int) -> - (Qast.Node ("TyVrn", [Qast.Loc; rfl; Qast.Option None]) : - 'ctyp))]]; - Grammar.Entry.obj (row_field_list : 'row_field_list Grammar.Entry.e), - None, - [None, None, - [[Gramext.srules - [[Gramext.Slist0sep - (Gramext.Snterm - (Grammar.Entry.obj (row_field : 'row_field Grammar.Entry.e)), - Gramext.Stoken ("", "|"))], - Gramext.action - (fun (a : 'row_field list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]], - Gramext.action - (fun (rfl : 'a_list) (loc : int * int) -> (rfl : 'row_field_list))]]; - Grammar.Entry.obj (row_field : 'row_field Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], - Gramext.action - (fun (t : 'ctyp) (loc : int * int) -> - (Qast.Node ("RfInh", [t]) : 'row_field)); - [Gramext.Stoken ("", "`"); - Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e)); - Gramext.Stoken ("", "of"); - Gramext.srules - [[Gramext.Sopt - (Gramext.srules - [[Gramext.Stoken ("", "&")], - Gramext.action - (fun (x : string) (loc : int * int) -> - (Qast.Str x : 'e__26))])], - Gramext.action - (fun (a : 'e__26 option) (loc : int * int) -> - (Qast.Option a : 'a_opt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_opt) (loc : int * int) -> (a : 'a_opt))]; - Gramext.srules - [[Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)), - Gramext.Stoken ("", "&"))], - Gramext.action - (fun (a : 'ctyp list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]], - Gramext.action - (fun (l : 'a_list) (ao : 'a_opt) _ (i : 'ident) _ (loc : int * int) -> - (Qast.Node ("RfTag", [i; o2b ao; l]) : 'row_field)); - [Gramext.Stoken ("", "`"); - Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e))], - Gramext.action - (fun (i : 'ident) _ (loc : int * int) -> - (Qast.Node ("RfTag", [i; Qast.Bool true; Qast.List []]) : - 'row_field))]]; - Grammar.Entry.obj (name_tag : 'name_tag Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "`"); - Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e))], - Gramext.action - (fun (i : 'ident) _ (loc : int * int) -> (i : 'name_tag))]]; - Grammar.Entry.obj (patt : 'patt Grammar.Entry.e), - Some (Gramext.Level "simple"), - [None, None, - [[Gramext.Stoken ("", "?"); Gramext.Stoken ("", "("); - Gramext.Snterm - (Grammar.Entry.obj (patt_tcon : 'patt_tcon Grammar.Entry.e)); - Gramext.srules - [[Gramext.Sopt - (Gramext.Snterm - (Grammar.Entry.obj (eq_expr : 'eq_expr Grammar.Entry.e)))], - Gramext.action - (fun (a : 'eq_expr option) (loc : int * int) -> - (Qast.Option a : 'a_opt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_opt) (loc : int * int) -> (a : 'a_opt))]; - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (eo : 'a_opt) (p : 'patt_tcon) _ _ (loc : int * int) -> - (Qast.Node - ("PaOlb", - [Qast.Loc; Qast.Str ""; - Qast.Option (Some (Qast.Tuple [p; eo]))]) : - 'patt)); - [Gramext.Snterm - (Grammar.Entry.obj - (a_QUESTIONIDENT : 'a_QUESTIONIDENT Grammar.Entry.e))], - Gramext.action - (fun (i : 'a_QUESTIONIDENT) (loc : int * int) -> - (Qast.Node ("PaOlb", [Qast.Loc; i; Qast.Option None]) : 'patt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_OPTLABEL : 'a_OPTLABEL Grammar.Entry.e)); - Gramext.Stoken ("", "("); - Gramext.Snterm - (Grammar.Entry.obj (patt_tcon : 'patt_tcon Grammar.Entry.e)); - Gramext.srules - [[Gramext.Sopt - (Gramext.Snterm - (Grammar.Entry.obj (eq_expr : 'eq_expr Grammar.Entry.e)))], - Gramext.action - (fun (a : 'eq_expr option) (loc : int * int) -> - (Qast.Option a : 'a_opt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_opt) (loc : int * int) -> (a : 'a_opt))]; - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (eo : 'a_opt) (p : 'patt_tcon) _ (i : 'a_OPTLABEL) - (loc : int * int) -> - (Qast.Node - ("PaOlb", - [Qast.Loc; i; Qast.Option (Some (Qast.Tuple [p; eo]))]) : - 'patt)); - [Gramext.Snterm - (Grammar.Entry.obj - (a_QUESTIONIDENT : 'a_QUESTIONIDENT Grammar.Entry.e)); - Gramext.Stoken ("", ":"); Gramext.Stoken ("", "("); - Gramext.Snterm - (Grammar.Entry.obj (patt_tcon : 'patt_tcon Grammar.Entry.e)); - Gramext.srules - [[Gramext.Sopt - (Gramext.Snterm - (Grammar.Entry.obj (eq_expr : 'eq_expr Grammar.Entry.e)))], - Gramext.action - (fun (a : 'eq_expr option) (loc : int * int) -> - (Qast.Option a : 'a_opt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_opt) (loc : int * int) -> (a : 'a_opt))]; - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (eo : 'a_opt) (p : 'patt_tcon) _ _ (i : 'a_QUESTIONIDENT) - (loc : int * int) -> - (Qast.Node - ("PaOlb", - [Qast.Loc; i; Qast.Option (Some (Qast.Tuple [p; eo]))]) : - 'patt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_TILDEIDENT : 'a_TILDEIDENT Grammar.Entry.e))], - Gramext.action - (fun (i : 'a_TILDEIDENT) (loc : int * int) -> - (Qast.Node ("PaLab", [Qast.Loc; i; Qast.Option None]) : 'patt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_LABEL : 'a_LABEL Grammar.Entry.e)); - Gramext.Sself], - Gramext.action - (fun (p : 'patt) (i : 'a_LABEL) (loc : int * int) -> - (Qast.Node ("PaLab", [Qast.Loc; i; Qast.Option (Some p)]) : - 'patt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_TILDEIDENT : 'a_TILDEIDENT Grammar.Entry.e)); - Gramext.Stoken ("", ":"); Gramext.Sself], - Gramext.action - (fun (p : 'patt) _ (i : 'a_TILDEIDENT) (loc : int * int) -> - (Qast.Node ("PaLab", [Qast.Loc; i; Qast.Option (Some p)]) : - 'patt)); - [Gramext.Stoken ("", "#"); - Gramext.Snterm - (Grammar.Entry.obj (mod_ident : 'mod_ident Grammar.Entry.e))], - Gramext.action - (fun (sl : 'mod_ident) _ (loc : int * int) -> - (Qast.Node ("PaTyp", [Qast.Loc; sl]) : 'patt)); - [Gramext.Stoken ("", "`"); - Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e))], - Gramext.action - (fun (s : 'ident) _ (loc : int * int) -> - (Qast.Node ("PaVrn", [Qast.Loc; s]) : 'patt))]]; - Grammar.Entry.obj (patt_tcon : 'patt_tcon Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e))], - Gramext.action (fun (p : 'patt) (loc : int * int) -> (p : 'patt_tcon)); - [Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e)); - Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], - Gramext.action - (fun (t : 'ctyp) _ (p : 'patt) (loc : int * int) -> - (Qast.Node ("PaTyc", [Qast.Loc; p; t]) : 'patt_tcon))]]; - Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "?"); Gramext.Stoken ("", "("); - Gramext.Snterm - (Grammar.Entry.obj (ipatt_tcon : 'ipatt_tcon Grammar.Entry.e)); - Gramext.srules - [[Gramext.Sopt - (Gramext.Snterm - (Grammar.Entry.obj (eq_expr : 'eq_expr Grammar.Entry.e)))], - Gramext.action - (fun (a : 'eq_expr option) (loc : int * int) -> - (Qast.Option a : 'a_opt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_opt) (loc : int * int) -> (a : 'a_opt))]; - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (eo : 'a_opt) (p : 'ipatt_tcon) _ _ (loc : int * int) -> - (Qast.Node - ("PaOlb", - [Qast.Loc; Qast.Str ""; - Qast.Option (Some (Qast.Tuple [p; eo]))]) : - 'ipatt)); - [Gramext.Snterm - (Grammar.Entry.obj - (a_QUESTIONIDENT : 'a_QUESTIONIDENT Grammar.Entry.e))], - Gramext.action - (fun (i : 'a_QUESTIONIDENT) (loc : int * int) -> - (Qast.Node ("PaOlb", [Qast.Loc; i; Qast.Option None]) : 'ipatt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_OPTLABEL : 'a_OPTLABEL Grammar.Entry.e)); - Gramext.Stoken ("", "("); - Gramext.Snterm - (Grammar.Entry.obj (ipatt_tcon : 'ipatt_tcon Grammar.Entry.e)); - Gramext.srules - [[Gramext.Sopt - (Gramext.Snterm - (Grammar.Entry.obj (eq_expr : 'eq_expr Grammar.Entry.e)))], - Gramext.action - (fun (a : 'eq_expr option) (loc : int * int) -> - (Qast.Option a : 'a_opt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_opt) (loc : int * int) -> (a : 'a_opt))]; - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (eo : 'a_opt) (p : 'ipatt_tcon) _ (i : 'a_OPTLABEL) - (loc : int * int) -> - (Qast.Node - ("PaOlb", - [Qast.Loc; i; Qast.Option (Some (Qast.Tuple [p; eo]))]) : - 'ipatt)); - [Gramext.Snterm - (Grammar.Entry.obj - (a_QUESTIONIDENT : 'a_QUESTIONIDENT Grammar.Entry.e)); - Gramext.Stoken ("", ":"); Gramext.Stoken ("", "("); - Gramext.Snterm - (Grammar.Entry.obj (ipatt_tcon : 'ipatt_tcon Grammar.Entry.e)); - Gramext.srules - [[Gramext.Sopt - (Gramext.Snterm - (Grammar.Entry.obj (eq_expr : 'eq_expr Grammar.Entry.e)))], - Gramext.action - (fun (a : 'eq_expr option) (loc : int * int) -> - (Qast.Option a : 'a_opt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_opt) (loc : int * int) -> (a : 'a_opt))]; - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (eo : 'a_opt) (p : 'ipatt_tcon) _ _ (i : 'a_QUESTIONIDENT) - (loc : int * int) -> - (Qast.Node - ("PaOlb", - [Qast.Loc; i; Qast.Option (Some (Qast.Tuple [p; eo]))]) : - 'ipatt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_TILDEIDENT : 'a_TILDEIDENT Grammar.Entry.e))], - Gramext.action - (fun (i : 'a_TILDEIDENT) (loc : int * int) -> - (Qast.Node ("PaLab", [Qast.Loc; i; Qast.Option None]) : 'ipatt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_LABEL : 'a_LABEL Grammar.Entry.e)); - Gramext.Sself], - Gramext.action - (fun (p : 'ipatt) (i : 'a_LABEL) (loc : int * int) -> - (Qast.Node ("PaLab", [Qast.Loc; i; Qast.Option (Some p)]) : - 'ipatt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_TILDEIDENT : 'a_TILDEIDENT Grammar.Entry.e)); - Gramext.Stoken ("", ":"); Gramext.Sself], - Gramext.action - (fun (p : 'ipatt) _ (i : 'a_TILDEIDENT) (loc : int * int) -> - (Qast.Node ("PaLab", [Qast.Loc; i; Qast.Option (Some p)]) : - 'ipatt))]]; - Grammar.Entry.obj (ipatt_tcon : 'ipatt_tcon Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e))], - Gramext.action - (fun (p : 'ipatt) (loc : int * int) -> (p : 'ipatt_tcon)); - [Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e)); - Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], - Gramext.action - (fun (t : 'ctyp) _ (p : 'ipatt) (loc : int * int) -> - (Qast.Node ("PaTyc", [Qast.Loc; p; t]) : 'ipatt_tcon))]]; - Grammar.Entry.obj (eq_expr : 'eq_expr Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) _ (loc : int * int) -> (e : 'eq_expr))]]; - Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), - Some (Gramext.After "apply"), - [Some "label", Some Gramext.NonA, - [[Gramext.Snterm - (Grammar.Entry.obj - (a_QUESTIONIDENT : 'a_QUESTIONIDENT Grammar.Entry.e))], - Gramext.action - (fun (i : 'a_QUESTIONIDENT) (loc : int * int) -> - (Qast.Node ("ExOlb", [Qast.Loc; i; Qast.Option None]) : 'expr)); - [Gramext.Snterm - (Grammar.Entry.obj (a_OPTLABEL : 'a_OPTLABEL Grammar.Entry.e)); - Gramext.Sself], - Gramext.action - (fun (e : 'expr) (i : 'a_OPTLABEL) (loc : int * int) -> - (Qast.Node ("ExOlb", [Qast.Loc; i; Qast.Option (Some e)]) : - 'expr)); - [Gramext.Snterm - (Grammar.Entry.obj - (a_QUESTIONIDENT : 'a_QUESTIONIDENT Grammar.Entry.e)); - Gramext.Stoken ("", ":"); Gramext.Sself], - Gramext.action - (fun (e : 'expr) _ (i : 'a_QUESTIONIDENT) (loc : int * int) -> - (Qast.Node ("ExOlb", [Qast.Loc; i; Qast.Option (Some e)]) : - 'expr)); - [Gramext.Snterm - (Grammar.Entry.obj (a_TILDEIDENT : 'a_TILDEIDENT Grammar.Entry.e))], - Gramext.action - (fun (i : 'a_TILDEIDENT) (loc : int * int) -> - (Qast.Node ("ExLab", [Qast.Loc; i; Qast.Option None]) : 'expr)); - [Gramext.Snterm - (Grammar.Entry.obj (a_LABEL : 'a_LABEL Grammar.Entry.e)); - Gramext.Sself], - Gramext.action - (fun (e : 'expr) (i : 'a_LABEL) (loc : int * int) -> - (Qast.Node ("ExLab", [Qast.Loc; i; Qast.Option (Some e)]) : - 'expr)); - [Gramext.Snterm - (Grammar.Entry.obj (a_TILDEIDENT : 'a_TILDEIDENT Grammar.Entry.e)); - Gramext.Stoken ("", ":"); Gramext.Sself], - Gramext.action - (fun (e : 'expr) _ (i : 'a_TILDEIDENT) (loc : int * int) -> - (Qast.Node ("ExLab", [Qast.Loc; i; Qast.Option (Some e)]) : - 'expr))]]; - Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), - Some (Gramext.Level "simple"), - [None, None, - [[Gramext.Stoken ("", "`"); - Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e))], - Gramext.action - (fun (s : 'ident) _ (loc : int * int) -> - (Qast.Node ("ExVrn", [Qast.Loc; s]) : 'expr))]]; - Grammar.Entry.obj (direction_flag : 'direction_flag Grammar.Entry.e), - None, - [None, None, - [[Gramext.Stoken ("", "downto")], - Gramext.action - (fun _ (loc : int * int) -> (Qast.Bool false : 'direction_flag)); - [Gramext.Stoken ("", "to")], - Gramext.action - (fun _ (loc : int * int) -> (Qast.Bool true : 'direction_flag))]]; - Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e), - Some (Gramext.Level "simple"), - [None, None, - [[Gramext.Stoken ("", "[|"); - Gramext.Snterm - (Grammar.Entry.obj - (warning_variant : 'warning_variant Grammar.Entry.e)); - Gramext.Stoken ("", "<"); - Gramext.Snterm - (Grammar.Entry.obj - (row_field_list : 'row_field_list Grammar.Entry.e)); - Gramext.Stoken ("", ">"); - Gramext.srules - [[Gramext.Slist1 - (Gramext.Snterm - (Grammar.Entry.obj (name_tag : 'name_tag Grammar.Entry.e)))], - Gramext.action - (fun (a : 'name_tag list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]; - Gramext.Stoken ("", "|]")], - Gramext.action - (fun _ (ntl : 'a_list) _ (rfl : 'row_field_list) _ _ _ - (loc : int * int) -> - (Qast.Node - ("TyVrn", - [Qast.Loc; rfl; Qast.Option (Some (Qast.Option (Some ntl)))]) : - 'ctyp)); - [Gramext.Stoken ("", "[|"); - Gramext.Snterm - (Grammar.Entry.obj - (warning_variant : 'warning_variant Grammar.Entry.e)); - Gramext.Stoken ("", "<"); - Gramext.Snterm - (Grammar.Entry.obj - (row_field_list : 'row_field_list Grammar.Entry.e)); - Gramext.Stoken ("", "|]")], - Gramext.action - (fun _ (rfl : 'row_field_list) _ _ _ (loc : int * int) -> - (Qast.Node - ("TyVrn", - [Qast.Loc; rfl; - Qast.Option (Some (Qast.Option (Some (Qast.List []))))]) : - 'ctyp)); - [Gramext.Stoken ("", "[|"); - Gramext.Snterm - (Grammar.Entry.obj - (warning_variant : 'warning_variant Grammar.Entry.e)); - Gramext.Stoken ("", ">"); - Gramext.Snterm - (Grammar.Entry.obj - (row_field_list : 'row_field_list Grammar.Entry.e)); - Gramext.Stoken ("", "|]")], - Gramext.action - (fun _ (rfl : 'row_field_list) _ _ _ (loc : int * int) -> - (Qast.Node - ("TyVrn", - [Qast.Loc; rfl; Qast.Option (Some (Qast.Option None))]) : - 'ctyp)); - [Gramext.Stoken ("", "[|"); - Gramext.Snterm - (Grammar.Entry.obj - (warning_variant : 'warning_variant Grammar.Entry.e)); - Gramext.Snterm - (Grammar.Entry.obj - (row_field_list : 'row_field_list Grammar.Entry.e)); - Gramext.Stoken ("", "|]")], - Gramext.action - (fun _ (rfl : 'row_field_list) _ _ (loc : int * int) -> - (Qast.Node ("TyVrn", [Qast.Loc; rfl; Qast.Option None]) : - 'ctyp))]]; - Grammar.Entry.obj (warning_variant : 'warning_variant Grammar.Entry.e), - None, - [None, None, - [[], - Gramext.action - (fun (loc : int * int) -> - (warn_variant Qast.Loc : 'warning_variant))]]; - Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), - Some (Gramext.Level "top"), - [None, None, - [[Gramext.Stoken ("", "while"); Gramext.Sself; Gramext.Stoken ("", "do"); - Gramext.srules - [[Gramext.Slist0 - (Gramext.srules - [[Gramext.Snterm - (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e)); - Gramext.Stoken ("", ";")], - Gramext.action - (fun _ (e : 'expr) (loc : int * int) -> (e : 'e__29))])], - Gramext.action - (fun (a : 'e__29 list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]; - Gramext.Snterm - (Grammar.Entry.obj - (warning_sequence : 'warning_sequence Grammar.Entry.e)); - Gramext.Stoken ("", "done")], - Gramext.action - (fun _ _ (seq : 'a_list) _ (e : 'expr) _ (loc : int * int) -> - (Qast.Node ("ExWhi", [Qast.Loc; e; seq]) : 'expr)); - [Gramext.Stoken ("", "for"); - Gramext.Snterm - (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e)); - Gramext.Stoken ("", "="); Gramext.Sself; - Gramext.Snterm - (Grammar.Entry.obj - (direction_flag : 'direction_flag Grammar.Entry.e)); - Gramext.Sself; Gramext.Stoken ("", "do"); - Gramext.srules - [[Gramext.Slist0 - (Gramext.srules - [[Gramext.Snterm - (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e)); - Gramext.Stoken ("", ";")], - Gramext.action - (fun _ (e : 'expr) (loc : int * int) -> (e : 'e__28))])], - Gramext.action - (fun (a : 'e__28 list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]; - Gramext.Snterm - (Grammar.Entry.obj - (warning_sequence : 'warning_sequence Grammar.Entry.e)); - Gramext.Stoken ("", "done")], - Gramext.action - (fun _ _ (seq : 'a_list) _ (e2 : 'expr) (df : 'direction_flag) - (e1 : 'expr) _ (i : 'a_LIDENT) _ (loc : int * int) -> - (Qast.Node ("ExFor", [Qast.Loc; i; e1; e2; df; seq]) : 'expr)); - [Gramext.Stoken ("", "do"); - Gramext.srules - [[Gramext.Slist0 - (Gramext.srules - [[Gramext.Snterm - (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e)); - Gramext.Stoken ("", ";")], - Gramext.action - (fun _ (e : 'expr) (loc : int * int) -> (e : 'e__27))])], - Gramext.action - (fun (a : 'e__27 list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]; - Gramext.Stoken ("", "return"); - Gramext.Snterm - (Grammar.Entry.obj - (warning_sequence : 'warning_sequence Grammar.Entry.e)); - Gramext.Sself], - Gramext.action - (fun (e : 'expr) _ _ (seq : 'a_list) _ (loc : int * int) -> - (Qast.Node ("ExSeq", [Qast.Loc; append_elem seq e]) : 'expr))]]; - Grammar.Entry.obj (warning_sequence : 'warning_sequence Grammar.Entry.e), - None, - [None, None, - [[], - Gramext.action - (fun (loc : int * int) -> - (warn_sequence Qast.Loc : 'warning_sequence))]]; - Grammar.Entry.obj (sequence : 'sequence Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("ANTIQUOT", "list")], - Gramext.action - (fun (a : string) (loc : int * int) -> - (antiquot "list" loc a : 'sequence))]]; - Grammar.Entry.obj (expr_ident : 'expr_ident Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("ANTIQUOT", "")], - Gramext.action - (fun (a : string) (loc : int * int) -> - (antiquot "" loc a : 'expr_ident))]]; - Grammar.Entry.obj (patt_label_ident : 'patt_label_ident Grammar.Entry.e), - Some (Gramext.Level "simple"), - [None, None, - [[Gramext.Stoken ("ANTIQUOT", "")], - Gramext.action - (fun (a : string) (loc : int * int) -> - (antiquot "" loc a : 'patt_label_ident))]]; - Grammar.Entry.obj (when_expr_opt : 'when_expr_opt Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("ANTIQUOT", "when")], - Gramext.action - (fun (a : string) (loc : int * int) -> - (antiquot "when" loc a : 'when_expr_opt))]]; - Grammar.Entry.obj (mod_ident : 'mod_ident Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("ANTIQUOT", "")], - Gramext.action - (fun (a : string) (loc : int * int) -> - (antiquot "" loc a : 'mod_ident))]]; - Grammar.Entry.obj (clty_longident : 'clty_longident Grammar.Entry.e), - None, - [None, None, - [[Gramext.Snterm (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'clty_longident))]]; - Grammar.Entry.obj (class_longident : 'class_longident Grammar.Entry.e), - None, - [None, None, - [[Gramext.Snterm (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'class_longident))]]; - Grammar.Entry.obj (direction_flag : 'direction_flag Grammar.Entry.e), - None, - [None, None, - [[Gramext.Stoken ("ANTIQUOT", "to")], - Gramext.action - (fun (a : string) (loc : int * int) -> - (antiquot "to" loc a : 'direction_flag))]]; - Grammar.Entry.obj (class_expr : 'class_expr Grammar.Entry.e), - Some (Gramext.Level "simple"), - [None, None, - [[Gramext.Stoken ("", "object"); Gramext.Stoken ("ANTIQUOT", ""); - Gramext.Stoken ("", ";"); - Gramext.srules - [[Gramext.Slist0 - (Gramext.srules - [[Gramext.Snterm - (Grammar.Entry.obj - (class_str_item : 'class_str_item Grammar.Entry.e)); - Gramext.Stoken ("", ";")], - Gramext.action - (fun _ (cf : 'class_str_item) (loc : int * int) -> - (cf : 'e__30))])], - Gramext.action - (fun (a : 'e__30 list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]; - Gramext.Stoken ("", "end")], - Gramext.action - (fun _ (csl : 'a_list) _ (x : string) _ (loc : int * int) -> - (let _ = warn_antiq loc "3.05" in - Qast.Node - ("CeStr", - [Qast.Loc; Qast.Option None; - Qast.Cons (antiquot "" loc x, csl)]) : - 'class_expr)); - [Gramext.Stoken ("", "object"); Gramext.Stoken ("ANTIQUOT", ""); - Gramext.Snterm - (Grammar.Entry.obj - (class_structure : 'class_structure Grammar.Entry.e)); - Gramext.Stoken ("", "end")], - Gramext.action - (fun _ (cf : 'class_structure) (x : string) _ (loc : int * int) -> - (let _ = warn_antiq loc "3.05" in - Qast.Node ("CeStr", [Qast.Loc; antiquot "" loc x; cf]) : - 'class_expr))]]; - Grammar.Entry.obj (class_type : 'class_type Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "object"); Gramext.Stoken ("ANTIQUOT", ""); - Gramext.Stoken ("", ";"); - Gramext.srules - [[Gramext.Slist0 - (Gramext.srules - [[Gramext.Snterm - (Grammar.Entry.obj - (class_sig_item : 'class_sig_item Grammar.Entry.e)); - Gramext.Stoken ("", ";")], - Gramext.action - (fun _ (csf : 'class_sig_item) (loc : int * int) -> - (csf : 'e__32))])], - Gramext.action - (fun (a : 'e__32 list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]; - Gramext.Stoken ("", "end")], - Gramext.action - (fun _ (csf : 'a_list) _ (x : string) _ (loc : int * int) -> - (let _ = warn_antiq loc "3.05" in - Qast.Node - ("CtSig", - [Qast.Loc; Qast.Option None; - Qast.Cons (antiquot "" loc x, csf)]) : - 'class_type)); - [Gramext.Stoken ("", "object"); Gramext.Stoken ("ANTIQUOT", ""); - Gramext.srules - [[Gramext.Slist0 - (Gramext.srules - [[Gramext.Snterm - (Grammar.Entry.obj - (class_sig_item : 'class_sig_item Grammar.Entry.e)); - Gramext.Stoken ("", ";")], - Gramext.action - (fun _ (csf : 'class_sig_item) (loc : int * int) -> - (csf : 'e__31))])], - Gramext.action - (fun (a : 'e__31 list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]; - Gramext.Stoken ("", "end")], - Gramext.action - (fun _ (csf : 'a_list) (x : string) _ (loc : int * int) -> - (let _ = warn_antiq loc "3.05" in - Qast.Node ("CtSig", [Qast.Loc; antiquot "" loc x; csf]) : - 'class_type))]]; - Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), - Some (Gramext.Level "top"), - [None, None, - [[Gramext.Stoken ("", "let"); Gramext.Stoken ("ANTIQUOT", "rec"); - Gramext.srules - [[Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj - (let_binding : 'let_binding Grammar.Entry.e)), - Gramext.Stoken ("", "and"))], - Gramext.action - (fun (a : 'let_binding list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]; - Gramext.Stoken ("", "in"); Gramext.Sself], - Gramext.action - (fun (x : 'expr) _ (l : 'a_list) (r : string) _ (loc : int * int) -> - (let _ = warn_antiq loc "3.06+18" in - Qast.Node ("ExLet", [Qast.Loc; antiquot "rec" loc r; l; x]) : - 'expr))]]; - Grammar.Entry.obj (str_item : 'str_item Grammar.Entry.e), - Some (Gramext.Level "top"), - [None, None, - [[Gramext.Stoken ("", "value"); Gramext.Stoken ("ANTIQUOT", "rec"); - Gramext.srules - [[Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj - (let_binding : 'let_binding Grammar.Entry.e)), - Gramext.Stoken ("", "and"))], - Gramext.action - (fun (a : 'let_binding list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]], - Gramext.action - (fun (l : 'a_list) (r : string) _ (loc : int * int) -> - (let _ = warn_antiq loc "3.06+18" in - Qast.Node ("StVal", [Qast.Loc; antiquot "rec" loc r; l]) : - 'str_item))]]; - Grammar.Entry.obj (class_expr : 'class_expr Grammar.Entry.e), - Some (Gramext.Level "top"), - [None, None, - [[Gramext.Stoken ("", "let"); Gramext.Stoken ("ANTIQUOT", "rec"); - Gramext.srules - [[Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj - (let_binding : 'let_binding Grammar.Entry.e)), - Gramext.Stoken ("", "and"))], - Gramext.action - (fun (a : 'let_binding list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]; - Gramext.Stoken ("", "in"); Gramext.Sself], - Gramext.action - (fun (ce : 'class_expr) _ (lb : 'a_list) (r : string) _ - (loc : int * int) -> - (let _ = warn_antiq loc "3.06+18" in - Qast.Node ("CeLet", [Qast.Loc; antiquot "rec" loc r; lb; ce]) : - 'class_expr))]]; - Grammar.Entry.obj (class_str_item : 'class_str_item Grammar.Entry.e), - None, - [None, None, - [[Gramext.Stoken ("", "value"); Gramext.Stoken ("ANTIQUOT", "mut"); - Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e)); - Gramext.Snterm - (Grammar.Entry.obj - (cvalue_binding : 'cvalue_binding Grammar.Entry.e))], - Gramext.action - (fun (e : 'cvalue_binding) (lab : 'label) (mf : string) _ - (loc : int * int) -> - (let _ = warn_antiq loc "3.06+18" in - Qast.Node ("CrVal", [Qast.Loc; lab; antiquot "mut" loc mf; e]) : - 'class_str_item)); - [Gramext.Stoken ("", "inherit"); - Gramext.Snterm - (Grammar.Entry.obj (class_expr : 'class_expr Grammar.Entry.e)); - Gramext.Stoken ("ANTIQUOT", "as")], - Gramext.action - (fun (pb : string) (ce : 'class_expr) _ (loc : int * int) -> - (let _ = warn_antiq loc "3.06+18" in - Qast.Node ("CrInh", [Qast.Loc; ce; antiquot "as" loc pb]) : - 'class_str_item))]]; - Grammar.Entry.obj (class_sig_item : 'class_sig_item Grammar.Entry.e), - None, - [None, None, - [[Gramext.Stoken ("", "value"); Gramext.Stoken ("ANTIQUOT", "mut"); - Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e)); - Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], - Gramext.action - (fun (t : 'ctyp) _ (l : 'label) (mf : string) _ (loc : int * int) -> - (let _ = warn_antiq loc "3.06+18" in - Qast.Node ("CgVal", [Qast.Loc; l; antiquot "mut" loc mf; t]) : - 'class_sig_item))]]]);; - -Grammar.extend - (let _ = (str_item : 'str_item Grammar.Entry.e) - and _ = (sig_item : 'sig_item Grammar.Entry.e) in - let grammar_entry_create s = - Grammar.Entry.create (Grammar.of_entry str_item) s - in - let dir_param : 'dir_param Grammar.Entry.e = - grammar_entry_create "dir_param" - in - [Grammar.Entry.obj (str_item : 'str_item Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "#"); - Gramext.Snterm - (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e)); - Gramext.Snterm - (Grammar.Entry.obj (dir_param : 'dir_param Grammar.Entry.e))], - Gramext.action - (fun (dp : 'dir_param) (n : 'a_LIDENT) _ (loc : int * int) -> - (Qast.Node ("StDir", [Qast.Loc; n; dp]) : 'str_item))]]; - Grammar.Entry.obj (sig_item : 'sig_item Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "#"); - Gramext.Snterm - (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e)); - Gramext.Snterm - (Grammar.Entry.obj (dir_param : 'dir_param Grammar.Entry.e))], - Gramext.action - (fun (dp : 'dir_param) (n : 'a_LIDENT) _ (loc : int * int) -> - (Qast.Node ("SgDir", [Qast.Loc; n; dp]) : 'sig_item))]]; - Grammar.Entry.obj (dir_param : 'dir_param Grammar.Entry.e), None, - [None, None, - [[], - Gramext.action - (fun (loc : int * int) -> (Qast.Option None : 'dir_param)); - [Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) (loc : int * int) -> - (Qast.Option (Some e) : 'dir_param)); - [Gramext.Stoken ("ANTIQUOT", "opt")], - Gramext.action - (fun (a : string) (loc : int * int) -> - (antiquot "opt" loc a : 'dir_param))]]]);; - -(* Antiquotations *) - -Grammar.extend - [Grammar.Entry.obj (module_expr : 'module_expr Grammar.Entry.e), - Some (Gramext.Level "simple"), - [None, None, - [[Gramext.Stoken ("ANTIQUOT", "")], - Gramext.action - (fun (a : string) (loc : int * int) -> - (antiquot "" loc a : 'module_expr)); - [Gramext.Stoken ("ANTIQUOT", "mexp")], - Gramext.action - (fun (a : string) (loc : int * int) -> - (antiquot "mexp" loc a : 'module_expr))]]; - Grammar.Entry.obj (str_item : 'str_item Grammar.Entry.e), - Some (Gramext.Level "top"), - [None, None, - [[Gramext.Stoken ("ANTIQUOT", "")], - Gramext.action - (fun (a : string) (loc : int * int) -> - (antiquot "" loc a : 'str_item)); - [Gramext.Stoken ("ANTIQUOT", "stri")], - Gramext.action - (fun (a : string) (loc : int * int) -> - (antiquot "stri" loc a : 'str_item))]]; - Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e), - Some (Gramext.Level "simple"), - [None, None, - [[Gramext.Stoken ("ANTIQUOT", "")], - Gramext.action - (fun (a : string) (loc : int * int) -> - (antiquot "" loc a : 'module_type)); - [Gramext.Stoken ("ANTIQUOT", "mtyp")], - Gramext.action - (fun (a : string) (loc : int * int) -> - (antiquot "mtyp" loc a : 'module_type))]]; - Grammar.Entry.obj (sig_item : 'sig_item Grammar.Entry.e), - Some (Gramext.Level "top"), - [None, None, - [[Gramext.Stoken ("ANTIQUOT", "")], - Gramext.action - (fun (a : string) (loc : int * int) -> - (antiquot "" loc a : 'sig_item)); - [Gramext.Stoken ("ANTIQUOT", "sigi")], - Gramext.action - (fun (a : string) (loc : int * int) -> - (antiquot "sigi" loc a : 'sig_item))]]; - Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), - Some (Gramext.Level "simple"), - [None, None, - [[Gramext.Stoken ("", "("); - Gramext.Snterm (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e)); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (el : 'a_list) _ (loc : int * int) -> - (Qast.Node ("ExTup", [Qast.Loc; el]) : 'expr)); - [Gramext.Stoken ("ANTIQUOT", "anti")], - Gramext.action - (fun (a : string) (loc : int * int) -> - (Qast.Node ("ExAnt", [Qast.Loc; antiquot "anti" loc a]) : 'expr)); - [Gramext.Stoken ("ANTIQUOT", "")], - Gramext.action - (fun (a : string) (loc : int * int) -> (antiquot "" loc a : 'expr)); - [Gramext.Stoken ("ANTIQUOT", "exp")], - Gramext.action - (fun (a : string) (loc : int * int) -> - (antiquot "exp" loc a : 'expr))]]; - Grammar.Entry.obj (patt : 'patt Grammar.Entry.e), - Some (Gramext.Level "simple"), - [None, None, - [[Gramext.Stoken ("", "("); - Gramext.Snterm (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e)); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (pl : 'a_list) _ (loc : int * int) -> - (Qast.Node ("PaTup", [Qast.Loc; pl]) : 'patt)); - [Gramext.Stoken ("ANTIQUOT", "anti")], - Gramext.action - (fun (a : string) (loc : int * int) -> - (Qast.Node ("PaAnt", [Qast.Loc; antiquot "anti" loc a]) : 'patt)); - [Gramext.Stoken ("ANTIQUOT", "")], - Gramext.action - (fun (a : string) (loc : int * int) -> (antiquot "" loc a : 'patt)); - [Gramext.Stoken ("ANTIQUOT", "pat")], - Gramext.action - (fun (a : string) (loc : int * int) -> - (antiquot "pat" loc a : 'patt))]]; - Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "("); - Gramext.Snterm (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e)); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (pl : 'a_list) _ (loc : int * int) -> - (Qast.Node ("PaTup", [Qast.Loc; pl]) : 'ipatt)); - [Gramext.Stoken ("ANTIQUOT", "anti")], - Gramext.action - (fun (a : string) (loc : int * int) -> - (Qast.Node ("PaAnt", [Qast.Loc; antiquot "anti" loc a]) : 'ipatt)); - [Gramext.Stoken ("ANTIQUOT", "")], - Gramext.action - (fun (a : string) (loc : int * int) -> (antiquot "" loc a : 'ipatt)); - [Gramext.Stoken ("ANTIQUOT", "pat")], - Gramext.action - (fun (a : string) (loc : int * int) -> - (antiquot "pat" loc a : 'ipatt))]]; - Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e), - Some (Gramext.Level "simple"), - [None, None, - [[Gramext.Stoken ("", "("); - Gramext.Snterm (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e)); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (tl : 'a_list) _ (loc : int * int) -> - (Qast.Node ("TyTup", [Qast.Loc; tl]) : 'ctyp)); - [Gramext.Stoken ("ANTIQUOT", "")], - Gramext.action - (fun (a : string) (loc : int * int) -> (antiquot "" loc a : 'ctyp)); - [Gramext.Stoken ("ANTIQUOT", "typ")], - Gramext.action - (fun (a : string) (loc : int * int) -> - (antiquot "typ" loc a : 'ctyp))]]; - Grammar.Entry.obj (class_expr : 'class_expr Grammar.Entry.e), - Some (Gramext.Level "simple"), - [None, None, - [[Gramext.Stoken ("ANTIQUOT", "")], - Gramext.action - (fun (a : string) (loc : int * int) -> - (antiquot "" loc a : 'class_expr))]]; - Grammar.Entry.obj (class_str_item : 'class_str_item Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("ANTIQUOT", "")], - Gramext.action - (fun (a : string) (loc : int * int) -> - (antiquot "" loc a : 'class_str_item))]]; - Grammar.Entry.obj (class_sig_item : 'class_sig_item Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("ANTIQUOT", "")], - Gramext.action - (fun (a : string) (loc : int * int) -> - (antiquot "" loc a : 'class_sig_item))]]; - Grammar.Entry.obj (class_type : 'class_type Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("ANTIQUOT", "")], - Gramext.action - (fun (a : string) (loc : int * int) -> - (antiquot "" loc a : 'class_type))]]; - Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), - Some (Gramext.Level "simple"), - [None, None, - [[Gramext.Stoken ("", "{<"); - Gramext.Snterm (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e)); - Gramext.Stoken ("", ">}")], - Gramext.action - (fun _ (fel : 'a_list) _ (loc : int * int) -> - (Qast.Node ("ExOvr", [Qast.Loc; fel]) : 'expr))]]; - Grammar.Entry.obj (patt : 'patt Grammar.Entry.e), - Some (Gramext.Level "simple"), - [None, None, - [[Gramext.Stoken ("", "#"); - Gramext.Snterm (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) _ (loc : int * int) -> - (Qast.Node ("PaTyp", [Qast.Loc; a]) : 'patt))]]; - Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("ANTIQUOT", "list")], - Gramext.action - (fun (a : string) (loc : int * int) -> - (antiquot "list" loc a : 'a_list))]]; - Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("ANTIQUOT", "opt")], - Gramext.action - (fun (a : string) (loc : int * int) -> - (antiquot "opt" loc a : 'a_opt))]]; - Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("UIDENT", "")], - Gramext.action - (fun (i : string) (loc : int * int) -> (Qast.Str i : 'a_UIDENT)); - [Gramext.Stoken ("ANTIQUOT", "")], - Gramext.action - (fun (a : string) (loc : int * int) -> - (antiquot "" loc a : 'a_UIDENT)); - [Gramext.Stoken ("ANTIQUOT", "uid")], - Gramext.action - (fun (a : string) (loc : int * int) -> - (antiquot "uid" loc a : 'a_UIDENT))]]; - Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("LIDENT", "")], - Gramext.action - (fun (i : string) (loc : int * int) -> (Qast.Str i : 'a_LIDENT)); - [Gramext.Stoken ("ANTIQUOT", "")], - Gramext.action - (fun (a : string) (loc : int * int) -> - (antiquot "" loc a : 'a_LIDENT)); - [Gramext.Stoken ("ANTIQUOT", "lid")], - Gramext.action - (fun (a : string) (loc : int * int) -> - (antiquot "lid" loc a : 'a_LIDENT))]]; - Grammar.Entry.obj (a_INT : 'a_INT Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("INT", "")], - Gramext.action - (fun (s : string) (loc : int * int) -> (Qast.Str s : 'a_INT)); - [Gramext.Stoken ("ANTIQUOT", "")], - Gramext.action - (fun (a : string) (loc : int * int) -> (antiquot "" loc a : 'a_INT)); - [Gramext.Stoken ("ANTIQUOT", "int")], - Gramext.action - (fun (a : string) (loc : int * int) -> - (antiquot "int" loc a : 'a_INT))]]; - Grammar.Entry.obj (a_FLOAT : 'a_FLOAT Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("FLOAT", "")], - Gramext.action - (fun (s : string) (loc : int * int) -> (Qast.Str s : 'a_FLOAT)); - [Gramext.Stoken ("ANTIQUOT", "")], - Gramext.action - (fun (a : string) (loc : int * int) -> (antiquot "" loc a : 'a_FLOAT)); - [Gramext.Stoken ("ANTIQUOT", "flo")], - Gramext.action - (fun (a : string) (loc : int * int) -> - (antiquot "flo" loc a : 'a_FLOAT))]]; - Grammar.Entry.obj (a_STRING : 'a_STRING Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("STRING", "")], - Gramext.action - (fun (s : string) (loc : int * int) -> (Qast.Str s : 'a_STRING)); - [Gramext.Stoken ("ANTIQUOT", "")], - Gramext.action - (fun (a : string) (loc : int * int) -> - (antiquot "" loc a : 'a_STRING)); - [Gramext.Stoken ("ANTIQUOT", "str")], - Gramext.action - (fun (a : string) (loc : int * int) -> - (antiquot "str" loc a : 'a_STRING))]]; - Grammar.Entry.obj (a_CHAR : 'a_CHAR Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("CHAR", "")], - Gramext.action - (fun (s : string) (loc : int * int) -> (Qast.Str s : 'a_CHAR)); - [Gramext.Stoken ("ANTIQUOT", "")], - Gramext.action - (fun (a : string) (loc : int * int) -> (antiquot "" loc a : 'a_CHAR)); - [Gramext.Stoken ("ANTIQUOT", "chr")], - Gramext.action - (fun (a : string) (loc : int * int) -> - (antiquot "chr" loc a : 'a_CHAR))]]; - Grammar.Entry.obj (a_TILDEIDENT : 'a_TILDEIDENT Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("TILDEIDENT", "")], - Gramext.action - (fun (s : string) (loc : int * int) -> (Qast.Str s : 'a_TILDEIDENT)); - [Gramext.Stoken ("", "~"); Gramext.Stoken ("ANTIQUOT", "")], - Gramext.action - (fun (a : string) _ (loc : int * int) -> - (antiquot "" loc a : 'a_TILDEIDENT))]]; - Grammar.Entry.obj (a_LABEL : 'a_LABEL Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("LABEL", "")], - Gramext.action - (fun (s : string) (loc : int * int) -> (Qast.Str s : 'a_LABEL))]]; - Grammar.Entry.obj (a_QUESTIONIDENT : 'a_QUESTIONIDENT Grammar.Entry.e), - None, - [None, None, - [[Gramext.Stoken ("QUESTIONIDENT", "")], - Gramext.action - (fun (s : string) (loc : int * int) -> - (Qast.Str s : 'a_QUESTIONIDENT)); - [Gramext.Stoken ("", "?"); Gramext.Stoken ("ANTIQUOT", "")], - Gramext.action - (fun (a : string) _ (loc : int * int) -> - (antiquot "" loc a : 'a_QUESTIONIDENT))]]; - Grammar.Entry.obj (a_OPTLABEL : 'a_OPTLABEL Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("OPTLABEL", "")], - Gramext.action - (fun (s : string) (loc : int * int) -> (Qast.Str s : 'a_OPTLABEL))]]];; - -let apply_entry e = - let f s = Grammar.Entry.parse e (Stream.of_string s) in - let expr s = Qast.to_expr (f s) in - let patt s = Qast.to_patt (f s) in Quotation.ExAst (expr, patt) -;; - -let sig_item_eoi = Grammar.Entry.create gram "signature item" in -Grammar.extend - [Grammar.Entry.obj (sig_item_eoi : 'sig_item_eoi Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj (sig_item : 'sig_item Grammar.Entry.e)); - Gramext.Stoken ("EOI", "")], - Gramext.action - (fun _ (x : 'sig_item) (loc : int * int) -> (x : 'sig_item_eoi))]]]; -Quotation.add "sig_item" (apply_entry sig_item_eoi);; - -let str_item_eoi = Grammar.Entry.create gram "structure item" in -Grammar.extend - [Grammar.Entry.obj (str_item_eoi : 'str_item_eoi Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj (str_item : 'str_item Grammar.Entry.e)); - Gramext.Stoken ("EOI", "")], - Gramext.action - (fun _ (x : 'str_item) (loc : int * int) -> (x : 'str_item_eoi))]]]; -Quotation.add "str_item" (apply_entry str_item_eoi);; - -let ctyp_eoi = Grammar.Entry.create gram "type" in -Grammar.extend - [Grammar.Entry.obj (ctyp_eoi : 'ctyp_eoi Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("EOI", "")], - Gramext.action - (fun _ (x : 'ctyp) (loc : int * int) -> (x : 'ctyp_eoi))]]]; -Quotation.add "ctyp" (apply_entry ctyp_eoi);; - -let patt_eoi = Grammar.Entry.create gram "pattern" in -Grammar.extend - [Grammar.Entry.obj (patt_eoi : 'patt_eoi Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e)); - Gramext.Stoken ("EOI", "")], - Gramext.action - (fun _ (x : 'patt) (loc : int * int) -> (x : 'patt_eoi))]]]; -Quotation.add "patt" (apply_entry patt_eoi);; - -let expr_eoi = Grammar.Entry.create gram "expression" in -Grammar.extend - [Grammar.Entry.obj (expr_eoi : 'expr_eoi Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e)); - Gramext.Stoken ("EOI", "")], - Gramext.action - (fun _ (x : 'expr) (loc : int * int) -> (x : 'expr_eoi))]]]; -Quotation.add "expr" (apply_entry expr_eoi);; - -let module_type_eoi = Grammar.Entry.create gram "module type" in -Grammar.extend - [Grammar.Entry.obj (module_type_eoi : 'module_type_eoi Grammar.Entry.e), - None, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e)); - Gramext.Stoken ("EOI", "")], - Gramext.action - (fun _ (x : 'module_type) (loc : int * int) -> - (x : 'module_type_eoi))]]]; -Quotation.add "module_type" (apply_entry module_type_eoi);; - -let module_expr_eoi = Grammar.Entry.create gram "module expression" in -Grammar.extend - [Grammar.Entry.obj (module_expr_eoi : 'module_expr_eoi Grammar.Entry.e), - None, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj (module_expr : 'module_expr Grammar.Entry.e)); - Gramext.Stoken ("EOI", "")], - Gramext.action - (fun _ (x : 'module_expr) (loc : int * int) -> - (x : 'module_expr_eoi))]]]; -Quotation.add "module_expr" (apply_entry module_expr_eoi);; - -let class_type_eoi = Grammar.Entry.create gram "class_type" in -Grammar.extend - [Grammar.Entry.obj (class_type_eoi : 'class_type_eoi Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj (class_type : 'class_type Grammar.Entry.e)); - Gramext.Stoken ("EOI", "")], - Gramext.action - (fun _ (x : 'class_type) (loc : int * int) -> - (x : 'class_type_eoi))]]]; -Quotation.add "class_type" (apply_entry class_type_eoi);; - -let class_expr_eoi = Grammar.Entry.create gram "class_expr" in -Grammar.extend - [Grammar.Entry.obj (class_expr_eoi : 'class_expr_eoi Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj (class_expr : 'class_expr Grammar.Entry.e)); - Gramext.Stoken ("EOI", "")], - Gramext.action - (fun _ (x : 'class_expr) (loc : int * int) -> - (x : 'class_expr_eoi))]]]; -Quotation.add "class_expr" (apply_entry class_expr_eoi);; - -let class_sig_item_eoi = Grammar.Entry.create gram "class_sig_item" in -Grammar.extend - [Grammar.Entry.obj - (class_sig_item_eoi : 'class_sig_item_eoi Grammar.Entry.e), - None, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj - (class_sig_item : 'class_sig_item Grammar.Entry.e)); - Gramext.Stoken ("EOI", "")], - Gramext.action - (fun _ (x : 'class_sig_item) (loc : int * int) -> - (x : 'class_sig_item_eoi))]]]; -Quotation.add "class_sig_item" (apply_entry class_sig_item_eoi);; - -let class_str_item_eoi = Grammar.Entry.create gram "class_str_item" in -Grammar.extend - [Grammar.Entry.obj - (class_str_item_eoi : 'class_str_item_eoi Grammar.Entry.e), - None, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj - (class_str_item : 'class_str_item Grammar.Entry.e)); - Gramext.Stoken ("EOI", "")], - Gramext.action - (fun _ (x : 'class_str_item) (loc : int * int) -> - (x : 'class_str_item_eoi))]]]; -Quotation.add "class_str_item" (apply_entry class_str_item_eoi);; - -let with_constr_eoi = Grammar.Entry.create gram "with constr" in -Grammar.extend - [Grammar.Entry.obj (with_constr_eoi : 'with_constr_eoi Grammar.Entry.e), - None, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj (with_constr : 'with_constr Grammar.Entry.e)); - Gramext.Stoken ("EOI", "")], - Gramext.action - (fun _ (x : 'with_constr) (loc : int * int) -> - (x : 'with_constr_eoi))]]]; -Quotation.add "with_constr" (apply_entry with_constr_eoi);; - -let row_field_eoi = Grammar.Entry.create gram "row_field" in -Grammar.extend - [Grammar.Entry.obj (row_field_eoi : 'row_field_eoi Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj (row_field : 'row_field Grammar.Entry.e)); - Gramext.Stoken ("EOI", "")], - Gramext.action - (fun _ (x : 'row_field) (loc : int * int) -> (x : 'row_field_eoi))]]]; -Quotation.add "row_field" (apply_entry row_field_eoi);; diff --git a/camlp4/ocaml_src/odyl/.cvsignore b/camlp4/ocaml_src/odyl/.cvsignore deleted file mode 100644 index 18deb61827..0000000000 --- a/camlp4/ocaml_src/odyl/.cvsignore +++ /dev/null @@ -1,2 +0,0 @@ -odyl -odyl_config.ml diff --git a/camlp4/ocaml_src/odyl/.depend b/camlp4/ocaml_src/odyl/.depend deleted file mode 100644 index b63c10b0b6..0000000000 --- a/camlp4/ocaml_src/odyl/.depend +++ /dev/null @@ -1,6 +0,0 @@ -odyl_main.cmo: $(OTOP)/otherlibs/dynlink/dynlink.cmi odyl_config.cmo \ - odyl_main.cmi -odyl_main.cmx: odyl_config.cmx \ - odyl_main.cmi -odyl.cmo: odyl_config.cmo odyl_main.cmi -odyl.cmx: odyl_config.cmx odyl_main.cmx diff --git a/camlp4/ocaml_src/odyl/Makefile b/camlp4/ocaml_src/odyl/Makefile deleted file mode 100644 index bd59608b8e..0000000000 --- a/camlp4/ocaml_src/odyl/Makefile +++ /dev/null @@ -1,61 +0,0 @@ -# This file has been generated by program: do not edit! - -include ../../config/Makefile - -SHELL=/bin/sh - -INCLUDES=-I $(OTOP)/otherlibs/dynlink -OCAMLCFLAGS=-warn-error A $(INCLUDES) -LINKFLAGS=$(INCLUDES) - -OBJS=odyl_config.cmo odyl_main.cmo - -all: odyl$(EXE) - -opt: odyl.cmxa odyl.cmx - -odyl$(EXE): odyl.cma odyl.cmo - $(OCAMLC) odyl.cma odyl.cmo -o odyl$(EXE) - -odyl.cma: $(OBJS) - $(OCAMLC) $(LINKFLAGS) dynlink.cma $(OBJS) -a -o odyl.cma - -odyl.cmxa: $(OBJS:.cmo=.cmx) - $(OCAMLOPT) $(LINKFLAGS) $(OBJS:.cmo=.cmx) -a -o odyl.cmxa - -odyl_main.cmx: odyl_main.ml - $(CAMLP4_COMM) -nolib -DOPT -o odyl_main.ppo odyl_main.ml - $(OCAMLOPT) -c -impl odyl_main.ppo - rm -f odyl_main.ppo - -odyl_config.ml: - (echo 'let standard_library ='; \ - echo ' try Sys.getenv "CAMLP4LIB" with Not_found -> '; \ - echo ' try Sys.getenv "OCAMLLIB" ^ "/camlp4" with Not_found -> '; \ - echo ' try Sys.getenv "CAMLLIB" ^ "/camlp4" with Not_found -> '; \ - echo ' "$(LIBDIR)/camlp4"') \ - | sed -e 's|\\|/|g' > odyl_config.ml - -clean:: - rm -f *.cm* *.pp[io] *.$(O) *.bak .*.bak *.out *.opt *.$(A) - rm -f odyl_config.ml odyl$(EXE) - -depend: - cp .depend .depend.bak - > .depend - @for i in *.mli *.ml; do \ - ../tools/apply.sh pr_depend.cmo -- $(INCLUDES) $$i | \ - sed -e 's| $(OTOP)/otherlibs/dynlink/dynlink.cmx||' | \ - sed -e 's| \.\./\.\.| $$(OTOP)|g' >> .depend; \ - done - -promote: - -compare: - -install: - -$(MKDIR) "$(LIBDIR)/camlp4" "$(BINDIR)" - cp odyl.cmo odyl.cma odyl_main.cmi $(LIBDIR)/camlp4/. - if test -f odyl.cmxa; then cp odyl.cmxa odyl.$(A) $(LIBDIR)/camlp4/.; fi - -include .depend diff --git a/camlp4/ocaml_src/odyl/Makefile.Mac b/camlp4/ocaml_src/odyl/Makefile.Mac deleted file mode 100644 index 41b16d30e4..0000000000 --- a/camlp4/ocaml_src/odyl/Makefile.Mac +++ /dev/null @@ -1,49 +0,0 @@ -####################################################################### -# # -# Camlp4 # -# # -# Damien Doligez, projet Para, INRIA Rocquencourt # -# # -# Copyright 1999 Institut National de Recherche en Informatique et # -# en Automatique. Distributed only by permission. # -# # -####################################################################### - -# This file has been generated by program: do not edit! - -INCLUDES = -I "{OTOP}otherlibs:dynlink:" -OCAMLCFLAGS = {INCLUDES} -LINKFLAGS = {INCLUDES} - -OBJS = odyl_config.cmo odyl_main.cmo - -all Ä odyl - -odyl Ä odyl.cma odyl.cmo - {OCAMLC} odyl.cma odyl.cmo -o odyl - -odyl.cma Ä {OBJS} - {OCAMLC} {LINKFLAGS} dynlink.cma {OBJS} -a -o odyl.cma - -odyl_config.cmo Ä - echo 'let standard_library =' > odyl_config.ml - echo ' try Sys.getenv "CAMLP4LIB" with' >> odyl_config.ml - echo ' Not_found -> "'{P4LIBDIR}'"' >> odyl_config.ml - {OCAMLC} {OCAMLCFLAGS} -c odyl_config.ml - -clean ÄÄ - delete -i odyl_config.ml odyl - -{dependrule} - -promote Ä $OutOfDate - -compare Ä $OutOfDate - -install Ä - (newfolder "{P4LIBDIR}" || set status 0) ³ dev:null - (newfolder "{BINDIR}" || set status 0) ³ dev:null - duplicate -y odyl.cmo odyl.cma "{P4LIBDIR}" - duplicate -y odyl "{BINDIR}" - -{defrules} diff --git a/camlp4/ocaml_src/odyl/Makefile.Mac.depend b/camlp4/ocaml_src/odyl/Makefile.Mac.depend deleted file mode 100644 index adaff27755..0000000000 --- a/camlp4/ocaml_src/odyl/Makefile.Mac.depend +++ /dev/null @@ -1,4 +0,0 @@ -odyl_main.cmoÄ odyl_config.cmo odyl_main.cmi -odyl_main.cmxÄ odyl_config.cmx odyl_main.cmi -odyl.cmoÄ odyl_config.cmo odyl_main.cmi -odyl.cmxÄ odyl_config.cmx odyl_main.cmx diff --git a/camlp4/ocaml_src/odyl/odyl.ml b/camlp4/ocaml_src/odyl/odyl.ml deleted file mode 100644 index 096e13eeb4..0000000000 --- a/camlp4/ocaml_src/odyl/odyl.ml +++ /dev/null @@ -1,50 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2001 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* This file has been generated by program: do not edit! *) - -let apply_load () = - let i = ref 1 in - let stop = ref false in - while not !stop && !i < Array.length Sys.argv do - let s = Sys.argv.(!i) in - if s = "-I" && !i + 1 < Array.length Sys.argv then - begin Odyl_main.directory Sys.argv.(!i + 1); i := !i + 2 end - else if s = "-nolib" then begin Odyl_main.nolib := true; incr i end - else if s = "-where" then - begin - print_string Odyl_config.standard_library; - print_newline (); - flush stdout; - exit 0 - end - else if s = "--" then begin incr i; stop := true; () end - else if String.length s > 0 && s.[0] == '-' then stop := true - else if - Filename.check_suffix s ".cmo" || Filename.check_suffix s ".cma" - then - begin Odyl_main.loadfile s; incr i end - else stop := true - done -;; - -let main () = - try apply_load (); !(Odyl_main.go) () with - Odyl_main.Error (fname, str) -> - flush stdout; - Printf.eprintf "Error while loading \"%s\": " fname; - Printf.eprintf "%s.\n" str; - flush stderr; - exit 2 -;; - -Printexc.catch main ();; diff --git a/camlp4/ocaml_src/odyl/odyl_main.ml b/camlp4/ocaml_src/odyl/odyl_main.ml deleted file mode 100644 index 22e5e65d93..0000000000 --- a/camlp4/ocaml_src/odyl/odyl_main.ml +++ /dev/null @@ -1,77 +0,0 @@ -(* camlp4r pa_macro.cmo *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2001 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* This file has been generated by program: do not edit! *) - -let go = ref (fun () -> ());; -let name = ref "odyl";; - -let first_arg_no_load () = - let rec loop i = - if i < Array.length Sys.argv then - match Sys.argv.(i) with - "-I" -> loop (i + 2) - | "-nolib" -> loop (i + 1) - | "-where" -> loop (i + 1) - | "--" -> i + 1 - | s -> - if Filename.check_suffix s ".cmo" || Filename.check_suffix s ".cma" - then - loop (i + 1) - else i - else i - in - loop 1 -;; - -Arg.current := first_arg_no_load () - 1;; - -(* Load files in core *) - -let find_in_path path name = - if not (Filename.is_implicit name) then - if Sys.file_exists name then name else raise Not_found - else - let rec try_dir = - function - [] -> raise Not_found - | dir :: rem -> - let fullname = Filename.concat dir name in - if Sys.file_exists fullname then fullname else try_dir rem - in - try_dir path -;; - -exception Error of string * string;; - -let nolib = ref false;; -let initialized = ref false;; -let path = ref ([] : string list);; - -let loadfile file = - if not !initialized then - begin - begin Dynlink.init (); Dynlink.allow_unsafe_modules true end; - initialized := true - end; - let path = - if !nolib then !path else Odyl_config.standard_library :: !path - in - let fname = - try find_in_path (List.rev 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)) -;; - -let directory d = path := d :: !path;; diff --git a/camlp4/ocaml_src/odyl/odyl_main.mli b/camlp4/ocaml_src/odyl/odyl_main.mli deleted file mode 100644 index be441a6c84..0000000000 --- a/camlp4/ocaml_src/odyl/odyl_main.mli +++ /dev/null @@ -1,13 +0,0 @@ -(* camlp4r *) -(* This file has been generated by program: do not edit! *) - -exception Error of string * string;; - -val nolib : bool ref;; -val initialized : bool ref;; -val path : string list ref;; -val loadfile : string -> unit;; -val directory : string -> unit;; - -val go : (unit -> unit) ref;; -val name : string ref;; diff --git a/camlp4/ocaml_src/tools/camlp4_comm.mpw b/camlp4/ocaml_src/tools/camlp4_comm.mpw deleted file mode 100644 index ff837e7745..0000000000 --- a/camlp4/ocaml_src/tools/camlp4_comm.mpw +++ /dev/null @@ -1,27 +0,0 @@ -####################################################################### -# # -# Camlp4 # -# # -# Damien Doligez, projet Para, INRIA Rocquencourt # -# # -# Copyright 1999 Institut National de Recherche en Informatique et # -# en Automatique. Distributed only by permission. # -# # -####################################################################### - -# $Id$ - -set echo 0 - -exit if {#} < 1 - -if "{1}" =~ /(Å)¨0.mli/ - echo duplicate -y {1} {¨0}.ppi - duplicate -y "{1}" "{¨0}.ppi" -else if "{1}" =~ /(Å)¨0.ml/ - echo duplicate -y {1} {¨0}.ppo - duplicate -y "{1}" "{¨0}.ppo" -else - echo duplicate -y {1} {1}.ppo - duplicate -y "{1}" "{1}.ppo" -end diff --git a/camlp4/ocaml_src/tools/camlp4_comm.sh b/camlp4/ocaml_src/tools/camlp4_comm.sh deleted file mode 100755 index 357a929520..0000000000 --- a/camlp4/ocaml_src/tools/camlp4_comm.sh +++ /dev/null @@ -1,9 +0,0 @@ -#!/bin/sh - -if test "`basename $1 .mli`.mli" = "$1"; then - echo cp $1 `basename $1 .mli`.ppi - cp $1 `basename $1 .mli`.ppi -else - echo cp $1 `basename $1 .ml`.ppo - cp $1 `basename $1 .ml`.ppo -fi diff --git a/camlp4/ocaml_src/tools/extract_crc.mpw b/camlp4/ocaml_src/tools/extract_crc.mpw deleted file mode 100644 index 91dc4ddf9a..0000000000 --- a/camlp4/ocaml_src/tools/extract_crc.mpw +++ /dev/null @@ -1,3 +0,0 @@ -# $Id$ - -"{OTOP}boot:ocamlrun" "{OTOP}otherlibs:dynlink:extract_crc" {"parameters"} diff --git a/camlp4/ocaml_src/tools/extract_crc.sh b/camlp4/ocaml_src/tools/extract_crc.sh deleted file mode 100755 index e69de29bb2..0000000000 diff --git a/camlp4/ocaml_src/tools/ocamlc.mpw b/camlp4/ocaml_src/tools/ocamlc.mpw deleted file mode 100644 index 7e594c03eb..0000000000 --- a/camlp4/ocaml_src/tools/ocamlc.mpw +++ /dev/null @@ -1,3 +0,0 @@ -# - -"{OTOP}boot:ocamlrun" "{OTOP}ocamlc" -I "{OTOP}stdlib" {"parameters"} diff --git a/camlp4/ocaml_src/tools/ocamlc.sh b/camlp4/ocaml_src/tools/ocamlc.sh deleted file mode 100755 index ee654c2c6f..0000000000 --- a/camlp4/ocaml_src/tools/ocamlc.sh +++ /dev/null @@ -1,8 +0,0 @@ -#!/bin/sh -e -if test "`basename $OTOP`" != "ocaml_stuff"; then - COMM=$OTOP/ocamlcomp.sh -else - COMM=ocamlc$OPT -fi -echo $COMM $* -$COMM $* diff --git a/camlp4/ocaml_src/tools/ocamlopt.sh b/camlp4/ocaml_src/tools/ocamlopt.sh deleted file mode 100755 index 1fb669d670..0000000000 --- a/camlp4/ocaml_src/tools/ocamlopt.sh +++ /dev/null @@ -1,8 +0,0 @@ -#!/bin/sh -e -if test "`basename $OTOP`" != "ocaml_stuff"; then - COMM=$OTOP/ocamlcompopt.sh -else - COMM=ocamlopt$OPT -fi -echo $COMM $* -$COMM $* diff --git a/camlp4/ocaml_stuff/otherlibs/dynlink/.depend b/camlp4/ocaml_stuff/otherlibs/dynlink/.depend deleted file mode 100644 index e69de29bb2..0000000000 diff --git a/camlp4/ocaml_stuff/parsing/.depend b/camlp4/ocaml_stuff/parsing/.depend deleted file mode 100644 index 4364f56e08..0000000000 --- a/camlp4/ocaml_stuff/parsing/.depend +++ /dev/null @@ -1,2 +0,0 @@ -location.cmi: ../utils/warnings.cmi -parsetree.cmi: asttypes.cmi location.cmi longident.cmi diff --git a/camlp4/ocaml_stuff/utils/.depend b/camlp4/ocaml_stuff/utils/.depend deleted file mode 100644 index 2804128851..0000000000 --- a/camlp4/ocaml_stuff/utils/.depend +++ /dev/null @@ -1,2 +0,0 @@ -config.cmo: config.cmi -config.cmx: config.cmi diff --git a/camlp4/ocpp/.cvsignore b/camlp4/ocpp/.cvsignore deleted file mode 100644 index baef26c63b..0000000000 --- a/camlp4/ocpp/.cvsignore +++ /dev/null @@ -1,3 +0,0 @@ -*.cm[oia] -ocpp -crc.ml diff --git a/camlp4/ocpp/.depend b/camlp4/ocpp/.depend deleted file mode 100644 index e69de29bb2..0000000000 diff --git a/camlp4/ocpp/Makefile b/camlp4/ocpp/Makefile deleted file mode 100644 index 60729e323c..0000000000 --- a/camlp4/ocpp/Makefile +++ /dev/null @@ -1,25 +0,0 @@ -# $Id$ - -include ../config/Makefile - -SHELL=/bin/sh - -INCLUDES=-I ../camlp4 -I ../boot -I ../odyl -I $(OTOP)/otherlibs/dynlink -OCAMLCFLAGS=-warn-error A $(INCLUDES) -LINKFLAGS=$(INCLUDES) -OBJS=ocpp.cmo - -all: ocpp$(EXE) - -ocpp$(EXE): $(OBJS) - $(OCAMLC) $(LINKFLAGS) ../boot/stdpp.cmo ../camlp4/quotation.cmo ../odyl/odyl.cma $(OBJS) ../odyl/odyl.cmo -linkall -o ocpp$(EXE) - -clean:: - rm -f *.cm[ioa] *.pp[io] *.o *.out *.bak .*.bak ocpp$(EXE) - -install: - -$(MKDIR) "$(LIBDIR)/camlp4" "$(BINDIR)" - cp $(OBJS) "$(LIBDIR)/camlp4/." - cp ocpp$(EXE) "$(BINDIR)/." - -depend: diff --git a/camlp4/ocpp/Makefile.Mac b/camlp4/ocpp/Makefile.Mac deleted file mode 100644 index 5994a500c4..0000000000 --- a/camlp4/ocpp/Makefile.Mac +++ /dev/null @@ -1,41 +0,0 @@ -####################################################################### -# # -# Camlp4 # -# # -# Damien Doligez, projet Para, INRIA Rocquencourt # -# # -# Copyright 1999 Institut National de Recherche en Informatique et # -# en Automatique. Distributed only by permission. # -# # -####################################################################### - -# $Id$ - -INCLUDES = -I ::camlp4: -I ::boot: -I ::odyl: -I "{OTOP}otherlibs:dynlink:" -OCAMLCFLAGS = {INCLUDES} -LINKFLAGS = {INCLUDES} -OBJS = crc.cmo ocpp.cmo -INTERFACES = -I "{OLIBDIR}" Arg Array Callback Char Digest Filename Format ¶ - Gc Genlex Hashtbl Lexing List Map Obj Oo Parsing Pervasives ¶ - Printexc Printf Queue Random Set Sort Stack Stream String Sys ¶ - Weak -I ::boot: Gramext Grammar Plexer Stdpp Token -I ::camlp4: ¶ - MLast Quotation - -all Ä ocpp - -ocpp Ä {OBJS} - {OCAMLC} {LINKFLAGS} ::boot:stdpp.cmo ::camlp4:quotation.cmo ¶ - ::odyl:odyl.cma {OBJS} ::odyl:odyl.cmo -linkall -o ocpp - -clean ÄÄ - delete -i ocpp - -install Ä - (newfolder "{P4LIBDIR}" || set status 0) ³ dev:null - (newfolder "{BINDIR}" || set status 0) ³ dev:null - duplicate -y {OBJS} "{P4LIBDIR}" - duplicate -y ocpp "{BINDIR}" - -depend Ä $OutOfDate - -{defrules} diff --git a/camlp4/ocpp/ocpp.ml b/camlp4/ocpp/ocpp.ml deleted file mode 100644 index afe517c0e5..0000000000 --- a/camlp4/ocpp/ocpp.ml +++ /dev/null @@ -1,140 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -value buff = ref (String.create 80); -value store len x = - do { - if len >= String.length buff.val then - buff.val := buff.val ^ String.create (String.length buff.val) - else (); - buff.val.[len] := x; - succ len - } -; -value get_buff len = String.sub buff.val 0 len; - -value rec copy_strip_locate cs = - match cs with parser - [ [: `'$' :] -> maybe_locate cs - | [: `c :] -> do { print_char c; copy_strip_locate cs } - | [: :] -> () ] -and maybe_locate cs = - match cs with parser - [ [: `'1'..'9' :] -> locate cs - | [: :] -> do { print_char '$'; copy_strip_locate cs } ] -and locate cs = - match cs with parser - [ [: `'0'..'9' :] -> locate cs - | [: `':' :] -> inside_locate cs - | [: :] -> raise (Stream.Error "colon char expected") ] -and inside_locate cs = - match cs with parser - [ [: `'$' :] -> copy_strip_locate cs - | [: `'\\'; `c :] -> do { print_char c; inside_locate cs } - | [: `c :] -> do { print_char c; inside_locate cs } - | [: :] -> raise (Stream.Error "end of file in locate directive") ] -; - -value quot name pos str = - let exp = - try - match Quotation.find name with - [ Quotation.ExStr f -> f - | _ -> raise Not_found ] - with - [ Not_found -> - Stdpp.raise_with_loc (pos, pos + String.length str) Not_found ] - in - let new_str = - try exp True str with - [ Stdpp.Exc_located (p1, p2) exc -> - Stdpp.raise_with_loc (pos + p1, pos + p2) exc - | exc -> Stdpp.raise_with_loc (pos, pos + String.length str) exc ] - in - let cs = Stream.of_string new_str in copy_strip_locate cs -; - -value rec ident len = - parser - [ [: `('A'..'Z' | 'a'..'z' | '0'..'9' | '_' | ''' as c); s :] -> - ident (store len c) s - | [: :] -> get_buff len ] -; - -value rec copy cs = - match cs with parser - [ [: `'<' :] -> maybe_quot cs - | [: `'"' :] -> do { print_char '"'; inside_string cs } - | [: `c :] -> do { print_char c; copy cs } - | [: :] -> () ] -and maybe_quot cs = - match cs with parser - [ [: `'<' :] ep -> inside_quot "" ep 0 cs - | [: `':'; i = ident 0; `'<' ? "less char expected" :] ep -> - inside_quot i ep 0 cs - | [: :] -> do { print_char '<'; copy cs } ] -and inside_quot name pos len cs = - match cs with parser - [ [: `'>' :] -> maybe_end_quot name pos len cs - | [: `c :] -> inside_quot name pos (store len c) cs - | [: :] -> raise (Stream.Error "end of file in quotation") ] -and maybe_end_quot name pos len cs = - match cs with parser - [ [: `'>' :] -> do { quot name pos (get_buff len); copy cs } - | [: :] -> inside_quot name pos (store len '>') cs ] -and inside_string cs = - match cs with parser - [ [: `'"' :] -> do { print_char '"'; copy cs } - | [: `c :] -> do { print_char c; inside_string cs } - | [: :] -> raise (Stream.Error "end of file in string") ] -; - -value copy_quot cs = do { copy cs; flush stdout; }; - -value loc_fmt = - match Sys.os_type with - [ "MacOS" -> - format_of_string "File \"%s\"; line %d; characters %d to %d\n### " - | _ -> - format_of_string "File \"%s\", line %d, characters %d-%d:\n" ] -; - -value print_location loc file = - let (fname, line, c1, c2) = Stdpp.line_of_loc file loc in - do { Printf.eprintf loc_fmt file line c1 c2; flush stderr; } -; - -value file = ref ""; -Arg.parse [] (fun x -> file.val := x) "ocpp "; - -value main () = - try - if file.val <> "" then - copy_quot (Stream.of_channel (open_in_bin file.val)) - else () - with exc -> - do { - print_newline (); - flush stdout; - let exc = - match exc with - [ Stdpp.Exc_located loc exc -> do { print_location loc file.val; exc } - | exc -> exc ] - in - raise exc - } -; - -Odyl_main.name.val := "ocpp"; -Odyl_main.go.val := main; diff --git a/camlp4/odyl/.cvsignore b/camlp4/odyl/.cvsignore deleted file mode 100644 index 8ae0ebb068..0000000000 --- a/camlp4/odyl/.cvsignore +++ /dev/null @@ -1,4 +0,0 @@ -*.cm[oia] -odyl -*.lib -odyl_config.ml diff --git a/camlp4/odyl/.depend b/camlp4/odyl/.depend deleted file mode 100644 index b63c10b0b6..0000000000 --- a/camlp4/odyl/.depend +++ /dev/null @@ -1,6 +0,0 @@ -odyl_main.cmo: $(OTOP)/otherlibs/dynlink/dynlink.cmi odyl_config.cmo \ - odyl_main.cmi -odyl_main.cmx: odyl_config.cmx \ - odyl_main.cmi -odyl.cmo: odyl_config.cmo odyl_main.cmi -odyl.cmx: odyl_config.cmx odyl_main.cmx diff --git a/camlp4/odyl/Makefile b/camlp4/odyl/Makefile deleted file mode 100644 index 73dc854e6f..0000000000 --- a/camlp4/odyl/Makefile +++ /dev/null @@ -1,61 +0,0 @@ -# $Id$ - -include ../config/Makefile - -SHELL=/bin/sh - -INCLUDES=-I $(OTOP)/otherlibs/dynlink -OCAMLCFLAGS=-warn-error A $(INCLUDES) -LINKFLAGS=$(INCLUDES) - -OBJS=odyl_config.cmo odyl_main.cmo - -all: odyl$(EXE) - -opt: odyl.cmxa odyl.cmx - -odyl$(EXE): odyl.cma odyl.cmo - $(OCAMLC) odyl.cma odyl.cmo -o odyl$(EXE) - -odyl.cma: $(OBJS) - $(OCAMLC) $(LINKFLAGS) dynlink.cma $(OBJS) -a -o odyl.cma - -odyl.cmxa: $(OBJS:.cmo=.cmx) - $(OCAMLOPT) $(LINKFLAGS) $(OBJS:.cmo=.cmx) -a -o odyl.cmxa - -odyl_main.cmx: odyl_main.ml - $(CAMLP4_COMM) -nolib -DOPT -o odyl_main.ppo odyl_main.ml - $(OCAMLOPT) -c -impl odyl_main.ppo - rm -f odyl_main.ppo - -odyl_config.ml: - (echo 'let standard_library ='; \ - echo ' try Sys.getenv "CAMLP4LIB" with Not_found -> '; \ - echo ' try Sys.getenv "OCAMLLIB" ^ "/camlp4" with Not_found -> '; \ - echo ' try Sys.getenv "CAMLLIB" ^ "/camlp4" with Not_found -> '; \ - echo ' "$(LIBDIR)/camlp4"') \ - | sed -e 's|\\|/|g' > odyl_config.ml - -clean:: - rm -f *.cm* *.pp[io] *.$(O) *.bak .*.bak *.out *.opt *.$(A) - rm -f odyl_config.ml odyl$(EXE) - -depend: - cp .depend .depend.bak - > .depend - @for i in *.mli *.ml; do \ - ../tools/apply.sh pr_depend.cmo -- $(INCLUDES) $$i | \ - sed -e 's| $(OTOP)/otherlibs/dynlink/dynlink.cmx||' | \ - sed -e 's| \.\./\.\.| $$(OTOP)|g' >> .depend; \ - done - -promote: - -compare: - -install: - -$(MKDIR) "$(LIBDIR)/camlp4" "$(BINDIR)" - cp odyl.cmo odyl.cma odyl_main.cmi $(LIBDIR)/camlp4/. - if test -f odyl.cmxa; then cp odyl.cmxa odyl.$(A) $(LIBDIR)/camlp4/.; fi - -include .depend diff --git a/camlp4/odyl/Makefile.Mac b/camlp4/odyl/Makefile.Mac deleted file mode 100644 index 9814cec67e..0000000000 --- a/camlp4/odyl/Makefile.Mac +++ /dev/null @@ -1,49 +0,0 @@ -####################################################################### -# # -# Camlp4 # -# # -# Damien Doligez, projet Para, INRIA Rocquencourt # -# # -# Copyright 1999 Institut National de Recherche en Informatique et # -# en Automatique. Distributed only by permission. # -# # -####################################################################### - -# $Id$ - -INCLUDES = -I "{OTOP}otherlibs:dynlink:" -OCAMLCFLAGS = {INCLUDES} -LINKFLAGS = {INCLUDES} - -OBJS = odyl_config.cmo odyl_main.cmo - -all Ä odyl - -odyl Ä odyl.cma odyl.cmo - {OCAMLC} odyl.cma odyl.cmo -o odyl - -odyl.cma Ä {OBJS} - {OCAMLC} {LINKFLAGS} dynlink.cma {OBJS} -a -o odyl.cma - -odyl_config.cmo Ä - echo 'let standard_library =' > odyl_config.ml - echo ' try Sys.getenv "CAMLP4LIB" with' >> odyl_config.ml - echo ' Not_found -> "'{P4LIBDIR}'"' >> odyl_config.ml - {OCAMLC} {OCAMLCFLAGS} -c odyl_config.ml - -clean ÄÄ - delete -i odyl_config.ml odyl - -{dependrule} - -promote Ä $OutOfDate - -compare Ä $OutOfDate - -install Ä - (newfolder "{P4LIBDIR}" || set status 0) ³ dev:null - (newfolder "{BINDIR}" || set status 0) ³ dev:null - duplicate -y odyl.cmo odyl.cma "{P4LIBDIR}" - duplicate -y odyl "{BINDIR}" - -{defrules} diff --git a/camlp4/odyl/Makefile.Mac.depend b/camlp4/odyl/Makefile.Mac.depend deleted file mode 100644 index adaff27755..0000000000 --- a/camlp4/odyl/Makefile.Mac.depend +++ /dev/null @@ -1,4 +0,0 @@ -odyl_main.cmoÄ odyl_config.cmo odyl_main.cmi -odyl_main.cmxÄ odyl_config.cmx odyl_main.cmi -odyl.cmoÄ odyl_config.cmo odyl_main.cmi -odyl.cmxÄ odyl_config.cmx odyl_main.cmx diff --git a/camlp4/odyl/odyl.ml b/camlp4/odyl/odyl.ml deleted file mode 100644 index 0bd4b17473..0000000000 --- a/camlp4/odyl/odyl.ml +++ /dev/null @@ -1,51 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2001 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -value apply_load () = - let i = ref 1 in - let stop = ref False in - while not stop.val && i.val < Array.length Sys.argv do { - let s = Sys.argv.(i.val) in - if s = "-I" && i.val + 1 < Array.length Sys.argv then do { - Odyl_main.directory Sys.argv.(i.val + 1); - i.val := i.val + 2 - } - else if s = "-nolib" then do { Odyl_main.nolib.val := True; incr i } - else if s = "-where" then do { - print_string Odyl_config.standard_library; - print_newline (); - flush stdout; - exit 0 - } - else if s = "--" then do { incr i; stop.val := True; () } - else if String.length s > 0 && s.[0] == '-' then stop.val := True - else if Filename.check_suffix s ".cmo" || Filename.check_suffix s ".cma" - then do { Odyl_main.loadfile s; incr i } - else stop.val := True - } -; - -value main () = - try do { apply_load () ; Odyl_main.go.val () } with - [ Odyl_main.Error fname str -> - do { - flush stdout; - Printf.eprintf "Error while loading \"%s\": " fname; - Printf.eprintf "%s.\n" str; - flush stderr; - exit 2 - } ] -; - -Printexc.catch main (); diff --git a/camlp4/odyl/odyl_main.ml b/camlp4/odyl/odyl_main.ml deleted file mode 100644 index c0996568d0..0000000000 --- a/camlp4/odyl/odyl_main.ml +++ /dev/null @@ -1,82 +0,0 @@ -(* camlp4r pa_macro.cmo *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2001 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -value go = ref (fun () -> ()); -value name = ref "odyl"; - -value first_arg_no_load () = - loop 1 where rec loop i = - if i < Array.length Sys.argv then - match Sys.argv.(i) with - [ "-I" -> loop (i + 2) - | "-nolib" -> loop (i + 1) - | "-where" -> loop (i + 1) - | "--" -> i + 1 - | s -> - if Filename.check_suffix s ".cmo" - || Filename.check_suffix s ".cma" then loop (i + 1) - else i ] - else i -; - -Arg.current.val := first_arg_no_load () - 1; - -(* Load files in core *) - -value find_in_path path name = - if not (Filename.is_implicit name) then - if Sys.file_exists name then name else raise Not_found - else - let rec try_dir = - fun - [ [] -> raise Not_found - | [dir :: rem] -> - let fullname = Filename.concat dir name in - if Sys.file_exists fullname then fullname else try_dir rem ] - in - try_dir path -; - -exception Error of string and string; - -value nolib = ref False; -value initialized = ref False; -value path = ref ([] : list string); - -value loadfile file = - IFDEF OPT THEN - raise (Error file "native-code program cannot do a dynamic load") - ELSE do { - if not initialized.val then do { - IFDEF OPT THEN () - ELSE do { Dynlink.init (); Dynlink.allow_unsafe_modules True } - END; - initialized.val := True - } - else (); - let path = - if nolib.val then path.val - else [Odyl_config.standard_library :: path.val] - in - let fname = - try find_in_path (List.rev 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)) ] - } - END -; - -value directory d = path.val := [d :: path.val]; diff --git a/camlp4/odyl/odyl_main.mli b/camlp4/odyl/odyl_main.mli deleted file mode 100644 index db47805370..0000000000 --- a/camlp4/odyl/odyl_main.mli +++ /dev/null @@ -1,13 +0,0 @@ -(* camlp4r *) -(* $Id$ *) - -exception Error of string and string; - -value nolib : ref bool; -value initialized : ref bool; -value path : ref (list string); -value loadfile : string -> unit; -value directory : string -> unit; - -value go : ref (unit -> unit); -value name : ref string; diff --git a/camlp4/tools/apply.sh b/camlp4/tools/apply.sh deleted file mode 100755 index 078b1d501e..0000000000 --- a/camlp4/tools/apply.sh +++ /dev/null @@ -1,31 +0,0 @@ -#!/bin/sh -# $Id$ - -ARGS1= -FILE= -while test "" != "$1"; do - case $1 in - *.ml*) FILE=$1;; - *) ARGS1="$ARGS1 $1";; - esac - shift -done - -# FILE must exist and be non empty (at least one line) -test -s "$FILE" || exit 1 - - - -set - `awk 'NR == 1' "$FILE"` -if test "$2" = "camlp4r" -o "$2" = "camlp4"; then - COMM="../boot/$2 -nolib -I ../boot -I ../etc" - shift; shift - ARGS2=`echo $* | sed -e "s/[()*]//g"` -else - COMM="../boot/camlp4 -nolib -I ../boot -I ../etc pa_o.cmo" - ARGS2= -fi - -OTOP=../.. -echo $OTOP/boot/ocamlrun $COMM $ARGS2 $ARGS1 $FILE 1>&2 -$OTOP/boot/ocamlrun $COMM $ARGS2 $ARGS1 $FILE diff --git a/camlp4/tools/camlp4_comm.mpw b/camlp4/tools/camlp4_comm.mpw deleted file mode 100644 index 274bead93d..0000000000 --- a/camlp4/tools/camlp4_comm.mpw +++ /dev/null @@ -1,53 +0,0 @@ -####################################################################### -# # -# Camlp4 # -# # -# Damien Doligez, projet Para, INRIA Rocquencourt # -# # -# Copyright 1999 Institut National de Recherche en Informatique et # -# en Automatique. Distributed only by permission. # -# # -####################################################################### - -# $Id$ - -set echo 0 - -exit if {#} < 1 - -set args1 "" -set file "" -loop - break if {#} == 0 - if "{1}" =~ /Å.mlÅ/ - set file "{1}" - else - set args1 "{args1} `quote "{1}"`" - end - shift -end - -set firstline "`streamedit -e '1 exit' "{file}"`" ³ dev:null || set status 0 - -if "{firstline}" =~ /[Â ]+ camlp4r (Å)¨0/ - set args0 "`echo "{¨0}" | streamedit -e '1,$ replace -c ° /[()*]/ ""' ¶ - -e '1,$ replace -c ° /.¶// ":"'`" - set comm "{OTOP}boot:ocamlrun ::boot:camlp4r -nolib -I ::boot:" - echo "{comm} {args0} {args1} {file}" - {comm} {args0} {args1} "{file}" -else if "{firstline}" =~ /[Â ]+ camlp4 (Å)¨0/ - set args0 "`echo "{¨0}" | streamedit -e '1,$ replace -c ° /[()*]/ ""' ¶ - -e '1,$ replace -c ° /.¶// ":"'`" - set comm "{OTOP}boot:ocamlrun ::boot:camlp4 -nolib -I ::boot:" - echo "{comm} {args0} {args1} {file}" - {comm} {args0} {args1} "{file}" -else if "{file}" =~ /(Å)¨0.mli/ - echo duplicate -y {file} {¨0}.ppi - duplicate -y "{file}" "{¨0}.ppi" -else if "{file}" =~ /(Å)¨0.ml/ - echo duplicate -y {file} {¨0}.ppo - duplicate -y "{file}" "{¨0}.ppo" -else - echo duplicate -y {file} {file}.ppo - duplicate -y "{file}" "{file}.ppo" -end diff --git a/camlp4/tools/camlp4_comm.sh b/camlp4/tools/camlp4_comm.sh deleted file mode 100755 index b6bb8f87ed..0000000000 --- a/camlp4/tools/camlp4_comm.sh +++ /dev/null @@ -1,38 +0,0 @@ -#!/bin/sh -# $Id$ - -ARGS1= -FILE= -QUIET=no -while test "" != "$1"; do - case $1 in - -q) QUIET=yes;; - *.ml*) FILE=$1;; - *) ARGS1="$ARGS1 $1";; - esac - shift -done - -# FILE must exist and be non empty (at least one line) -test -s "$FILE" || exit 1 - -set - `awk 'NR == 1' "$FILE"` -if test "$2" = "camlp4r" -o "$2" = "camlp4"; then - COMM="ocamlrun$EXE ../boot/$2$EXE -nolib -I ../boot" - if test "`basename $OTOP`" != "ocaml_stuff"; then - COMM="$OTOP/boot/$COMM" - fi - shift; shift - ARGS2=`echo $* | sed -e "s/[()*]//g"` -# ARGS1="$ARGS1 -verbose" - if test "$QUIET" = "no"; then echo $COMM $ARGS2 $ARGS1 $FILE; fi - $COMM $ARGS2 $ARGS1 $FILE -else - if test "`basename $FILE .mli`.mli" = "$FILE"; then - OFILE=`basename $FILE .mli`.ppi - else - OFILE=`basename $FILE .ml`.ppo - fi - if test "$QUIET" = "no"; then echo cp $FILE $OFILE; fi - cp $FILE $OFILE -fi diff --git a/camlp4/tools/conv.sh b/camlp4/tools/conv.sh deleted file mode 100755 index 64a4e2b1d3..0000000000 --- a/camlp4/tools/conv.sh +++ /dev/null @@ -1,22 +0,0 @@ -#!/bin/sh -DIR=`expr "$0" : "\(.*\)/.*" "|" "."` - -INCL= -FILE= -while test "" != "$1"; do - case $1 in - -I) INCL="$INCL -I $2"; shift;; - *) FILE=$1;; - esac - shift -done - -set - `awk 'NR == 1' "$FILE"` -if test "$2" = "camlp4r" -o "$2" = "camlp4"; then - COMM="$OTOP/boot/ocamlrun $DIR/../boot/$2 -nolib -I $DIR/../boot $INCL $DIR/../etc/pr_o.cmo" - shift; shift - ARGS=`echo $* | sed -e "s/[()*]//g"` - $COMM $ARGS -ss $FILE -else - cat $FILE -fi diff --git a/camlp4/tools/extract_crc.mpw b/camlp4/tools/extract_crc.mpw deleted file mode 100644 index 91dc4ddf9a..0000000000 --- a/camlp4/tools/extract_crc.mpw +++ /dev/null @@ -1,3 +0,0 @@ -# $Id$ - -"{OTOP}boot:ocamlrun" "{OTOP}otherlibs:dynlink:extract_crc" {"parameters"} diff --git a/camlp4/tools/extract_crc.sh b/camlp4/tools/extract_crc.sh deleted file mode 100755 index e69de29bb2..0000000000 diff --git a/camlp4/tools/ocamlc.mpw b/camlp4/tools/ocamlc.mpw deleted file mode 100644 index 6e21e9bf19..0000000000 --- a/camlp4/tools/ocamlc.mpw +++ /dev/null @@ -1,3 +0,0 @@ -# $Id$ - -"{OTOP}boot:ocamlrun" "{OTOP}ocamlc" -I "{OTOP}stdlib:" {"parameters"} diff --git a/camlp4/tools/ocamlc.sh b/camlp4/tools/ocamlc.sh deleted file mode 100755 index ee654c2c6f..0000000000 --- a/camlp4/tools/ocamlc.sh +++ /dev/null @@ -1,8 +0,0 @@ -#!/bin/sh -e -if test "`basename $OTOP`" != "ocaml_stuff"; then - COMM=$OTOP/ocamlcomp.sh -else - COMM=ocamlc$OPT -fi -echo $COMM $* -$COMM $* diff --git a/camlp4/tools/ocamlopt.sh b/camlp4/tools/ocamlopt.sh deleted file mode 100755 index 1fb669d670..0000000000 --- a/camlp4/tools/ocamlopt.sh +++ /dev/null @@ -1,8 +0,0 @@ -#!/bin/sh -e -if test "`basename $OTOP`" != "ocaml_stuff"; then - COMM=$OTOP/ocamlcompopt.sh -else - COMM=ocamlopt$OPT -fi -echo $COMM $* -$COMM $* diff --git a/camlp4/top/.cvsignore b/camlp4/top/.cvsignore deleted file mode 100644 index df1824f495..0000000000 --- a/camlp4/top/.cvsignore +++ /dev/null @@ -1 +0,0 @@ -*.cm[oia] diff --git a/camlp4/top/.depend b/camlp4/top/.depend deleted file mode 100644 index d7aebc7bc5..0000000000 --- a/camlp4/top/.depend +++ /dev/null @@ -1,14 +0,0 @@ -camlp4_top.cmo: ../camlp4/ast2pt.cmi ../camlp4/mLast.cmi \ - $(OTOP)/parsing/parsetree.cmi ../camlp4/pcaml.cmi \ - $(OTOP)/toplevel/topdirs.cmi $(OTOP)/toplevel/toploop.cmi \ - $(OTOP)/utils/warnings.cmi -camlp4_top.cmx: ../camlp4/ast2pt.cmx ../camlp4/mLast.cmi \ - $(OTOP)/parsing/parsetree.cmi ../camlp4/pcaml.cmx \ - $(OTOP)/toplevel/topdirs.cmx $(OTOP)/toplevel/toploop.cmx \ - $(OTOP)/utils/warnings.cmx -oprint.cmo: $(OTOP)/typing/outcometree.cmi $(OTOP)/toplevel/toploop.cmi -oprint.cmx: $(OTOP)/typing/outcometree.cmi $(OTOP)/toplevel/toploop.cmx -rprint.cmo: $(OTOP)/parsing/asttypes.cmi $(OTOP)/typing/outcometree.cmi \ - $(OTOP)/toplevel/toploop.cmi -rprint.cmx: $(OTOP)/parsing/asttypes.cmi $(OTOP)/typing/outcometree.cmi \ - $(OTOP)/toplevel/toploop.cmx diff --git a/camlp4/top/Makefile b/camlp4/top/Makefile deleted file mode 100644 index 4ea4e46bc2..0000000000 --- a/camlp4/top/Makefile +++ /dev/null @@ -1,52 +0,0 @@ -# $Id$ - -include ../config/Makefile - -INCLUDES=-I ../camlp4 -I ../boot -I $(OTOP)/utils -I $(OTOP)/parsing -I $(OTOP)/typing -I $(OTOP)/toplevel -OCAMLCFLAGS=-warn-error A $(INCLUDES) - -CAMLP4_OBJS=$(OTOP)/utils/config.cmo ../boot/stdpp.cmo ../boot/token.cmo ../boot/plexer.cmo ../boot/gramext.cmo ../boot/grammar.cmo ../boot/extfold.cmo ../boot/extfun.cmo ../boot/fstream.cmo ../camlp4/quotation.cmo ../camlp4/ast2pt.cmo ../camlp4/reloc.cmo ../camlp4/spretty.cmo ../camlp4/pcaml.cmo -TOP=camlp4_top.cmo -ROBJS=$(CAMLP4_OBJS) ../meta/pa_r.cmo ../meta/pa_rp.cmo rprint.cmo $(TOP) -SOBJS=$(CAMLP4_OBJS) ../etc/pa_scheme.cmo $(TOP) -OOBJS=$(CAMLP4_OBJS) ../etc/pa_o.cmo ../etc/pa_op.cmo $(TOP) -OOOBJS=$(CAMLP4_OBJS) ../etc/pa_o.cmo ../etc/pa_oop.cmo $(TOP) -OBJS=$(OTOP)/utils/config.cmo ../camlp4/quotation.cmo ../camlp4/reloc.cmo ../camlp4/ast2pt.cmo ../camlp4/spretty.cmo ../camlp4/pcaml.cmo camlp4_top.cmo - -TARGET=camlp4o.cma camlp4r.cma camlp4sch.cma camlp4_top.cma - -all: $(TARGET) - -camlp4oo.cma: $(OOOBJS) - $(OCAMLC) $(OOOBJS) -linkall -a -o camlp4oo.cma - -camlp4o.cma: $(OOBJS) - $(OCAMLC) $(OOBJS) -linkall -a -o camlp4o.cma - -camlp4r.cma: $(ROBJS) - $(OCAMLC) $(ROBJS) -linkall -a -o camlp4r.cma - -camlp4sch.cma: $(SOBJS) - $(OCAMLC) $(SOBJS) -linkall -a -o camlp4sch.cma - -camlp4_top.cma: $(OBJS) - $(OCAMLC) $(OBJS) -a -o camlp4_top.cma - -clean:: - rm -f *.cm[ioa] *.pp[io] *.o *.bak .*.bak $(TARGET) - -depend: - cp .depend .depend.bak - > .depend - @for i in *.mli *.ml; do \ - ../tools/apply.sh pr_depend.cmo -- $(INCLUDES) $$i | \ - sed -e 's| \.\./\.\.| $$(OTOP)|g' >> .depend; \ - done - -get_promote: - -install: - -$(MKDIR) "$(LIBDIR)/camlp4" - cp $(TARGET) "$(LIBDIR)/camlp4/." - -include .depend diff --git a/camlp4/top/Makefile.Mac b/camlp4/top/Makefile.Mac deleted file mode 100644 index bb2aa44506..0000000000 --- a/camlp4/top/Makefile.Mac +++ /dev/null @@ -1,60 +0,0 @@ -####################################################################### -# # -# Camlp4 # -# # -# Damien Doligez, projet Para, INRIA Rocquencourt # -# # -# Copyright 1999 Institut National de Recherche en Informatique et # -# en Automatique. Distributed only by permission. # -# # -####################################################################### - -# $Id$ - -INCLUDES = -I ::camlp4: -I ::boot: -I "{OTOP}utils:" -I "{OTOP}parsing:" ¶ - -I "{OTOP}typing:" -I "{OTOP}toplevel:" -OCAMLCFLAGS = {INCLUDES} - -CAMLP4_OBJS = "{OTOP}utils:config.cmo" ::boot:stdpp.cmo ::boot:token.cmo ¶ - ::boot:plexer.cmo ¶ - ::boot:gramext.cmo ::boot:grammar.cmo ::boot:extfold.cmo ::boot:extfun.cmo ¶ - ::boot:fstream.cmo ¶ - ::camlp4:quotation.cmo ¶ - ::camlp4:ast2pt.cmo ::camlp4:reloc.cmo ::camlp4:spretty.cmo ¶ - ::camlp4:pcaml.cmo -TOP = camlp4_top.cmo -ROBJS = {CAMLP4_OBJS} ::meta:pa_r.cmo ::meta:pa_rp.cmo rprint.cmo {TOP} -OOBJS = {CAMLP4_OBJS} ::etc:pa_o.cmo ::etc:pa_op.cmo {TOP} -OOOBJS = {CAMLP4_OBJS} ::etc:pa_o.cmo ::etc:pa_oop.cmo {TOP} -OBJS = "{OTOP}utils:config.cmo" ::camlp4:quotation.cmo ::camlp4:reloc.cmo ¶ - ::camlp4:ast2pt.cmo ::camlp4:spretty.cmo ¶ - ::camlp4:pcaml.cmo camlp4_top.cmo - -TARGETS = camlp4o.cma camlp4r.cma camlp4_top.cma - -all Ä {TARGETS} - -camlp4oo.cma Ä {OOOBJS} - {OCAMLC} {OOOBJS} -linkall -a -o camlp4oo.cma - -camlp4o.cma Ä {OOBJS} - {OCAMLC} {OOBJS} -linkall -a -o camlp4o.cma - -camlp4r.cma Ä {ROBJS} - {OCAMLC} {ROBJS} -linkall -a -o camlp4r.cma - -camlp4_top.cma Ä {OBJS} - {OCAMLC} {OBJS} -a -o camlp4_top.cma - -clean ÄÄ - delete -i {TARGETS} - -{dependrule} - -get_promote Ä $OutOfDate - -install Ä - (newfolder "{P4LIBDIR}" || set status 0) ³ dev:null - duplicate -y {TARGETS} "{P4LIBDIR}" - -{defrules} diff --git a/camlp4/top/Makefile.Mac.depend b/camlp4/top/Makefile.Mac.depend deleted file mode 100644 index 6b7096dadb..0000000000 --- a/camlp4/top/Makefile.Mac.depend +++ /dev/null @@ -1,2 +0,0 @@ -camlp4_top.cmoÄ ::camlp4:ast2pt.cmo ::camlp4:mLast.cmi ::camlp4:pcaml.cmi -camlp4_top.cmxÄ ::camlp4:ast2pt.cmx ::camlp4:mLast.cmi ::camlp4:pcaml.cmx diff --git a/camlp4/top/camlp4_top.ml b/camlp4/top/camlp4_top.ml deleted file mode 100644 index 4d0d12f785..0000000000 --- a/camlp4/top/camlp4_top.ml +++ /dev/null @@ -1,172 +0,0 @@ -(* camlp4r q_MLast.cmo *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -open Parsetree; -open Lexing; -open Stdpp; - -value highlight_locations lb loc1 loc2 = - try - let pos0 = - lb.lex_abs_pos in - do { - if pos0 < 0 then raise Exit else (); - let pos_at_bol = ref 0 in - print_string "Toplevel input:\n# "; - for pos = 0 to lb.lex_buffer_len - pos0 - 1 do { - let c = lb.lex_buffer.[pos + pos0] in - if c = '\n' then do { - if pos_at_bol.val <= fst loc1 && snd loc1 <= pos then do { - print_string "\n "; - for i = pos_at_bol.val to fst loc1 - 1 do { print_char ' ' }; - for i = fst loc1 to snd loc1 - 1 do { print_char '^' }; - print_char '\n' - } - else if pos_at_bol.val <= fst loc1 && fst loc1 < pos then do { - print_char '\r'; - print_char (if pos_at_bol.val = 0 then '#' else ' '); - print_char ' '; - for i = pos_at_bol.val to fst loc1 - 1 do { print_char '.' }; - print_char '\n' - } - else if pos_at_bol.val <= snd loc1 && snd loc1 < pos then do { - for i = pos - 1 downto snd loc1 do { print_string "\008.\008" }; - print_char '\n' - } - else print_char '\n'; - pos_at_bol.val := pos + 1; - if pos < lb.lex_buffer_len - pos0 - 1 then - print_string " " - else () - } - else print_char c - }; - flush stdout - } - with - [ Exit -> () ] -; - -value print_location lb loc = - if String.length Toploop.input_name.val = 0 then - highlight_locations lb loc (-1, -1) - else Toploop.print_location Format.err_formatter (Ast2pt.mkloc loc) -; - -value wrap f shfn lb = - let cs = - let shift = shfn lb in - Stream.from - (fun i -> - if i < shift then Some ' ' - else do { - while - lb.lex_curr_pos >= lb.lex_buffer_len && - not lb.lex_eof_reached - do { - lb.refill_buff lb - }; - if lb.lex_curr_pos >= lb.lex_buffer_len then None - else do { - let c = lb.lex_buffer.[lb.lex_curr_pos] in - lb.lex_curr_pos := lb.lex_curr_pos + 1; - Some c - } - }) - in - try f cs with - [ Exc_located _ (Sys.Break as x) -> raise x - | End_of_file as x -> raise x - | x -> - let x = - match x with - [ Exc_located loc x -> do { print_location lb loc; x } - | x -> x ] - in - do { - match x with - [ Stream.Failure | Stream.Error _ -> Pcaml.sync.val cs - | _ -> () ]; - Format.open_hovbox 0; - Pcaml.report_error x; - Format.close_box (); - Format.print_newline (); - raise Exit - } ] -; - -value first_phrase = ref True; - -value toplevel_phrase cs = - do { - if Sys.interactive.val && first_phrase.val then do { - first_phrase.val := False; - Printf.eprintf "\tCamlp4 Parsing version %s\n\n" Pcaml.version; - flush stderr; - } - else (); - match Grammar.Entry.parse Pcaml.top_phrase cs with - [ Some phr -> Ast2pt.phrase phr - | None -> raise End_of_file ]; - } -; - -value use_file cs = - let v = Pcaml.input_file.val in - do { - Pcaml.input_file.val := Toploop.input_name.val; - let restore () = Pcaml.input_file.val := v in - try - let (pl0, eoi) = - loop () where rec loop () = - let (pl, stopped_at_directive) = - Grammar.Entry.parse Pcaml.use_file cs - in - if stopped_at_directive then - match pl with - [ [MLast.StDir _ "load" (Some <:expr< $str:s$ >>)] -> - do { Topdirs.dir_load Format.std_formatter s; loop () } - | [MLast.StDir _ "directory" (Some <:expr< $str:s$ >>)] -> - do { Topdirs.dir_directory s; loop () } - | _ -> (pl, False) ] - else (pl, True) - in - let pl = - if eoi then [] - else - loop () where rec loop () = - let (pl, stopped_at_directive) = - Grammar.Entry.parse Pcaml.use_file cs - in - if stopped_at_directive then pl @ loop () else pl - in - let r = pl0 @ pl in - let r = List.map Ast2pt.phrase r in - do { restore (); r } - with e -> - do { restore (); raise e } - } -; - -Toploop.parse_toplevel_phrase.val := - wrap toplevel_phrase (fun _ -> 0) -; - -Toploop.parse_use_file.val := - wrap use_file (fun lb -> lb.lex_curr_pos - lb.lex_start_pos) -; - -Pcaml.warning.val := - fun loc txt -> - Toploop.print_warning (Ast2pt.mkloc loc) Format.err_formatter - (Warnings.Other txt); diff --git a/camlp4/top/oprint.ml b/camlp4/top/oprint.ml deleted file mode 100644 index 15600c2411..0000000000 --- a/camlp4/top/oprint.ml +++ /dev/null @@ -1,597 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -open Format; -open Outcometree; - -exception Ellipsis; -value cautious f ppf arg = - try f ppf arg with [ Ellipsis -> fprintf ppf "..." ] -; - -value rec print_ident ppf = - fun - [ Oide_ident s -> fprintf ppf "%s" s - | Oide_dot id s -> fprintf ppf "%a.%s" print_ident id s - | Oide_apply id1 id2 -> - fprintf ppf "%a(%a)" print_ident id1 print_ident id2 ] -; - -value value_ident ppf name = - if List.mem name ["or"; "mod"; "land"; "lor"; "lxor"; "lsl"; "lsr"; "asr"] - then - fprintf ppf "( %s )" name - else - match name.[0] with - [ 'a'..'z' | '\223'..'\246' | '\248'..'\255' | '_' -> - fprintf ppf "%s" name - | _ -> fprintf ppf "( %s )" name ] -; - -(* Values *) - -value print_out_value ppf tree = - let rec print_tree ppf = - fun - [ Oval_tuple tree_list -> - fprintf ppf "@[%a@]" (print_tree_list print_tree_1 ",") tree_list - | tree -> print_tree_1 ppf tree ] - and print_tree_1 ppf = - fun - [ Oval_constr name [param] -> - fprintf ppf "@[<1>%a@ %a@]" print_ident name print_simple_tree param - | Oval_constr name ([_ :: _] as params) -> - fprintf ppf "@[<1>%a@ (%a)@]" print_ident name - (print_tree_list print_tree_1 ",") params - | Oval_variant name (Some param) -> - fprintf ppf "@[<2>`%s@ %a@]" name print_simple_tree param - | tree -> print_simple_tree ppf tree ] - and print_simple_tree ppf = - fun - [ Oval_int i -> fprintf ppf "%i" i - | Oval_int32 i -> fprintf ppf "%ldl" i - | Oval_int64 i -> fprintf ppf "%LdL" i - | Oval_nativeint i -> fprintf ppf "%ndn" i - | Oval_float f -> fprintf ppf "%F" f - | Oval_char c -> fprintf ppf "%C" c - | Oval_string s -> - try fprintf ppf "%S" s with - [ Invalid_argument "String.create" -> fprintf ppf "" ] - | Oval_list tl -> - fprintf ppf "@[<1>[%a]@]" (print_tree_list print_tree_1 ";") tl - | Oval_array tl -> - fprintf ppf "@[<2>[|%a|]@]" (print_tree_list print_tree_1 ";") tl - | Oval_constr name [] -> print_ident ppf name - | Oval_variant name None -> fprintf ppf "`%s" name - | Oval_stuff s -> fprintf ppf "%s" s - | Oval_record fel -> - fprintf ppf "@[<1>{%a}@]" (cautious (print_fields True)) fel - | Oval_ellipsis -> raise Ellipsis - | Oval_printer f -> f ppf - | tree -> fprintf ppf "@[<1>(%a)@]" (cautious print_tree) tree ] - and print_fields first ppf = - fun - [ [] -> () - | [(name, tree) :: fields] -> - do { - if not first then fprintf ppf ";@ " else (); - fprintf ppf "@[<1>%a@ =@ %a@]" print_ident name - (cautious print_tree) tree; - print_fields False ppf fields - } ] - and print_tree_list print_item sep ppf tree_list = - let rec print_list first ppf = - fun - [ [] -> () - | [tree :: tree_list] -> - do { - if not first then fprintf ppf "%s@ " sep else (); - print_item ppf tree; - print_list False ppf tree_list - } ] - in - cautious (print_list True) ppf tree_list - in - cautious print_tree ppf tree -; - -(* Types *) - -value rec print_list_init pr sep ppf = - fun - [ [] -> () - | [a :: l] -> do { sep ppf; pr ppf a; print_list_init pr sep ppf l } ] -; - -value pr_vars = - print_list (fun ppf s -> fprintf ppf "'%s" s) (fun ppf -> fprintf ppf "@ ") -; - -value rec print_list pr sep ppf = - fun - [ [] -> () - | [a] -> pr ppf a - | [a :: l] -> do { pr ppf a; sep ppf; print_list pr sep ppf l } ] -; - -value pr_present = - print_list (fun ppf s -> fprintf ppf "`%s" s) (fun ppf -> fprintf ppf "@ ") -; - -value rec print_out_type ppf = - fun - [ Otyp_alias ty s -> fprintf ppf "@[%a as '%s@]" print_out_type ty s - | Otyp_poly sl ty -> - fprintf ppf "@[%a.@ %a@]" - pr_vars sl - print_out_type ty - | ty -> print_out_type_1 ppf ty ] -and print_out_type_1 ppf = - fun - [ Otyp_arrow lab ty1 ty2 -> - fprintf ppf "@[%s%a ->@ %a@]" (if lab <> "" then lab ^ ":" else "") - print_out_type_2 ty1 print_out_type_1 ty2 - | ty -> print_out_type_2 ppf ty ] -and print_out_type_2 ppf = - fun - [ Otyp_tuple tyl -> - fprintf ppf "@[<0>%a@]" (print_typlist print_simple_out_type " *") tyl - | ty -> print_simple_out_type ppf ty ] -and print_simple_out_type ppf = - fun - [ Otyp_class ng id tyl -> - fprintf ppf "@[%a%s#%a@]" print_typargs tyl (if ng then "_" else "") - print_ident id - | Otyp_constr id tyl -> - fprintf ppf "@[%a%a@]" print_typargs tyl print_ident id - | Otyp_object fields rest -> - fprintf ppf "@[<2>< %a >@]" (print_fields rest) fields - | Otyp_stuff s -> fprintf ppf "%s" s - | Otyp_var ng s -> fprintf ppf "'%s%s" (if ng then "_" else "") s - | Otyp_variant non_gen row_fields closed tags -> - let print_present ppf = - fun - [ None | Some [] -> () - | Some l -> fprintf ppf "@;<1 -2>> @[%a@]" pr_present l ] - in - let print_fields ppf = - fun - [ Ovar_fields fields -> - print_list print_row_field (fun ppf -> fprintf ppf "@;<1 -2>| ") - ppf fields - | Ovar_name id tyl -> - fprintf ppf "@[%a%a@]" print_typargs tyl print_ident id ] - in - fprintf ppf "%s[%s@[@[%a@]%a]@]" (if non_gen then "_" else "") - (if closed then if tags = None then " " else "< " - else if tags = None then "> " - else "? ") - print_fields row_fields print_present tags - | Otyp_alias _ _ | Otyp_poly _ | Otyp_arrow _ _ _ | Otyp_tuple _ as ty -> - fprintf ppf "@[<1>(%a)@]" print_out_type ty - | Otyp_abstract | Otyp_sum _ | Otyp_record _ | Otyp_private _ - | Otyp_manifest _ _ -> () ] -and print_fields rest ppf = - fun - [ [] -> - match rest with - [ Some non_gen -> fprintf ppf "%s.." (if non_gen then "_" else "") - | None -> () ] - | [(s, t)] -> - do { - fprintf ppf "%s : %a" s print_out_type t; - match rest with - [ Some _ -> fprintf ppf ";@ " - | None -> () ]; - print_fields rest ppf [] - } - | [(s, t) :: l] -> - fprintf ppf "%s : %a;@ %a" s print_out_type t (print_fields rest) l ] -and print_row_field ppf (l, opt_amp, tyl) = - let pr_of ppf = - if opt_amp then fprintf ppf " of@ &@ " - else if tyl <> [] then fprintf ppf " of@ " - else fprintf ppf "" - in - fprintf ppf "@[`%s%t%a@]" l pr_of (print_typlist print_out_type " &") - tyl -and print_typlist print_elem sep ppf = - fun - [ [] -> () - | [ty] -> print_elem ppf ty - | [ty :: tyl] -> - fprintf ppf "%a%s@ %a" print_elem ty sep (print_typlist print_elem sep) - tyl ] -and print_typargs ppf = - fun - [ [] -> () - | [ty1] -> fprintf ppf "%a@ " print_simple_out_type ty1 - | tyl -> - fprintf ppf "@[<1>(%a)@]@ " (print_typlist print_out_type ",") tyl ] -; - -(* Signature items *) - -value print_out_class_params ppf = - fun - [ [] -> () - | tyl -> - fprintf ppf "@[<1>[%a]@]@ " - (print_list (fun ppf x -> fprintf ppf "'%s" x) - (fun ppf -> fprintf ppf ", ")) - tyl ] -; - -value rec print_out_class_type ppf = - fun - [ Octy_constr id tyl -> - let pr_tyl ppf = - fun - [ [] -> () - | tyl -> - fprintf ppf "@[<1>[%a]@]@ " (print_typlist print_out_type ",") - tyl ] - in - fprintf ppf "@[%a%a@]" pr_tyl tyl print_ident id - | Octy_fun lab ty cty -> - fprintf ppf "@[%s%a ->@ %a@]" (if lab <> "" then lab ^ ":" else "") - print_out_type_2 ty print_out_class_type cty - | Octy_signature self_ty csil -> - let pr_param ppf = - fun - [ Some ty -> fprintf ppf "@ @[(%a)@]" print_out_type ty - | None -> () ] - in - fprintf ppf "@[@[<2>object%a@]@ %a@;<1 -2>end@]" pr_param self_ty - (print_list print_out_class_sig_item (fun ppf -> fprintf ppf "@ ")) - csil ] -and print_out_class_sig_item ppf = - fun - [ Ocsg_constraint ty1 ty2 -> - fprintf ppf "@[<2>constraint %a =@ %a@]" print_out_type ty1 - print_out_type ty2 - | Ocsg_method name priv virt ty -> - fprintf ppf "@[<2>method %s%s%s :@ %a@]" - (if priv then "private " else "") (if virt then "virtual " else "") - name print_out_type ty - | Ocsg_value name mut ty -> - fprintf ppf "@[<2>val %s%s :@ %a@]" (if mut then "mutable " else "") - name print_out_type ty ] -; - -value rec print_out_module_type ppf = - fun - [ Omty_abstract -> () - | Omty_functor name mty_arg mty_res -> - fprintf ppf "@[<2>functor@ (%s : %a) ->@ %a@]" name - print_out_module_type mty_arg print_out_module_type mty_res - | Omty_ident id -> fprintf ppf "%a" print_ident id - | Omty_signature sg -> - fprintf ppf "@[sig@ %a@;<1 -2>end@]" print_signature_body sg ] -and print_signature_body ppf = - fun - [ [] -> () - | [item] -> print_out_sig_item ppf item - | [item :: items] -> - fprintf ppf "%a@ %a" print_out_sig_item item - print_signature_body items ] -and print_out_sig_item ppf = - fun - [ Osig_class vir_flag name params clt -> - fprintf ppf "@[<2>class%s@ %a%s@ :@ %a@]" - (if vir_flag then " virtual" else "") print_out_class_params params - name print_out_class_type clt - | Osig_class_type vir_flag name params clt -> - fprintf ppf "@[<2>class type%s@ %a%s@ =@ %a@]" - (if vir_flag then " virtual" else "") print_out_class_params params - name print_out_class_type clt - | Osig_exception id tyl -> - fprintf ppf "@[<2>exception %a@]" print_out_constr (id, tyl) - | Osig_modtype name Omty_abstract -> - fprintf ppf "@[<2>module type %s@]" name - | Osig_modtype name mty -> - fprintf ppf "@[<2>module type %s =@ %a@]" name print_out_module_type mty - | Osig_module name mty -> - fprintf ppf "@[<2>module %s :@ %a@]" name print_out_module_type mty - | Osig_type tdl -> print_out_type_decl_list ppf tdl - | Osig_value name ty prims -> - let kwd = if prims = [] then "val" else "external" in - let pr_prims ppf = - fun - [ [] -> () - | [s :: sl] -> - do { - fprintf ppf "@ = \"%s\"" s; - List.iter (fun s -> fprintf ppf "@ \"%s\"" s) sl - } ] - in - fprintf ppf "@[<2>%s %a :@ %a%a@]" kwd value_ident name - print_out_type ty pr_prims prims ] -and print_out_type_decl_list ppf = - fun - [ [] -> () - | [x] -> print_out_type_decl "type" ppf x - | [x :: l] -> - do { - print_out_type_decl "type" ppf x; - List.iter (fun x -> fprintf ppf "@ %a" (print_out_type_decl "and") x) - l - } ] -and print_out_type_decl kwd ppf (name, args, ty, constraints) = - let print_constraints ppf params = - List.iter - (fun (ty1, ty2) -> - fprintf ppf "@ @[<2>constraint %a =@ %a@]" print_out_type - ty1 print_out_type ty2) - params - in - let type_parameter ppf (ty, (co, cn)) = - fprintf ppf "%s'%s" (if not cn then "+" else if not co then "-" else "") - ty - in - let type_defined ppf = - match args with - [ [] -> fprintf ppf "%s" name - | [arg] -> fprintf ppf "@[%a@ %s@]" type_parameter arg name - | _ -> - fprintf ppf "@[(@[%a)@]@ %s@]" - (print_list type_parameter (fun ppf -> fprintf ppf ",@ ")) args - name ] - in - let print_manifest ppf = - fun - [ Otyp_manifest ty _ -> fprintf ppf " =@ %a" print_out_type ty - | _ -> () ] - in - let print_name_args ppf = - fprintf ppf "%s %t%a" kwd type_defined print_manifest ty - in - let ty = - match ty with - [ Otyp_manifest _ ty -> ty - | _ -> ty ] - in - match ty with - [ Otyp_abstract -> - fprintf ppf "@[<2>@[%t@]%a@]" print_name_args print_constraints - constraints - | Otyp_record lbls -> - fprintf ppf "@[<2>@[%t = {%a@;<1 -2>}@]@ %a@]" print_name_args - (print_list_init print_out_label (fun ppf -> fprintf ppf "@ ")) lbls - print_constraints constraints - | Otyp_sum constrs -> - fprintf ppf "@[<2>@[%t =@;<1 2>%a@]%a@]" print_name_args - (print_list print_out_constr (fun ppf -> fprintf ppf "@ | ")) constrs - print_constraints constraints - | ty -> - fprintf ppf "@[<2>@[%t =@ %a@]%a@]" print_name_args - print_out_type ty print_constraints constraints ] -and print_out_constr ppf (name, tyl) = - match tyl with - [ [] -> fprintf ppf "%s" name - | _ -> - fprintf ppf "@[<2>%s of@ %a@]" name - (print_typlist print_simple_out_type " *") tyl ] -and print_out_label ppf (name, mut, arg) = - fprintf ppf "@[<2>%s%s :@ %a@];" (if mut then "mutable " else "") name - print_out_type arg -; - -(* Signature items *) - -value print_out_class_params ppf = - fun - [ [] -> () - | tyl -> - fprintf ppf "@[<1>[%a]@]@ " - (print_list (fun ppf x -> fprintf ppf "'%s" x) - (fun ppf -> fprintf ppf ", ")) - tyl ] -; - -value rec print_out_class_type ppf = - fun - [ Octy_constr id tyl -> - let pr_tyl ppf = - fun - [ [] -> () - | tyl -> - fprintf ppf "@[<1>[%a]@]@ " - (print_typlist print_out_type ",") tyl ] - in - fprintf ppf "@[%a%a@]" pr_tyl tyl print_ident id - | Octy_fun lab ty cty -> - fprintf ppf "@[%s%a ->@ %a@]" (if lab <> "" then lab ^ ":" else "") - print_out_type_2 ty print_out_class_type cty - | Octy_signature self_ty csil -> - let pr_param ppf = - fun - [ Some ty -> fprintf ppf "@ @[(%a)@]" print_out_type ty - | None -> () ] - in - fprintf ppf "@[@[<2>object%a@]@ %a@;<1 -2>end@]" pr_param self_ty - (print_list print_out_class_sig_item (fun ppf -> fprintf ppf "@ ")) - csil ] -and print_out_class_sig_item ppf = - fun - [ Ocsg_constraint ty1 ty2 -> - fprintf ppf "@[<2>constraint %a =@ %a@]" print_out_type ty1 - print_out_type ty2 - | Ocsg_method name priv virt ty -> - fprintf ppf "@[<2>method %s%s%s :@ %a@]" - (if priv then "private " else "") (if virt then "virtual " else "") - name print_out_type ty - | Ocsg_value name mut ty -> - fprintf ppf "@[<2>val %s%s :@ %a@]" (if mut then "mutable " else "") - name print_out_type ty ] -; - -value rec print_out_module_type ppf = - fun - [ Omty_abstract -> () - | Omty_functor name mty_arg mty_res -> - fprintf ppf "@[<2>functor@ (%s : %a) ->@ %a@]" name - print_out_module_type mty_arg print_out_module_type mty_res - | Omty_ident id -> fprintf ppf "%a" print_ident id - | Omty_signature sg -> - fprintf ppf "@[sig@ %a@;<1 -2>end@]" print_signature_body sg ] -and print_signature_body ppf = - fun - [ [] -> () - | [item] -> print_out_sig_item ppf item - | [item :: items] -> - fprintf ppf "%a@ %a" print_out_sig_item item print_signature_body - items ] -and print_out_sig_item ppf = - fun - [ Osig_class vir_flag name params clt -> - fprintf ppf "@[<2>class%s@ %a%s@ :@ %a@]" - (if vir_flag then " virtual" else "") print_out_class_params params - name print_out_class_type clt - | Osig_class_type vir_flag name params clt -> - fprintf ppf "@[<2>class type%s@ %a%s@ =@ %a@]" - (if vir_flag then " virtual" else "") print_out_class_params params - name print_out_class_type clt - | Osig_exception id tyl -> - fprintf ppf "@[<2>exception %a@]" print_out_constr (id, tyl) - | Osig_modtype name Omty_abstract -> - fprintf ppf "@[<2>module type %s@]" name - | Osig_modtype name mty -> - fprintf ppf "@[<2>module type %s =@ %a@]" name print_out_module_type mty - | Osig_module name mty -> - fprintf ppf "@[<2>module %s :@ %a@]" name print_out_module_type mty - | Osig_type tdl -> print_out_type_decl_list ppf tdl - | Osig_value name ty prims -> - let kwd = if prims = [] then "val" else "external" in - let pr_prims ppf = - fun - [ [] -> () - | [s :: sl] -> - do { - fprintf ppf "@ = \"%s\"" s; - List.iter (fun s -> fprintf ppf "@ \"%s\"" s) sl - } ] - in - fprintf ppf "@[<2>%s %a :@ %a%a@]" kwd value_ident name print_out_type - ty pr_prims prims ] -and print_out_type_decl_list ppf = - fun - [ [] -> () - | [x] -> print_out_type_decl "type" ppf x - | [x :: l] -> - do { - print_out_type_decl "type" ppf x; - List.iter (fun x -> fprintf ppf "@ %a" (print_out_type_decl "and") x) - l - } ] -and print_out_type_decl kwd ppf (name, args, ty, constraints) = - let print_constraints ppf params = - List.iter - (fun (ty1, ty2) -> - fprintf ppf "@ @[<2>constraint %a =@ %a@]" print_out_type ty1 - print_out_type ty2) - params - in - let type_parameter ppf (ty, (co, cn)) = - fprintf ppf "%s'%s" (if not cn then "+" else if not co then "-" else "") - ty - in - let type_defined ppf = - match args with - [ [] -> fprintf ppf "%s" name - | [arg] -> fprintf ppf "@[%a@ %s@]" type_parameter arg name - | _ -> - fprintf ppf "@[(@[%a)@]@ %s@]" - (print_list type_parameter (fun ppf -> fprintf ppf ",@ ")) args - name ] - in - let print_manifest ppf = - fun - [ Otyp_manifest ty _ -> fprintf ppf " =@ %a" print_out_type ty - | _ -> () ] - in - let print_name_args ppf = - fprintf ppf "%s %t%a" kwd type_defined print_manifest ty - in - let ty = - match ty with - [ Otyp_manifest _ ty -> ty - | _ -> ty ] - in - match ty with - [ Otyp_abstract -> - fprintf ppf "@[<2>@[%t@]%a@]" print_name_args print_constraints - constraints - | Otyp_record lbls -> - fprintf ppf "@[<2>@[%t = {%a@;<1 -2>}@]@ %a@]" print_name_args - (print_list_init print_out_label (fun ppf -> fprintf ppf "@ ")) lbls - print_constraints constraints - | Otyp_sum constrs -> - fprintf ppf "@[<2>@[%t =@;<1 2>%a@]%a@]" print_name_args - (print_list print_out_constr (fun ppf -> fprintf ppf "@ | ")) constrs - print_constraints constraints - | ty -> - fprintf ppf "@[<2>@[%t =@ %a@]%a@]" print_name_args - print_out_type ty print_constraints constraints ] -and print_out_constr ppf (name, tyl) = - match tyl with - [ [] -> fprintf ppf "%s" name - | _ -> - fprintf ppf "@[<2>%s of@ %a@]" name - (print_typlist print_simple_out_type " *") tyl ] -and print_out_label ppf (name, mut, arg) = - fprintf ppf "@[<2>%s%s :@ %a@];" (if mut then "mutable " else "") name - print_out_type arg -; - -(* Phrases *) - -value print_out_exception ppf exn outv = - match exn with - [ Sys.Break -> fprintf ppf "Interrupted.@." - | Out_of_memory -> fprintf ppf "Out of memory during evaluation.@." - | Stack_overflow -> - fprintf ppf "Stack overflow during evaluation (looping recursion?).@." - | _ -> - fprintf ppf "@[Exception:@ %a.@]@." Toploop.print_out_value.val outv ] -; - -value rec print_items ppf = - fun - [ [] -> () - | [(tree, valopt) :: items] -> - do { - match valopt with - [ Some v -> - fprintf ppf "@[<2>%a =@ %a@]" Toploop.print_out_sig_item.val tree - Toploop.print_out_value.val v - | None -> fprintf ppf "@[%a@]" Toploop.print_out_sig_item.val tree ]; - if items <> [] then fprintf ppf "@ %a" print_items items else () - } ] -; - -value print_out_phrase ppf = - fun - [ Ophr_eval outv ty -> - fprintf ppf "@[- : %a@ =@ %a@]@." Toploop.print_out_type.val ty - Toploop.print_out_value.val outv - | Ophr_signature [] -> () - | Ophr_signature items -> fprintf ppf "@[%a@]@." print_items items - | Ophr_exception (exn, outv) -> print_out_exception ppf exn outv ] -; - -Toploop.print_out_value.val := print_out_value; -Toploop.print_out_type.val := print_out_type; -Toploop.print_out_sig_item.val := print_out_sig_item; -Toploop.print_out_phrase.val := print_out_phrase; diff --git a/camlp4/top/rprint.ml b/camlp4/top/rprint.ml deleted file mode 100644 index 76f19fe11e..0000000000 --- a/camlp4/top/rprint.ml +++ /dev/null @@ -1,422 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -open Format; -open Outcometree; - -exception Ellipsis; -value cautious f ppf arg = - try f ppf arg with [ Ellipsis -> fprintf ppf "..." ] -; - -value rec print_ident ppf = - fun - [ Oide_ident s -> fprintf ppf "%s" s - | Oide_dot id s -> fprintf ppf "%a.%s" print_ident id s - | Oide_apply id1 id2 -> - fprintf ppf "%a(%a)" print_ident id1 print_ident id2 ] -; - -value value_ident ppf name = - if List.mem name ["or"; "mod"; "land"; "lor"; "lxor"; "lsl"; "lsr"; "asr"] - then - fprintf ppf "( %s )" name - else - match name.[0] with - [ 'a'..'z' | '\223'..'\246' | '\248'..'\255' | '_' -> - fprintf ppf "%s" name - | _ -> fprintf ppf "( %s )" name ] -; - -(* Values *) - -value print_out_value ppf tree = - let rec print_tree ppf = - fun - [ Oval_constr name ([_ :: _] as params) -> - fprintf ppf "@[<1>%a@ %a@]" print_ident name - (print_tree_list print_simple_tree "") params - | Oval_variant name (Some param) -> - fprintf ppf "@[<2>`%s@ %a@]" name print_simple_tree param - | tree -> print_simple_tree ppf tree ] - and print_simple_tree ppf = - fun - [ Oval_int i -> fprintf ppf "%i" i - | Oval_int32 i -> fprintf ppf "%ldl" i - | Oval_int64 i -> fprintf ppf "%LdL" i - | Oval_nativeint i -> fprintf ppf "%ndn" i - | Oval_float f -> fprintf ppf "%.12g" f - | Oval_char c -> fprintf ppf "'%s'" (Char.escaped c) - | Oval_string s -> - try fprintf ppf "\"%s\"" (String.escaped s) with - [ Invalid_argument "String.create" -> fprintf ppf "" ] - | Oval_list tl -> - fprintf ppf "@[<1>[%a]@]" (print_tree_list print_tree ";") tl - | Oval_array tl -> - fprintf ppf "@[<2>[|%a|]@]" (print_tree_list print_tree ";") tl - | Oval_constr (Oide_ident "true") [] -> fprintf ppf "True" - | Oval_constr (Oide_ident "false") [] -> fprintf ppf "False" - | Oval_constr name [] -> print_ident ppf name - | Oval_variant name None -> fprintf ppf "`%s" name - | Oval_stuff s -> fprintf ppf "%s" s - | Oval_record fel -> - fprintf ppf "@[<1>{%a}@]" (cautious (print_fields True)) fel - | Oval_tuple tree_list -> - fprintf ppf "@[(%a)@]" (print_tree_list print_tree ",") tree_list - | Oval_ellipsis -> raise Ellipsis - | Oval_printer f -> f ppf - | tree -> fprintf ppf "@[<1>(%a)@]" (cautious print_tree) tree ] - and print_fields first ppf = - fun - [ [] -> () - | [(name, tree) :: fields] -> - let name = - match name with - [ Oide_ident "contents" -> Oide_ident "val" - | x -> x ] - in - do { - if not first then fprintf ppf ";@ " else (); - fprintf ppf "@[<1>%a=@,%a@]" print_ident name (cautious print_tree) - tree; - print_fields False ppf fields - } ] - and print_tree_list print_item sep ppf tree_list = - let rec print_list first ppf = - fun - [ [] -> () - | [tree :: tree_list] -> - do { - if not first then fprintf ppf "%s@ " sep else (); - print_item ppf tree; - print_list False ppf tree_list - } ] - in - cautious (print_list True) ppf tree_list - in - cautious print_tree ppf tree -; - -value rec print_list pr sep ppf = - fun - [ [] -> () - | [a] -> pr ppf a - | [a :: l] -> do { pr ppf a; sep ppf; print_list pr sep ppf l } ] -; - -value pr_vars = - print_list (fun ppf s -> fprintf ppf "'%s" s) (fun ppf -> fprintf ppf "@ ") -; - -value pr_present = - print_list (fun ppf s -> fprintf ppf "`%s" s) (fun ppf -> fprintf ppf "@ ") -; - -(* Types *) - -value rec print_out_type ppf = - fun - [ Otyp_alias ty s -> fprintf ppf "@[%a as '%s@]" print_out_type ty s - | ty -> print_out_type_1 ppf ty ] -and print_out_type_1 ppf = - fun - [ Otyp_arrow lab ty1 ty2 -> - fprintf ppf "@[%s%a ->@ %a@]" (if lab <> "" then lab ^ ":" else "") - print_out_type_2 ty1 print_out_type_1 ty2 - | Otyp_poly sl ty -> - fprintf ppf "@[%a.@ %a@]" - pr_vars sl - print_out_type ty - | ty -> print_out_type_2 ppf ty ] -and print_out_type_2 ppf = - fun - [ Otyp_constr id ([_ :: _] as tyl) -> - fprintf ppf "@[%a@;<1 2>%a@]" print_ident id - (print_typlist print_simple_out_type "") tyl - | ty -> print_simple_out_type ppf ty ] -and print_simple_out_type ppf = - let rec print_tkind ppf = - fun - [ Otyp_var ng s -> fprintf ppf "'%s%s" (if ng then "_" else "") s - | Otyp_constr id [] -> fprintf ppf "@[%a@]" print_ident id - | Otyp_tuple tyl -> - fprintf ppf "@[<1>(%a)@]" (print_typlist print_out_type " *") tyl - | Otyp_stuff s -> fprintf ppf "%s" s - | Otyp_variant non_gen row_fields closed tags -> - let print_present ppf = - fun - [ None | Some [] -> () - | Some l -> fprintf ppf "@;<1 -2>> @[%a@]" pr_present l ] - in - let print_fields ppf = - fun - [ Ovar_fields fields -> - print_list print_row_field (fun ppf -> fprintf ppf "@;<1 -2>| ") - ppf fields - | Ovar_name id tyl -> - fprintf ppf "@[%a%a@]" print_typargs tyl print_ident id ] - in - fprintf ppf "%s[|%s@[@[%a@]%a|]@]" (if non_gen then "_" else "") - (if closed then if tags = None then " " else "< " - else if tags = None then "> " - else "? ") - print_fields row_fields - print_present tags - | Otyp_object fields rest -> - fprintf ppf "@[<2>< %a >@]" (print_fields rest) fields - | Otyp_class ng id tyl -> - fprintf ppf "@[%a%s#%a@]" print_typargs tyl (if ng then "_" else "") - print_ident id - | Otyp_manifest ty1 ty2 -> - fprintf ppf "@[<2>%a ==@ %a@]" print_out_type ty1 print_out_type ty2 - | Otyp_sum constrs priv -> - fprintf ppf "@[%a[ %a ]@]" print_private priv - (print_list print_out_constr (fun ppf -> fprintf ppf "@ | ")) constrs - | Otyp_record lbls priv -> - fprintf ppf "@[%a{ %a }@]" print_private priv - (print_list print_out_label (fun ppf -> fprintf ppf ";@ ")) lbls - | Otyp_abstract -> fprintf ppf "'abstract" - | Otyp_alias _ _ | Otyp_poly _ _ - | Otyp_arrow _ _ _ | Otyp_constr _ [_ :: _] as ty -> - fprintf ppf "@[<1>(%a)@]" print_out_type ty ] - and print_private ppf = - fun - [ Asttypes.Public -> () - | Asttypes.Private -> fprintf ppf "private " - ] - in - print_tkind ppf -and print_out_constr ppf (name, tyl) = - match tyl with - [ [] -> fprintf ppf "%s" name - | _ -> - fprintf ppf "@[<2>%s of@ %a@]" name - (print_typlist print_out_type " and") tyl ] -and print_out_label ppf (name, mut, arg) = - fprintf ppf "@[<2>%s :@ %s%a@]" name (if mut then "mutable " else "") - print_out_type arg -and print_fields rest ppf = - fun - [ [] -> - match rest with - [ Some non_gen -> fprintf ppf "%s.." (if non_gen then "_" else "") - | None -> () ] - | [(s, t)] -> - do { - fprintf ppf "%s : %a" s print_out_type t; - match rest with - [ Some _ -> fprintf ppf ";@ " - | None -> () ]; - print_fields rest ppf [] - } - | [(s, t) :: l] -> - fprintf ppf "%s : %a;@ %a" s print_out_type t (print_fields rest) l ] -and print_row_field ppf (l, opt_amp, tyl) = - let pr_of ppf = - if opt_amp then fprintf ppf " of@ &@ " - else if tyl <> [] then fprintf ppf " of@ " - else fprintf ppf "" - in - fprintf ppf "@[`%s%t%a@]" l pr_of (print_typlist print_out_type " &") - tyl -and print_typlist print_elem sep ppf = - fun - [ [] -> () - | [ty] -> print_elem ppf ty - | [ty :: tyl] -> - fprintf ppf "%a%s@ %a" print_elem ty sep (print_typlist print_elem sep) - tyl ] -and print_typargs ppf = - fun - [ [] -> () - | [ty1] -> fprintf ppf "%a@ " print_simple_out_type ty1 - | tyl -> - fprintf ppf "@[<1>(%a)@]@ " (print_typlist print_out_type ",") tyl ] -; - -value print_out_class_params ppf = - fun - [ [] -> () - | tyl -> - fprintf ppf "@[<1>[%a]@]@ " - (print_list (fun ppf x -> fprintf ppf "'%s" x) - (fun ppf -> fprintf ppf ", ")) - tyl ] -; - -(* Signature items *) - -value rec print_out_class_type ppf = - fun - [ Octy_constr id tyl -> - let pr_tyl ppf = - fun - [ [] -> () - | tyl -> - fprintf ppf "@[<1>[%a]@]@ " - (print_typlist Toploop.print_out_type.val ",") tyl ] - in - fprintf ppf "@[%a%a@]" pr_tyl tyl print_ident id - | Octy_fun lab ty cty -> - fprintf ppf "@[%s[ %a ] ->@ %a@]" (if lab <> "" then lab ^ ":" else "") - Toploop.print_out_type.val ty print_out_class_type cty - | Octy_signature self_ty csil -> - let pr_param ppf = - fun - [ Some ty -> fprintf ppf "@ @[(%a)@]" Toploop.print_out_type.val ty - | None -> () ] - in - fprintf ppf "@[@[<2>object%a@]@ %a@;<1 -2>end@]" pr_param self_ty - (print_list print_out_class_sig_item (fun ppf -> fprintf ppf "@ ")) - csil ] -and print_out_class_sig_item ppf = - fun - [ Ocsg_constraint ty1 ty2 -> - fprintf ppf "@[<2>type %a =@ %a;@]" Toploop.print_out_type.val ty1 - Toploop.print_out_type.val ty2 - | Ocsg_method name priv virt ty -> - fprintf ppf "@[<2>method %s%s%s :@ %a;@]" - (if priv then "private " else "") (if virt then "virtual " else "") - name Toploop.print_out_type.val ty - | Ocsg_value name mut ty -> - fprintf ppf "@[<2>value %s%s :@ %a;@]" (if mut then "mutable " else "") - name Toploop.print_out_type.val ty ] -; - -value rec print_out_module_type ppf = - fun - [ Omty_ident id -> fprintf ppf "%a" print_ident id - | Omty_signature sg -> - fprintf ppf "@[sig@ %a@;<1 -2>end@]" - Toploop.print_out_signature.val sg - | Omty_functor name mty_arg mty_res -> - fprintf ppf "@[<2>functor@ (%s : %a) ->@ %a@]" name - print_out_module_type mty_arg print_out_module_type mty_res - | Omty_abstract -> () ] -and print_out_signature ppf = - fun - [ [] -> () - | [item] -> fprintf ppf "%a;" Toploop.print_out_sig_item.val item - | [item :: items] -> - fprintf ppf "%a;@ %a" Toploop.print_out_sig_item.val item - print_out_signature items ] -and print_out_sig_item ppf = - fun - [ Osig_class vir_flag name params clt -> - fprintf ppf "@[<2>class%s@ %a%s@ :@ %a@]" - (if vir_flag then " virtual" else "") print_out_class_params params - name Toploop.print_out_class_type.val clt - | Osig_class_type vir_flag name params clt -> - fprintf ppf "@[<2>class type%s@ %a%s@ =@ %a@]" - (if vir_flag then " virtual" else "") print_out_class_params params - name Toploop.print_out_class_type.val clt - | Osig_exception id tyl -> - fprintf ppf "@[<2>exception %a@]" print_out_constr (id, tyl) - | Osig_modtype name Omty_abstract -> - fprintf ppf "@[<2>module type %s@]" name - | Osig_modtype name mty -> - fprintf ppf "@[<2>module type %s =@ %a@]" name - Toploop.print_out_module_type.val mty - | Osig_module name mty -> - fprintf ppf "@[<2>module %s :@ %a@]" name - Toploop.print_out_module_type.val mty - | Osig_type tdl -> print_out_type_decl_list ppf tdl - | Osig_value name ty prims -> - let kwd = if prims = [] then "value" else "external" in - let pr_prims ppf = - fun - [ [] -> () - | [s :: sl] -> - do { - fprintf ppf "@ = \"%s\"" s; - List.iter (fun s -> fprintf ppf "@ \"%s\"" s) sl - } ] - in - fprintf ppf "@[<2>%s %a :@ %a%a@]" kwd value_ident name - Toploop.print_out_type.val ty pr_prims prims ] -and print_out_type_decl_list ppf = - fun - [ [] -> () - | [x] -> print_out_type_decl "type" ppf x - | [x :: l] -> - do { - print_out_type_decl "type" ppf x; - List.iter (fun x -> fprintf ppf "@ %a" (print_out_type_decl "and") x) - l - } ] -and print_out_type_decl kwd ppf (name, args, ty, constraints) = - let constrain ppf (ty, ty') = - fprintf ppf "@ @[<2>constraint %a =@ %a@]" Toploop.print_out_type.val ty - Toploop.print_out_type.val ty' - in - let print_constraints ppf params = List.iter (constrain ppf) params in - let type_parameter ppf (ty, (co, cn)) = - fprintf ppf "%s'%s" (if not cn then "+" else if not co then "-" else "") - ty - in - let type_defined ppf = - match args with - [ [] -> fprintf ppf "%s" name - | [arg] -> fprintf ppf "%s %a" name type_parameter arg - | _ -> - fprintf ppf "%s@ %a" name - (print_list type_parameter (fun ppf -> fprintf ppf "@ ")) args ] - in - fprintf ppf "@[<2>@[@[%s %t@] =@ %a@]%a@]" kwd type_defined - Toploop.print_out_type.val ty print_constraints constraints -; - -(* Phrases *) - -value print_out_exception ppf exn outv = - match exn with - [ Sys.Break -> fprintf ppf "Interrupted.@." - | Out_of_memory -> fprintf ppf "Out of memory during evaluation.@." - | Stack_overflow -> - fprintf ppf "Stack overflow during evaluation (looping recursion?).@." - | _ -> - fprintf ppf "@[Exception:@ %a.@]@." Toploop.print_out_value.val outv ] -; - -value rec print_items ppf = - fun - [ [] -> () - | [(tree, valopt) :: items] -> - do { - match valopt with - [ Some v -> - fprintf ppf "@[<2>%a =@ %a@]" Toploop.print_out_sig_item.val tree - Toploop.print_out_value.val v - | None -> fprintf ppf "@[%a@]" Toploop.print_out_sig_item.val tree ]; - if items <> [] then fprintf ppf "@ %a" print_items items else () - } ] -; - -value print_out_phrase ppf = - fun - [ Ophr_eval outv ty -> - fprintf ppf "@[- : %a@ =@ %a@]@." Toploop.print_out_type.val ty - Toploop.print_out_value.val outv - | Ophr_signature [] -> () - | Ophr_signature items -> fprintf ppf "@[%a@]@." print_items items - | Ophr_exception (exn, outv) -> print_out_exception ppf exn outv ] -; - -Toploop.print_out_value.val := print_out_value; -Toploop.print_out_type.val := print_out_type; -Toploop.print_out_class_type.val := print_out_class_type; -Toploop.print_out_module_type.val := print_out_module_type; -Toploop.print_out_sig_item.val := print_out_sig_item; -Toploop.print_out_signature.val := print_out_signature; -Toploop.print_out_phrase.val := print_out_phrase; diff --git a/config/.cvsignore b/config/.cvsignore deleted file mode 100644 index eaf9ea5524..0000000000 --- a/config/.cvsignore +++ /dev/null @@ -1,4 +0,0 @@ -m.h -s.h -Makefile - diff --git a/config/Makefile-templ b/config/Makefile-templ deleted file mode 100644 index d442a8c3e4..0000000000 --- a/config/Makefile-templ +++ /dev/null @@ -1,310 +0,0 @@ -######################################################################### -# # -# Objective Caml # -# # -# Xavier Leroy, projet Cristal, INRIA Rocquencourt # -# # -# Copyright 1999 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the GNU Library General Public License, with # -# the special exception on linking described in file ../LICENSE. # -# # -######################################################################### - -# $Id$ - -### Compile-time configuration - -########## General configuration - -### Where to install the binaries -BINDIR=/usr/local/bin - -### Where to install the standard library -LIBDIR=/usr/local/lib/ocaml -STUBLIBDIR=$(LIBDIR)/stublibs - -### Where to install the man pages -# Man pages for commands go in $(MANDIR)/man$(MANEXT) -# Man pages for the library go in $(MANDIR)/mano -MANDIR=/usr/local/man -MANEXT=1 - -### Do #! scripts work on your system? -### Beware: on some systems (e.g. SunOS 4), this will work only if -### the string "#!$(BINDIR)/ocamlrun" is less than 32 characters long. -### In doubt, set SHARPBANGSCRIPTS to false. -SHARPBANGSCRIPTS=true -#SHARPBANGSCRIPTS=false - -########## Configuration for the bytecode compiler - -### Which C compiler to use for the bytecode interpreter. -### Performance of the bytecode interpreter is *much* improved -### if Gnu CC version 2 is used. -#BYTECC=gcc -#BYTECC=cc - -### Additional compile-time options for $(BYTECC). -# If using gcc on Intel 386 or Motorola 68k: -# (the -fno-defer-pop option circumvents a bug in certain versions of gcc) -#BYTECCCOMPOPTS=-fno-defer-pop -Wall -# If using gcc and being superstitious: -#BYTECCCOMPOPTS=-Wall -# Under NextStep: -#BYTECCCOMPOPTS=-U__GNUC__ -fno-defer-pop -Wall -# Otherwise: -#BYTECCCOMPOPTS= - -### Additional link-time options for $(BYTECC) -### If using GCC on a Dec Alpha under OSF1: -#BYTECCLINKOPTS=-Wl,-T,12000000 -Wl,-D,14000000 -# To support dynamic loading of shared libraries (they need to look at -# our own symbols): -#BYTECCLINKOPTS=-Wl,-E -# Otherwise: -#BYTECCLINKOPTS= - -### Libraries needed -# On most platforms: -#CCLIBS=-lcurses -ltermcap -lm - -### How to invoke the C preprocessor -# This is not needed anymore. Leave these lines commented out. -# On most machines: -#CPP=/lib/cpp -P -# Under Solaris: -#CPP=/usr/ccs/lib/cpp -P -# Under FreeBSD: -#CPP=cpp -P - -### How to invoke ranlib -# BSD-style: -#RANLIB=ranlib -#RANLIBCMD=ranlib -# If ranlib is not needed: -#RANLIB=ar rs -#RANLIBCMD= - -### Shared library support -# Extension for shared libraries: so if supported, a if not supported -#SO=so -#SO=a -# Set to nothing if shared libraries supported, and to -custom if not supported -#CUSTOM_IF_NOT_SHARED= -#CUSTOM_IF_NOT_SHARED=-custom -# Options to $(BYTECC) to produce shared objects (e.g. PIC) -#SHAREDCCCOMPOPTS=-fPIC -# How to build a shared library, invoked with output .so as first arg -# and object files as remaining args -#MKSHAREDLIB=gcc -shared -o -# Compile-time option to $(BYTECC) to add a directory to be searched -# at run-time for shared libraries -#BYTECCRPATH=-Wl,-rpath - -############# Configuration for the native-code compiler - -### Name of architecture for the native-code compiler -### Currently supported: -### -### alpha Digital/Compaq Alpha machines under DUnix/Tru64 or Linux -### i386 Intel Pentium PCs under Linux, *BSD*, NextStep -### sparc Sun Sparcstation under SunOS 4.1 or Solaris 2 -### mips SGI machines under IRIX -### hppa HP 9000/700 under HPUX -### power Mac OS X; IBM RS6000 and PowerPC workstations under AIX -### ia64 Intel Itanium/IA64 under Linux -### arm ARM under Linux -### -### Set ARCH=none if your machine is not supported -#ARCH=alpha -#ARCH=i386 -#ARCH=sparc -#ARCH=mips -#ARCH=hppa -#ARCH=power -#ARCH=ia64 -#ARCH=arm -#ARCH=none - -### Name of architecture model for the native-code compiler. -### Some architectures come in several slightly different flavors -### that share a common code generator. This variable tailors the -### behavior of the code generator to the particular flavor used. -### Currently needed only if ARCH=power; leave MODEL=default for -### other architectures. -### If ARCH=power: choose between -### MODEL=rs6000 The original IBM RS6000 workstations -### (RIOS and RIOS2 processors) -### MODEL=ppc The newer PowerPC processors -### (Motorola/IBM PPC601, PPC603, PPC604, G3, G4, etc) -### The Motorola PPC601 is compatible with both models, but the newer -### PPCs will work only with MODEL=ppc, and the older IBM RS6000 -### workstations will work only with MODEL=rs6000. -### -### For other architectures: leave MODEL=default -### -#MODEL=rs6000 -#MODEL=ppc -#MODEL=default - -### Name of operating system family for the native-code compiler. -### If ARCH=sparc: choose between -### SYSTEM=sunos SunOS 4.1 -### SYSTEM=solaris Solaris 2 -### -### If ARCH=i386: choose between -### SYSTEM=linux_aout Linux with a.out binaries -### SYSTEM=linux_elf Linux with ELF binaries -### SYSTEM=bsd FreeBSD, probably works for NetBSD also -### SYSTEM=nextstep NextStep -### -### For other architectures: set SYSTEM=unknown -### -#SYSTEM=sunos -#SYSTEM=solaris -#SYSTEM=linux -#SYSTEM=linux_elf -#SYSTEM=bsd -#SYSTEM=nextstep -#SYSTEM=unknown - -### Which C compiler to use for the native-code compiler. -### cc is better than gcc on the Mips and Alpha. -#NATIVECC=cc -#NATIVECC=gcc - -### Additional compile-time options for $(NATIVECC). -# For cc on the Alpha: -#NATIVECCCOMPOPTS=-std1 -# For cc on the Mips: -#NATIVECCCOMPOPTS=-std -# For gcc if superstitious: -#NATIVECCCOMPOPTS=-Wall - -### Additional link-time options for $(NATIVECC) -#NATIVECCLINKOPTS= - -# Compile-time option to $(NATIVECC) to add a directory to be searched -# at run-time for shared libraries -#NATIVECCRPATH=-Wl,-rpath - -### Flags for the assembler -# For the Alpha or the Mips: -#ASFLAGS=-O2 -# For the PowerPC: -#ASFLAGS=-u -m ppc -w -# For the RS6000: -#ASFLAGS=-u -m pwr -w -# Otherwise: -#ASFLAGS= - -### Command and flags to use for assembling .S files (often with preprocessing) -# If gcc is available: -#ASPP=gcc -#ASPPFLAGS=-c -DSYS_$(SYSTEM) -# On SunOS and Solaris: -#ASPP=$(AS) -#ASPPFLAGS=-P -DSYS_$(SYSTEM) -# Otherwise: -#ASPP=$(AS) -#ASPPFLAGS= - -### Extra flags to use for assembling .S files in profiling mode -# On Digital Unix: -#ASPPPROFFLAGS=-pg -DPROFILING -# Otherwise: -#ASPPPROFFLAGS=-DPROFILING - -### Whether profiling with gprof is supported -# If yes: (x86/Linux, Alpha/Digital Unix, Sparc/Solaris): -#PROFILING=prof -# If no: (all others) -#PROFILING=noprof - -### Option to give to the C compiler for profiling -#CC_PROFILE=-pg -#CC_PROFILE=-xpg - -### How to perform a partial link -PARTIALLD=ld -r $(NATIVECCLINKOPTS) -PACKLD=$(PARTIALLD) - -### Path to the "objcopy" program from GNU binutils. -# You need a sufficiently recent version of the binutils so that -# the option --redefine-sym is supported by objcopy. -# Leave blank if you don't have "objcopy", but then "ocamlopt -pack" -# will not work -#BINUTILS_OBJCOPY=/usr/bin/objcopy - -### Path to the "nm" program from GNU binutils. -# Other versions of nm do *not* work for our purposes. -# Leave blank if you don't have GNU "nm", but then "ocamlopt -pack" -# will not work -#BINUTILS_NM=/usr/bin/nm - -############# Configuration for the contributed libraries - -### Which libraries to compile and install -# Currently available: -# unix Unix system calls -# str Regular expressions and high-level string processing -# num Arbitrary-precision rational arithmetic -# threads Lightweight concurrent processes -# systhreads Same as threads, requires POSIX threads -# graph Portable drawing primitives for X11 -# dynlink Dynamic linking of bytecode -# labltk Tcl/Tk interface -# bigarray Large, multidimensional numerical arrays - -OTHERLIBRARIES=unix str num threads graph dynlink labltk bigarray - -### Name of the target architecture for the "num" library -# Known targets: -# x86 68K vax ns mips alpha pyramid i960 -# sparc supersparc sparc-solaris supersparc-solaris -# See the file otherlibs/num/README for more explanations. -# If you don't know, leave BIGNUM_ARCH=C, which selects a portable -# C implementation of these routines. -BIGNUM_ARCH=alpha - -### Link-time options to ocamlc or ocamlopt for linking with POSIX threads -# Needed for the "systhreads" package -# Usually: -#PTHREAD_LINK=-cclib -lpthread -# For Solaris: -#PTHREAD_LINK=-cclib -lpthread -cclib -lposix4 - -### -I options for finding the X11/*.h includes -# Needed for the "graph" and "labltk" packages -# Usually: -#X11_INCLUDES=-I/usr/X11R6/include -# For SunOS with OpenLook: -#X11_INCLUDES=/usr/openwin/include - -### Link-time options to ocamlc or ocamlopt for linking with X11 libraries -# Needed for the "graph" and "labltk" packages -# Usually: -#X11_LINK=-lX11 -# For SunOS with OpenLook: -#X11_LINK=-L$(X11_LIB) -lX11 - -### -I options for finding the include file ndbm.h -# Needed for the "dbm" package -# Usually: -#DBM_INCLUDES= -# For recent Linux systems: -#DBM_INCLUDES=-I/usr/include/gdbm - -### Preprocessor options for finding tcl.h and tk.h -# Needed for the "labltk" package -# Required only if not in the standard include path. -# For Tcl/Tk 8.0 on FreeBSD: -#TK_DEFS="-I/usr/local/include/tcl8.0 -I/usr/local/include/tk8.0" - -### Linker options for linking tcl and tk libraries -# Needed for the "labltk" package -# Usually (with appropriate version numbers): -#TK_LINK="-ltk8.0 -ltcl8.0" -# For Tcl/Tk 8.0 on FreeBSD: -#TK_LINK="-L/usr/local/lib -ltk8.0 -ltcl8.0" diff --git a/config/Makefile.mingw b/config/Makefile.mingw deleted file mode 100644 index b7b02a15f5..0000000000 --- a/config/Makefile.mingw +++ /dev/null @@ -1,123 +0,0 @@ -######################################################################### -# # -# Objective Caml # -# # -# Xavier Leroy, projet Cristal, INRIA Rocquencourt # -# # -# Copyright 1999 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the GNU Library General Public License, with # -# the special exception on linking described in file ../LICENSE. # -# # -######################################################################### - -# $Id$ - -# Configuration for Windows, Mingw compiler - -######### General configuration - -PREFIX=C:/ocamlmgw - -### Where to install the binaries -BINDIR=$(PREFIX)/bin - -### Where to install the standard library -LIBDIR=$(PREFIX)/lib - -### Where to install the stub DLLs -STUBLIBDIR=$(LIBDIR)/stublibs - -### Where to install the info files -DISTRIB=$(PREFIX) - -########## Toolchain and OS dependencies - -TOOLCHAIN=mingw -CCOMPTYPE=cc -O=o -A=a -S=s -SO=s.o -DO=d.o -EXE=.exe - -########## Configuration for the bytecode compiler - -### Which C compiler to use for the bytecode interpreter. -BYTECC=gcc -mno-cygwin - -### Additional compile-time options for $(BYTECC). (For static linking.) -BYTECCCOMPOPTS=-O -mms-bitfields -Wall -Wno-unused - -### Additional link-time options for $(BYTECC). (For static linking.) -BYTECCLINKOPTS= - -### Additional compile-time options for $(BYTECC). (For building a DLL.) -DLLCCCOMPOPTS=-O -mms-bitfields -Wall -Wno-unused -DCAML_DLL - -### Libraries needed -BYTECCLIBS= -NATIVECCLIBS= - -### How to invoke the C preprocessor -CPP=$(BYTECC) -E - -### How to build a DLL -MKDLL=$(BYTECC) -shared -o $(1) -Wl,--out-implib,$(2) $(3) - -### How to build a static library -MKLIB=rm -f $(1); ar rcs $(1) $(2) - -### Canonicalize the name of a system library -SYSLIB=-l$(1) - -### The ranlib command -RANLIBCMD=ranlib - -############# Configuration for the native-code compiler - -### Name of architecture for the native-code compiler -ARCH=i386 - -### Name of architecture model for the native-code compiler. -MODEL=default - -### Name of operating system family for the native-code compiler. -SYSTEM=mingw - -### Which C compiler to use for the native-code compiler. -NATIVECC=$(BYTECC) - -### Additional compile-time options for $(NATIVECC). -NATIVECCCOMPOPTS=-O -mms-bitfields -Wall -Wno-unused - -### Additional link-time options for $(NATIVECC) -NATIVECCLINKOPTS= - -### Build partially-linked object file -PARTIALLD=ld -r $(NATIVECCLINKOPTS) -PACKLD=$(PARTIALLD) - -### nm and objcopy from GNU binutils -BINUTILS_NM=nm -BINUTILS_OBJCOPY=objcopy - -############# Configuration for the contributed libraries - -OTHERLIBRARIES=win32unix systhreads str num win32graph dynlink bigarray labltk - -### Name of the target architecture for the "num" library -BIGNUM_ARCH=C - -### Configuration for LablTk -# Set TK_ROOT to the directory where you installed TCL/TK 8.3 -# There must be no spaces or special characters in $(TK_ROOT) -TK_ROOT=c:/tcl -TK_DEFS=-I$(TK_ROOT)/include -TK_LINK=$(TK_ROOT)/lib/tk83.lib $(TK_ROOT)/lib/tcl83.lib - -############# Aliases for common commands - -MAKEREC=$(MAKE) -f Makefile.nt -MAKECMD=$(MAKE) diff --git a/config/Makefile.msvc b/config/Makefile.msvc deleted file mode 100644 index 7144f9e01e..0000000000 --- a/config/Makefile.msvc +++ /dev/null @@ -1,129 +0,0 @@ -######################################################################### -# # -# Objective Caml # -# # -# Xavier Leroy, projet Cristal, INRIA Rocquencourt # -# # -# Copyright 1999 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the GNU Library General Public License, with # -# the special exception on linking described in file ../LICENSE. # -# # -######################################################################### - -# $Id$ - -# Configuration for Windows, Visual C++ compiler - -######### General configuration - -PREFIX=C:/ocaml - -### Where to install the binaries. -BINDIR=$(PREFIX)/bin - -### Where to install the standard library -LIBDIR=$(PREFIX)/lib - -### Where to install the stub DLLs -STUBLIBDIR=$(LIBDIR)/stublibs - -### Where to install the info files -DISTRIB=$(PREFIX) - -########## Toolchain and OS dependencies - -TOOLCHAIN=msvc -CCOMPTYPE=msvc -O=obj -A=lib -S=asm -SO=s.obj -DO=d.obj -EXE=.exe - -########## Configuration for the bytecode compiler - -### Which C compiler to use for the bytecode interpreter. -BYTECC=cl /nologo - -### Additional compile-time options for $(BYTECC). (For static linking.) -BYTECCCOMPOPTS=/Ox /MT - -### Additional link-time options for $(BYTECC). (For static linking.) -BYTECCLINKOPTS=/MT - -### Additional compile-time options for $(BYTECC). (For building a DLL.) -DLLCCCOMPOPTS=/Ox /MD -DCAML_DLL - -### Libraries needed -BYTECCLIBS=advapi32.lib -NATIVECCLIBS=advapi32.lib - -### How to invoke the C preprocessor -CPP=cl /nologo /EP - -### How to build a DLL -MKDLL=link /nologo /dll /out:$(1) /implib:$(2) $(3) - -### How to build a static library -MKLIB=lib /nologo /debugtype:CV /out:$(1) $(2) - -### Canonicalize the name of a system library -SYSLIB=$(1).lib - -### The ranlib command -RANLIBCMD= - -############# Configuration for the native-code compiler - -### Name of architecture for the native-code compiler -ARCH=i386 - -### Name of architecture model for the native-code compiler. -MODEL=default - -### Name of operating system family for the native-code compiler. -SYSTEM=win32 - -### Which C compiler to use for the native-code compiler. -NATIVECC=cl /nologo - -### Additional compile-time options for $(NATIVECC). -NATIVECCCOMPOPTS=/Ox /MT - -### Additional link-time options for $(NATIVECC) -NATIVECCLINKOPTS=/MT - -### Build partially-linked object file -PARTIALLD=lib /nologo /debugtype:cv -PACKLD=ld -r --oformat pe-i386 - -### nm and objcopy are missing -BINUTILS_NM=nm -BINUTILS_OBJCOPY=objcopy - -############# Configuration for the contributed libraries - -OTHERLIBRARIES=win32unix systhreads str num win32graph dynlink bigarray labltk - -### Name of the target architecture for the "num" library -BIGNUM_ARCH=C - -### Configuration for LablTk -# Set TK_ROOT to the directory where you installed TCL/TK 8.3 -TK_ROOT=c:/tcl -TK_DEFS=-I$(TK_ROOT)/include -# The following definition avoids hard-wiring $(TK_ROOT) in the libraries -# produced by OCaml, and is therefore required for binary distribution -# of these libraries. However, $(TK_ROOT) must be added to the LIB -# environment variable, as described in README.win32. -TK_LINK=tk83.lib tcl83.lib -# An alternative definition that avoids mucking with the LIB variable, -# but hard-wires the Tcl/Tk location in the binaries -# TK_LINK=$(TK_ROOT)/tk83.lib $(TK_ROOT)/tcl83.lib - -############# Aliases for common commands - -MAKEREC=$(MAKE) -f Makefile.nt -MAKECMD=$(MAKE) diff --git a/config/auto-aux/align.c b/config/auto-aux/align.c deleted file mode 100644 index 0bedf77a02..0000000000 --- a/config/auto-aux/align.c +++ /dev/null @@ -1,103 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 1996 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 file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include -#include -#include - -long foo; - -void access16(short int *p) -{ - foo = *p; -} - -void access32(long int *p) -{ - foo = *p; -} - -jmp_buf failure; - -void sig_handler(int dummy) -{ - longjmp(failure, 1); -} - -int test(void (*fct) (/* ??? */), char *p) -{ - int res; - - signal(SIGSEGV, sig_handler); - signal(SIGBUS, sig_handler); - if(setjmp(failure) == 0) { - fct(p); - res = 0; - } else { - res = 1; - } - signal(SIGSEGV, SIG_DFL); - signal(SIGBUS, SIG_DFL); - return res; -} - -jmp_buf timer; - -void alarm_handler(int dummy) -{ - longjmp(timer, 1); -} - -void use(int n) -{ - return; -} - -int speedtest(char *p) -{ - int * q; - volatile int total; - int i; - volatile int sum; - - signal(SIGALRM, alarm_handler); - sum = 0; - if (setjmp(timer) == 0) { - alarm(1); - total = 0; - while(1) { - for (q = (int *) p, i = 1000; i > 0; q++, i--) - sum += *q; - total++; - } - } - use(sum); - signal(SIGALRM, SIG_DFL); - return total; -} - -main(void) -{ - long n[1001]; - int speed_aligned, speed_unaligned; - - if (test(access16, (char *) n + 1)) exit(1); - if (test(access32, (char *) n + 1)) exit(1); - if (test(access32, (char *) n + 2)) exit(1); - speed_aligned = speedtest((char *) n); - speed_unaligned = speedtest((char *) n + 1); - if (speed_aligned >= 3 * speed_unaligned) exit(1); - exit(0); -} diff --git a/config/auto-aux/ansi.c b/config/auto-aux/ansi.c deleted file mode 100644 index f1a416b857..0000000000 --- a/config/auto-aux/ansi.c +++ /dev/null @@ -1,21 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 1997 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 file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -int main() -{ -#ifdef __STDC__ - return 0; -#else - return 1; -#endif -} diff --git a/config/auto-aux/async_io.c b/config/auto-aux/async_io.c deleted file mode 100644 index 2b5faa2d70..0000000000 --- a/config/auto-aux/async_io.c +++ /dev/null @@ -1,60 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 1996 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 file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include -#include -#include -#include -#include -#include -#include "s.h" - -int signalled; - -void sigio_handler(int arg) -{ - signalled = 1; -} - -int main(void) -{ -#if defined(SIGIO) && defined(FASYNC) && defined(F_SETFL) && defined(F_SETOWN) - int p[2]; - int ret; -#define OUT 0 -#define IN 1 - if (socketpair(PF_UNIX, SOCK_STREAM, 0, p) == -1) return 1; - signalled = 0; - signal(SIGIO, sigio_handler); - ret = fcntl(p[OUT], F_GETFL, 0); - fcntl(p[OUT], F_SETFL, ret | FASYNC); - fcntl(p[OUT], F_SETOWN, getpid()); - switch(fork()) { - case -1: - return 1; - case 0: - close(p[OUT]); - write(p[IN], "x", 1); - sleep(1); - exit(0); - default: - close(p[IN]); - while(wait(NULL) == -1 && errno == EINTR) /*nothing*/; - } - if (signalled) return 0; else return 1; -#else - return 1; -#endif -} diff --git a/config/auto-aux/bytecopy.c b/config/auto-aux/bytecopy.c deleted file mode 100644 index 923b444e5b..0000000000 --- a/config/auto-aux/bytecopy.c +++ /dev/null @@ -1,34 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 1996 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 file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -char buffer[27]; - -#ifdef reverse -#define cpy(s1,s2,n) copy(s2,s1,n) -#else -#define cpy copy -#endif - -int main(int argc, char ** argv) -{ - cpy("abcdefghijklmnopqrstuvwxyz", buffer, 27); - if (strcmp(buffer, "abcdefghijklmnopqrstuvwxyz") != 0) exit(1); - cpy(buffer, buffer+3, 26-3); - if (strcmp(buffer, "abcabcdefghijklmnopqrstuvw") != 0) exit(1); - cpy("abcdefghijklmnopqrstuvwxyz", buffer, 27); - cpy(buffer+3, buffer, 26-3); - if (strcmp(buffer, "defghijklmnopqrstuvwxyzxyz") != 0) exit(1); - exit(0); -} diff --git a/config/auto-aux/dblalign.c b/config/auto-aux/dblalign.c deleted file mode 100644 index 9b44a774e2..0000000000 --- a/config/auto-aux/dblalign.c +++ /dev/null @@ -1,55 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 1996 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 file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include -#include -#include - -double foo; - -void access_double(double *p) -{ - foo = *p; -} - -jmp_buf failure; - -void sig_handler(int sig) -{ - longjmp(failure, 1); -} - -int main(void) -{ - long n[10]; - int res; - signal(SIGSEGV, sig_handler); -#ifdef SIGBUS - signal(SIGBUS, sig_handler); -#endif - if(setjmp(failure) == 0) { - access_double((double *) n); - access_double((double *) (n+1)); - res = 0; - } else { - res = 1; - } - signal(SIGSEGV, SIG_DFL); -#ifdef SIGBUS - signal(SIGBUS, SIG_DFL); -#endif - exit(res); -} - diff --git a/config/auto-aux/divmod.c b/config/auto-aux/divmod.c deleted file mode 100644 index 24d3786cec..0000000000 --- a/config/auto-aux/divmod.c +++ /dev/null @@ -1,47 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 1996 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 file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -/* Test semantics of division and modulus for negative arguments */ - -long div4[] = -{ -4,-3,-3,-3,-3,-2,-2,-2,-2,-1,-1,-1,-1,0,0,0, - 0,0,0,0,1,1,1,1,2,2,2,2,3,3,3,3,4 }; - -long divm4[] = -{ 4,3,3,3,3,2,2,2,2,1,1,1,1,0,0,0, - 0,0,0,0,-1,-1,-1,-1,-2,-2,-2,-2,-3,-3,-3,-3,-4 }; - -long mod4[] = -{ 0,-3,-2,-1,0,-3,-2,-1,0,-3,-2,-1,0,-3,-2,-1, - 0,1,2,3,0,1,2,3,0,1,2,3,0,1,2,3,0 }; - -long modm4[] = -{ 0,-3,-2,-1,0,-3,-2,-1,0,-3,-2,-1,0,-3,-2,-1, - 0,1,2,3,0,1,2,3,0,1,2,3,0,1,2,3,0 }; - -long q1 = 4; -long q2 = -4; - -int main() -{ - int i; - for (i = -16; i <= 16; i++) { - if (i / q1 != div4[i+16]) return 1; - if (i / q2 != divm4[i+16]) return 1; - if (i % q1 != mod4[i+16]) return 1; - if (i % q2 != modm4[i+16]) return 1; - } - return 0; -} diff --git a/config/auto-aux/elf.c b/config/auto-aux/elf.c deleted file mode 100644 index 026c4838eb..0000000000 --- a/config/auto-aux/elf.c +++ /dev/null @@ -1,26 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 1999 Institut National de Recherche en Informatique et */ -/* en Automatique. All rights reserved. This file is distributed */ -/* under the terms of the GNU Library General Public License, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include - -int main(int argc, char ** argv) -{ -#ifdef __ELF__ - printf("elf\n"); -#else - printf("aout\n"); -#endif - return 0; -} diff --git a/config/auto-aux/endian.c b/config/auto-aux/endian.c deleted file mode 100644 index def617f0f5..0000000000 --- a/config/auto-aux/endian.c +++ /dev/null @@ -1,41 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 1996 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 file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include "m.h" - -#ifndef ARCH_SIXTYFOUR -long intval = 0x41424344L; -char * bigendian = "ABCD"; -char * littleendian = "DCBA"; -#else -long intval = 0x4142434445464748L; -char * bigendian = "ABCDEFGH"; -char * littleendian = "HGFEDCBA"; -#endif - -main(void) -{ - long n[2]; - char * p; - - n[0] = intval; - n[1] = 0; - p = (char *) n; - if (strcmp(p, bigendian) == 0) - exit(0); - if (strcmp(p, littleendian) == 0) - exit(1); - exit(2); -} diff --git a/config/auto-aux/getgroups.c b/config/auto-aux/getgroups.c deleted file mode 100644 index 1ed8a1fbb1..0000000000 --- a/config/auto-aux/getgroups.c +++ /dev/null @@ -1,32 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 1996 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 file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include -#include - -#ifdef NGROUPS_MAX - -int main(void) -{ - int gidset[NGROUPS_MAX]; - if (getgroups(NGROUPS_MAX, gidset) == -1) return 1; - return 0; -} - -#else - -int main(void) { return 1; } - -#endif diff --git a/config/auto-aux/gethostbyaddr.c b/config/auto-aux/gethostbyaddr.c deleted file mode 100644 index c5dd129719..0000000000 --- a/config/auto-aux/gethostbyaddr.c +++ /dev/null @@ -1,51 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 2002 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 file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#ifndef _REENTRANT -/* This helps detection on Digital Unix... */ -#define _REENTRANT -#endif - -#include -#include - -int main(int argc, char ** argv) -{ -#if NUM_ARGS == 7 - char * address; - int length; - int type; - struct hostent h; - char buffer[10]; - int buflen; - int h_errnop; - struct hostent * hp; - hp = gethostbyaddr_r(address, length, type, &h, - buffer, buflen, &h_errnop); -#elif NUM_ARGS == 8 - char * address; - int length; - int type; - struct hostent h; - char buffer[10]; - int buflen; - int h_errnop; - struct hostent * hp; - int rc; - rc = gethostbyaddr_r(address, length, type, &h, - buffer, buflen, &hp, &h_errnop); -#endif - return 0; -} diff --git a/config/auto-aux/gethostbyname.c b/config/auto-aux/gethostbyname.c deleted file mode 100644 index 043b9d3343..0000000000 --- a/config/auto-aux/gethostbyname.c +++ /dev/null @@ -1,41 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 2002 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 file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#ifndef _REENTRANT -/* This helps detection on Digital Unix... */ -#define _REENTRANT -#endif - -#include -#include - -int main(int argc, char ** argv) -{ -#if NUM_ARGS == 5 - struct hostent *hp; - struct hostent h; - char buffer[1000]; - int h_errno; - hp = gethostbyname_r("www.caml.org", &h, buffer, 10, &h_errno); -#elif NUM_ARGS == 6 - struct hostent *hp; - struct hostent h; - char buffer[1000]; - int h_errno; - int rc; - rc = gethostbyname_r("www.caml.org", &h, buffer, 10, &hp, &h_errno); -#endif - return 0; -} diff --git a/config/auto-aux/hasgot b/config/auto-aux/hasgot deleted file mode 100755 index 99384768a9..0000000000 --- a/config/auto-aux/hasgot +++ /dev/null @@ -1,28 +0,0 @@ -#!/bin/sh - -opts="" -libs="$cclibs" -args=$* -rm -f hasgot.c -while : ; do - case "$1" in - -i) echo "#include <$2>" >> hasgot.c; shift;; - -t) echo "$2 the_$2;" >> hasgot.c; shift;; - -l*|-L*|-F*) libs="$libs $1";; - -framework) libs="$libs $1 $2"; shift;; - -*) opts="$opts $1";; - *) break;; - esac - shift -done - -(echo "main() {" - for f in $*; do echo " $f();"; done - echo "}") >> hasgot.c - -if test "$verbose" = yes; then - echo "hasgot $args: $cc $opts -o tst hasgot.c $libs" >&2 - exec $cc $opts -o tst hasgot.c $libs > /dev/null -else - exec $cc $opts -o tst hasgot.c $libs > /dev/null 2>/dev/null -fi diff --git a/config/auto-aux/ia32sse2.c b/config/auto-aux/ia32sse2.c deleted file mode 100644 index d4f72e7728..0000000000 --- a/config/auto-aux/ia32sse2.c +++ /dev/null @@ -1,22 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 2003 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 file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -/* Test whether IA32 assembler supports SSE2 instructions */ - -int main() -{ - asm("pmuludq %mm1, %mm0"); - return 0; -} diff --git a/config/auto-aux/int64align.c b/config/auto-aux/int64align.c deleted file mode 100644 index 5c77b39c58..0000000000 --- a/config/auto-aux/int64align.c +++ /dev/null @@ -1,56 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 2000 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 file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include -#include -#include -#include "m.h" - -ARCH_INT64_TYPE foo; - -void access_int64(ARCH_INT64_TYPE *p) -{ - foo = *p; -} - -jmp_buf failure; - -void sig_handler(int sig) -{ - longjmp(failure, 1); -} - -int main(void) -{ - long n[10]; - int res; - signal(SIGSEGV, sig_handler); -#ifdef SIGBUS - signal(SIGBUS, sig_handler); -#endif - if(setjmp(failure) == 0) { - access_int64((ARCH_INT64_TYPE *) n); - access_int64((ARCH_INT64_TYPE *) (n+1)); - res = 0; - } else { - res = 1; - } - signal(SIGSEGV, SIG_DFL); -#ifdef SIGBUS - signal(SIGBUS, SIG_DFL); -#endif - exit(res); -} - diff --git a/config/auto-aux/longlong.c b/config/auto-aux/longlong.c deleted file mode 100644 index bcdf4c974b..0000000000 --- a/config/auto-aux/longlong.c +++ /dev/null @@ -1,43 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 1996 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 file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include -#include - -/* Check for the availability of "long long" type as per ISO C9X */ - -/* Meaning of return code: - 0 long long OK, printf with %ll - 1 long long OK, printf with %q - 2 long long OK, no printf - 3 long long not suitable */ - -int main(int argc, char **argv) -{ - long long l; - unsigned long long u; - char buffer[64]; - - if (sizeof(long long) != 8) return 3; - l = 123456789123456789LL; - buffer[0] = '\0'; - sprintf(buffer, "%lld", l); - if (strcmp(buffer, "123456789123456789") == 0) return 0; - /* the MacOS X library uses qd to format long longs */ - buffer[0] = '\0'; - sprintf (buffer, "%qd", l); - if (strcmp (buffer, "123456789123456789") == 0) return 1; - return 2; -} diff --git a/config/auto-aux/runtest b/config/auto-aux/runtest deleted file mode 100755 index ce65bd07f1..0000000000 --- a/config/auto-aux/runtest +++ /dev/null @@ -1,8 +0,0 @@ -#!/bin/sh -if test "$verbose" = yes; then -echo "runtest: $cc -o tst $* $cclibs" >&2 -$cc -o tst $* $cclibs || exit 100 -else -$cc -o tst $* $cclibs 2> /dev/null || exit 100 -fi -exec ./tst diff --git a/config/auto-aux/schar.c b/config/auto-aux/schar.c deleted file mode 100644 index 55d49f31a7..0000000000 --- a/config/auto-aux/schar.c +++ /dev/null @@ -1,23 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 1996 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 file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -char foo[]="\377"; - -int main(int argc, char ** argv) -{ - int i; - i = foo[0]; - exit(i != -1); -} diff --git a/config/auto-aux/schar2.c b/config/auto-aux/schar2.c deleted file mode 100644 index d1d781a53e..0000000000 --- a/config/auto-aux/schar2.c +++ /dev/null @@ -1,23 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 1996 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 file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -signed char foo[]="\377"; - -int main(int argc, char ** argv) -{ - int i; - i = foo[0]; - exit(i != -1); -} diff --git a/config/auto-aux/searchpath b/config/auto-aux/searchpath deleted file mode 100755 index 9b31267f67..0000000000 --- a/config/auto-aux/searchpath +++ /dev/null @@ -1,9 +0,0 @@ -#!/bin/sh -# Find a program in the path - -IFS=':' -for dir in $PATH; do - if test -z "$dir"; then dir=.; fi - if test -f $dir/$1; then exit 0; fi -done -exit 1 diff --git a/config/auto-aux/sharpbang b/config/auto-aux/sharpbang deleted file mode 100755 index eb447baa6e..0000000000 --- a/config/auto-aux/sharpbang +++ /dev/null @@ -1,2 +0,0 @@ -#! /bin/cat -exit 1 diff --git a/config/auto-aux/sharpbang2 b/config/auto-aux/sharpbang2 deleted file mode 100755 index 3753096347..0000000000 --- a/config/auto-aux/sharpbang2 +++ /dev/null @@ -1,2 +0,0 @@ -#! /usr/bin/cat -exit 1 diff --git a/config/auto-aux/sighandler.c b/config/auto-aux/sighandler.c deleted file mode 100644 index 7e748df572..0000000000 --- a/config/auto-aux/sighandler.c +++ /dev/null @@ -1,23 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 1996 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 file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include - -int main(void) -{ - SIGRETURN (*old)(); - old = signal(SIGQUIT, SIG_DFL); - return 0; -} diff --git a/config/auto-aux/signals.c b/config/auto-aux/signals.c deleted file mode 100644 index df0a8b0b50..0000000000 --- a/config/auto-aux/signals.c +++ /dev/null @@ -1,68 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 1996 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 file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -/* To determine the semantics of signal handlers - (System V: signal is reset to default behavior on entrance to the handler - BSD: signal handler remains active). */ - -#include -#include - -/* Find a signal that is ignored by default */ - -#ifdef SIGCHLD -#define IGNSIG SIGCHLD -#else -#ifdef SIGIO -#define IGNSIG SIGIO -#else -#ifdef SIGCLD -#define IGNSIG SIGCLD -#else -#ifdef SIGPWR -#define IGNSIG SIGPWR -#endif -#endif -#endif -#endif - -#ifdef IGNSIG - -int counter; - -void sig_handler(int dummy) -{ - counter++; -} - -int main(int argc, char **argv) -{ - signal(IGNSIG, sig_handler); - counter = 0; - kill(getpid(), IGNSIG); - kill(getpid(), IGNSIG); - return (counter == 2 ? 0 : 1); -} - -#else - -/* If no suitable signal was found, assume System V */ - -int main(int argc, char ** argv) -{ - return 1; -} - -#endif diff --git a/config/auto-aux/sizes.c b/config/auto-aux/sizes.c deleted file mode 100644 index 992c47a658..0000000000 --- a/config/auto-aux/sizes.c +++ /dev/null @@ -1,23 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 1996 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 file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include - -int main(int argc, char **argv) -{ - printf("%d %d %d %d\n", - sizeof(int), sizeof(long), sizeof(long *), sizeof(short)); - return 0; -} diff --git a/config/auto-aux/solaris-ld b/config/auto-aux/solaris-ld deleted file mode 100644 index 3ab90bceff..0000000000 --- a/config/auto-aux/solaris-ld +++ /dev/null @@ -1,7 +0,0 @@ -#!/bin/sh -# Determine if gcc calls the Solaris ld or the GNU ld -# Exit code is 0 for Solaris ld, 1 for GNU ld - -echo "int main() { return 0; }" > hasgot.c -$cc -v -o tst hasgot.c 2>&1 | grep -s '^ld:' > /dev/null -exit $? diff --git a/config/auto-aux/stackov.c b/config/auto-aux/stackov.c deleted file mode 100644 index a1aa0b7ecf..0000000000 --- a/config/auto-aux/stackov.c +++ /dev/null @@ -1,68 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 2001 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 file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include -#include -#include - -static char sig_alt_stack[SIGSTKSZ]; -static char * system_stack_top; - -#if defined(TARGET_i386) && defined(SYS_linux_elf) -static void segv_handler(int signo, struct sigcontext sc) -{ - char * fault_addr = (char *) sc.cr2; -#else -static void segv_handler(int signo, siginfo_t * info, void * context) -{ - char * fault_addr = (char *) info->si_addr; -#endif - struct rlimit limit; - - if (getrlimit(RLIMIT_STACK, &limit) == 0 && - ((long) fault_addr & (sizeof(long) - 1)) == 0 && - fault_addr < system_stack_top && - fault_addr >= system_stack_top - limit.rlim_cur - 0x2000) { - _exit(0); - } else { - _exit(4); - } -} - -int main(int argc, char ** argv) -{ - struct sigaltstack stk; - struct sigaction act; - - stk.ss_sp = sig_alt_stack; - stk.ss_size = SIGSTKSZ; - stk.ss_flags = 0; -#if defined(TARGET_i386) && defined(SYS_linux_elf) - act.sa_handler = (void (*)(int)) segv_handler; - act.sa_flags = SA_ONSTACK | SA_NODEFER; -#else - act.sa_sigaction = segv_handler; - act.sa_flags = SA_SIGINFO | SA_ONSTACK | SA_NODEFER; -#endif - sigemptyset(&act.sa_mask); - system_stack_top = (char *) &act; - if (sigaltstack(&stk, NULL) != 0) { perror("sigaltstack"); return 2; } - if (sigaction(SIGSEGV, &act, NULL) != 0) { perror("sigaction"); return 2; } - /* We used to trigger a stack overflow at this point to test whether - the code above works, but this causes problems with POSIX threads - on some BSD systems. So, instead, we just test that all this - code compiles, indicating that the required syscalls are there. */ - return 0; -} diff --git a/config/auto-aux/tclversion.c b/config/auto-aux/tclversion.c deleted file mode 100644 index 77c0bb729e..0000000000 --- a/config/auto-aux/tclversion.c +++ /dev/null @@ -1,8 +0,0 @@ -#include -#include -#include - -main () -{ - puts(TCL_VERSION); -} diff --git a/config/auto-aux/trycompile b/config/auto-aux/trycompile deleted file mode 100755 index 797a1c3869..0000000000 --- a/config/auto-aux/trycompile +++ /dev/null @@ -1,7 +0,0 @@ -#!/bin/sh -if test "$verbose" = yes; then -echo "trycompile: $cc -o tst $* $cclibs" >&2 -$cc -o tst $* $cclibs || exit 100 -else -$cc -o tst $* $cclibs 2> /dev/null || exit 100 -fi diff --git a/config/config.Mac b/config/config.Mac deleted file mode 100644 index 51594dd25c..0000000000 --- a/config/config.Mac +++ /dev/null @@ -1,76 +0,0 @@ -######################################################################### -# # -# Objective Caml # -# # -# Damien Doligez, Projet Para, INRIA Rocquencourt # -# # -# Copyright 1999 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the GNU Library General Public License, with # -# the special exception on linking described in file ../LICENSE. # -# # -######################################################################### - -# $Id$ - -### Compile-time configuration - -########## General configuration - -### Where to install the MPW tool binaries (must be in your command path) -set -e BINDIR "{mpw}User Commands:" - -### Where to install the standard library for MPW tools -set -e LIBDIR "{mpw}User Commands:ocaml-lib:" - -### Where to install the help file -set -e HELPFILE "{mpw}OCaml.help" - -### Where to install the application and the standard library -set -e APPLIDIR "{mpw}:OCaml-distrib:" - - -############# Configuration for the contributed libraries - -### Which libraries to compile and install -# Currently available: -# bigarray Statically-allocated arrays -# dynlink Dynamic linking of bytecode -# graph Graphics (for the standalone application only) -# num Arbitrary-precision rational arithmetic -# str Regular expressions and high-level string processing -# -# You need all of them to build the standalone application. - -set -e OTHERLIBRARIES "bigarray dynlink graph num str" - - -############# To compile in debug mode (or not) - -# compile without debugging info / with optimisations -unset adbgflag ldbgflag -set -e cdbgflag "-d NDEBUG" - -# compile with debugging info / without optimisations -#set -e adbgflag "-sym on -d DEBUG -wb -l" -#set -e cdbgflag "-sym on -d DEBUG" -#set -e ldbgflag "-sym on" - - -############# Configuration for the native-code compiler -# (not used for the moment) - -set -e ARCH none -set -e MODEL ppc -set -e SYSTEM unknown -set -e NATIVECC MrC - -############# Version numbers (do not change) - -set -e OCAMLMAJOR 3 -set -e OCAMLMINOR "04" -set -e MAJOR 1 -set -e MINOR 0 -set -e BUGFIX 0 -set -e STAGE a -set -e REV 11 diff --git a/config/gnu/config.guess b/config/gnu/config.guess deleted file mode 100755 index 4a903edf44..0000000000 --- a/config/gnu/config.guess +++ /dev/null @@ -1,1366 +0,0 @@ -#! /bin/sh -# Attempt to guess a canonical system name. -# Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001 -# Free Software Foundation, Inc. - -timestamp='2003-11-23' - -# This file is free software; you can redistribute it and/or modify it -# under the terms of the GNU General Public License as published by -# the Free Software Foundation; either version 2 of the License, or -# (at your option) any later version. -# -# This program is distributed in the hope that it will be useful, but -# WITHOUT ANY WARRANTY; without even the implied warranty of -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -# General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -# -# As a special exception to the GNU General Public License, if you -# distribute this file as part of a program that contains a -# configuration script generated by Autoconf, you may include it under -# the same distribution terms that you use for the rest of that program. - -# Written by Per Bothner . -# Please send patches to . -# -# This script attempts to guess a canonical system name similar to -# config.sub. If it succeeds, it prints the system name on stdout, and -# exits with 0. Otherwise, it exits with 1. -# -# The plan is that this can be called by configure scripts if you -# don't specify an explicit build system type. - -me=`echo "$0" | sed -e 's,.*/,,'` - -usage="\ -Usage: $0 [OPTION] - -Output the configuration name of the system \`$me' is run on. - -Operation modes: - -h, --help print this help, then exit - -t, --time-stamp print date of last modification, then exit - -v, --version print version number, then exit - -Report bugs and patches to ." - -version="\ -GNU config.guess ($timestamp) - -Originally written by Per Bothner. -Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001 -Free Software Foundation, Inc. - -This is free software; see the source for copying conditions. There is NO -warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE." - -help=" -Try \`$me --help' for more information." - -# Parse command line -while test $# -gt 0 ; do - case $1 in - --time-stamp | --time* | -t ) - echo "$timestamp" ; exit 0 ;; - --version | -v ) - echo "$version" ; exit 0 ;; - --help | --h* | -h ) - echo "$usage"; exit 0 ;; - -- ) # Stop option processing - shift; break ;; - - ) # Use stdin as input. - break ;; - -* ) - echo "$me: invalid option $1$help" >&2 - exit 1 ;; - * ) - break ;; - esac -done - -if test $# != 0; then - echo "$me: too many arguments$help" >&2 - exit 1 -fi - - -dummy=dummy-$$ -trap 'rm -f $dummy.c $dummy.o $dummy.rel $dummy; exit 1' 1 2 15 - -# CC_FOR_BUILD -- compiler used by this script. -# Historically, `CC_FOR_BUILD' used to be named `HOST_CC'. We still -# use `HOST_CC' if defined, but it is deprecated. - -case $CC_FOR_BUILD,$HOST_CC,$CC in - ,,) echo "int dummy(){}" > $dummy.c - for c in cc gcc c89 ; do - ($c $dummy.c -c -o $dummy.o) >/dev/null 2>&1 - if test $? = 0 ; then - CC_FOR_BUILD="$c"; break - fi - done - rm -f $dummy.c $dummy.o $dummy.rel - if test x"$CC_FOR_BUILD" = x ; then - CC_FOR_BUILD=no_compiler_found - fi - ;; - ,,*) CC_FOR_BUILD=$CC ;; - ,*,*) CC_FOR_BUILD=$HOST_CC ;; -esac - -# This is needed to find uname on a Pyramid OSx when run in the BSD universe. -# (ghazi@noc.rutgers.edu 8/24/94.) -if (test -f /.attbin/uname) >/dev/null 2>&1 ; then - PATH=$PATH:/.attbin ; export PATH -fi - -UNAME_MACHINE=`(uname -m) 2>/dev/null` || UNAME_MACHINE=unknown -UNAME_RELEASE=`(uname -r) 2>/dev/null` || UNAME_RELEASE=unknown -UNAME_SYSTEM=`(uname -s) 2>/dev/null` || UNAME_SYSTEM=unknown -UNAME_VERSION=`(uname -v) 2>/dev/null` || UNAME_VERSION=unknown - -# Note: order is significant - the case branches are not exclusive. - -case "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" in - *:NetBSD:*:*) - # Netbsd (nbsd) targets should (where applicable) match one or - # more of the tupples: *-*-netbsdelf*, *-*-netbsdaout*, - # *-*-netbsdecoff* and *-*-netbsd*. For targets that recently - # switched to ELF, *-*-netbsd* would select the old - # object file format. This provides both forward - # compatibility and a consistent mechanism for selecting the - # object file format. - # Determine the machine/vendor (is the vendor relevant). - case "${UNAME_MACHINE}" in - amiga) machine=m68k-unknown ;; - arm32) machine=arm-unknown ;; - atari*) machine=m68k-atari ;; - sun3*) machine=m68k-sun ;; - mac68k) machine=m68k-apple ;; - macppc) machine=powerpc-apple ;; - hp3[0-9][05]) machine=m68k-hp ;; - ibmrt|romp-ibm) machine=romp-ibm ;; - *) machine=${UNAME_MACHINE}-unknown ;; - esac - # The Operating System including object format, if it has switched - # to ELF recently, or will in the future. - case "${UNAME_MACHINE}" in - i386|sparc|amiga|arm*|hp300|mvme68k|vax|atari|luna68k|mac68k|news68k|next68k|pc532|sun3*|x68k) - if echo __ELF__ | $CC_FOR_BUILD -E - 2>/dev/null \ - | grep __ELF__ >/dev/null - then - # Once all utilities can be ECOFF (netbsdecoff) or a.out (netbsdaout). - # Return netbsd for either. FIX? - os=netbsd - else - os=netbsdelf - fi - ;; - *) - os=netbsd - ;; - esac - # The OS release - release=`echo ${UNAME_RELEASE}|sed -e 's/[-_].*/\./'` - # Since CPU_TYPE-MANUFACTURER-KERNEL-OPERATING_SYSTEM: - # contains redundant information, the shorter form: - # CPU_TYPE-MANUFACTURER-OPERATING_SYSTEM is used. - echo "${machine}-${os}${release}" - exit 0 ;; - alpha:OSF1:*:*) - if test $UNAME_RELEASE = "V4.0"; then - UNAME_RELEASE=`/usr/sbin/sizer -v | awk '{print $3}'` - fi - # A Vn.n version is a released version. - # A Tn.n version is a released field test version. - # A Xn.n version is an unreleased experimental baselevel. - # 1.2 uses "1.2" for uname -r. - cat <$dummy.s - .data -\$Lformat: - .byte 37,100,45,37,120,10,0 # "%d-%x\n" - - .text - .globl main - .align 4 - .ent main -main: - .frame \$30,16,\$26,0 - ldgp \$29,0(\$27) - .prologue 1 - .long 0x47e03d80 # implver \$0 - lda \$2,-1 - .long 0x47e20c21 # amask \$2,\$1 - lda \$16,\$Lformat - mov \$0,\$17 - not \$1,\$18 - jsr \$26,printf - ldgp \$29,0(\$26) - mov 0,\$16 - jsr \$26,exit - .end main -EOF - $CC_FOR_BUILD $dummy.s -o $dummy 2>/dev/null - if test "$?" = 0 ; then - case `./$dummy` in - 0-0) - UNAME_MACHINE="alpha" - ;; - 1-0) - UNAME_MACHINE="alphaev5" - ;; - 1-1) - UNAME_MACHINE="alphaev56" - ;; - 1-101) - UNAME_MACHINE="alphapca56" - ;; - 2-303) - UNAME_MACHINE="alphaev6" - ;; - 2-307) - UNAME_MACHINE="alphaev67" - ;; - esac - fi - rm -f $dummy.s $dummy - echo ${UNAME_MACHINE}-dec-osf`echo ${UNAME_RELEASE} | sed -e 's/^[VTX]//' | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz'` - exit 0 ;; - Alpha\ *:Windows_NT*:*) - # How do we know it's Interix rather than the generic POSIX subsystem? - # Should we change UNAME_MACHINE based on the output of uname instead - # of the specific Alpha model? - echo alpha-pc-interix - exit 0 ;; - 21064:Windows_NT:50:3) - echo alpha-dec-winnt3.5 - exit 0 ;; - Amiga*:UNIX_System_V:4.0:*) - echo m68k-unknown-sysv4 - exit 0;; - amiga:OpenBSD:*:*) - echo m68k-unknown-openbsd${UNAME_RELEASE} - exit 0 ;; - *:[Aa]miga[Oo][Ss]:*:*) - echo ${UNAME_MACHINE}-unknown-amigaos - exit 0 ;; - arc64:OpenBSD:*:*) - echo mips64el-unknown-openbsd${UNAME_RELEASE} - exit 0 ;; - arc:OpenBSD:*:*) - echo mipsel-unknown-openbsd${UNAME_RELEASE} - exit 0 ;; - hkmips:OpenBSD:*:*) - echo mips-unknown-openbsd${UNAME_RELEASE} - exit 0 ;; - pmax:OpenBSD:*:*) - echo mipsel-unknown-openbsd${UNAME_RELEASE} - exit 0 ;; - sgi:OpenBSD:*:*) - echo mips-unknown-openbsd${UNAME_RELEASE} - exit 0 ;; - wgrisc:OpenBSD:*:*) - echo mipsel-unknown-openbsd${UNAME_RELEASE} - exit 0 ;; - *:OS/390:*:*) - echo i370-ibm-openedition - exit 0 ;; - arm:RISC*:1.[012]*:*|arm:riscix:1.[012]*:*) - echo arm-acorn-riscix${UNAME_RELEASE} - exit 0;; - SR2?01:HI-UX/MPP:*:* | SR8000:HI-UX/MPP:*:*) - echo hppa1.1-hitachi-hiuxmpp - exit 0;; - Pyramid*:OSx*:*:* | MIS*:OSx*:*:* | MIS*:SMP_DC-OSx*:*:*) - # akee@wpdis03.wpafb.af.mil (Earle F. Ake) contributed MIS and NILE. - if test "`(/bin/universe) 2>/dev/null`" = att ; then - echo pyramid-pyramid-sysv3 - else - echo pyramid-pyramid-bsd - fi - exit 0 ;; - NILE*:*:*:dcosx) - echo pyramid-pyramid-svr4 - exit 0 ;; - sun4H:SunOS:5.*:*) - echo sparc-hal-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` - exit 0 ;; - sun4*:SunOS:5.*:* | tadpole*:SunOS:5.*:*) - echo sparc-sun-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` - exit 0 ;; - i86pc:SunOS:5.*:*) - echo i386-pc-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` - exit 0 ;; - sun4*:SunOS:6*:*) - # According to config.sub, this is the proper way to canonicalize - # SunOS6. Hard to guess exactly what SunOS6 will be like, but - # it's likely to be more like Solaris than SunOS4. - echo sparc-sun-solaris3`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` - exit 0 ;; - sun4*:SunOS:*:*) - case "`/usr/bin/arch -k`" in - Series*|S4*) - UNAME_RELEASE=`uname -v` - ;; - esac - # Japanese Language versions have a version number like `4.1.3-JL'. - echo sparc-sun-sunos`echo ${UNAME_RELEASE}|sed -e 's/-/_/'` - exit 0 ;; - sun3*:SunOS:*:*) - echo m68k-sun-sunos${UNAME_RELEASE} - exit 0 ;; - sun*:*:4.2BSD:*) - UNAME_RELEASE=`(cat /etc/motd | awk 'NR == 1 {print substr($5,1,3)}') 2>/dev/null` - test "x${UNAME_RELEASE}" = "x" && UNAME_RELEASE=3 - case "`/bin/arch`" in - sun3) - echo m68k-sun-sunos${UNAME_RELEASE} - ;; - sun4) - echo sparc-sun-sunos${UNAME_RELEASE} - ;; - esac - exit 0 ;; - aushp:SunOS:*:*) - echo sparc-auspex-sunos${UNAME_RELEASE} - exit 0 ;; - atari*:OpenBSD:*:*) - echo m68k-unknown-openbsd${UNAME_RELEASE} - exit 0 ;; - # The situation for MiNT is a little confusing. The machine name - # can be virtually everything (everything which is not - # "atarist" or "atariste" at least should have a processor - # > m68000). The system name ranges from "MiNT" over "FreeMiNT" - # to the lowercase version "mint" (or "freemint"). Finally - # the system name "TOS" denotes a system which is actually not - # MiNT. But MiNT is downward compatible to TOS, so this should - # be no problem. - atarist[e]:*MiNT:*:* | atarist[e]:*mint:*:* | atarist[e]:*TOS:*:*) - echo m68k-atari-mint${UNAME_RELEASE} - exit 0 ;; - atari*:*MiNT:*:* | atari*:*mint:*:* | atarist[e]:*TOS:*:*) - echo m68k-atari-mint${UNAME_RELEASE} - exit 0 ;; - *falcon*:*MiNT:*:* | *falcon*:*mint:*:* | *falcon*:*TOS:*:*) - echo m68k-atari-mint${UNAME_RELEASE} - exit 0 ;; - milan*:*MiNT:*:* | milan*:*mint:*:* | *milan*:*TOS:*:*) - echo m68k-milan-mint${UNAME_RELEASE} - exit 0 ;; - hades*:*MiNT:*:* | hades*:*mint:*:* | *hades*:*TOS:*:*) - echo m68k-hades-mint${UNAME_RELEASE} - exit 0 ;; - *:*MiNT:*:* | *:*mint:*:* | *:*TOS:*:*) - echo m68k-unknown-mint${UNAME_RELEASE} - exit 0 ;; - sun3*:OpenBSD:*:*) - echo m68k-unknown-openbsd${UNAME_RELEASE} - exit 0 ;; - mac68k:OpenBSD:*:*) - echo m68k-unknown-openbsd${UNAME_RELEASE} - exit 0 ;; - mvme68k:OpenBSD:*:*) - echo m68k-unknown-openbsd${UNAME_RELEASE} - exit 0 ;; - mvme88k:OpenBSD:*:*) - echo m88k-unknown-openbsd${UNAME_RELEASE} - exit 0 ;; - powerpc:machten:*:*) - echo powerpc-apple-machten${UNAME_RELEASE} - exit 0 ;; - RISC*:Mach:*:*) - echo mips-dec-mach_bsd4.3 - exit 0 ;; - RISC*:ULTRIX:*:*) - echo mips-dec-ultrix${UNAME_RELEASE} - exit 0 ;; - VAX*:ULTRIX*:*:*) - echo vax-dec-ultrix${UNAME_RELEASE} - exit 0 ;; - 2020:CLIX:*:* | 2430:CLIX:*:*) - echo clipper-intergraph-clix${UNAME_RELEASE} - exit 0 ;; - mips:*:*:UMIPS | mips:*:*:RISCos) - sed 's/^ //' << EOF >$dummy.c -#ifdef __cplusplus -#include /* for printf() prototype */ - int main (int argc, char *argv[]) { -#else - int main (argc, argv) int argc; char *argv[]; { -#endif - #if defined (host_mips) && defined (MIPSEB) - #if defined (SYSTYPE_SYSV) - printf ("mips-mips-riscos%ssysv\n", argv[1]); exit (0); - #endif - #if defined (SYSTYPE_SVR4) - printf ("mips-mips-riscos%ssvr4\n", argv[1]); exit (0); - #endif - #if defined (SYSTYPE_BSD43) || defined(SYSTYPE_BSD) - printf ("mips-mips-riscos%sbsd\n", argv[1]); exit (0); - #endif - #endif - exit (-1); - } -EOF - $CC_FOR_BUILD $dummy.c -o $dummy \ - && ./$dummy `echo "${UNAME_RELEASE}" | sed -n 's/\([0-9]*\).*/\1/p'` \ - && rm -f $dummy.c $dummy && exit 0 - rm -f $dummy.c $dummy - echo mips-mips-riscos${UNAME_RELEASE} - exit 0 ;; - Motorola:PowerMAX_OS:*:*) - echo powerpc-motorola-powermax - exit 0 ;; - Night_Hawk:Power_UNIX:*:*) - echo powerpc-harris-powerunix - exit 0 ;; - m88k:CX/UX:7*:*) - echo m88k-harris-cxux7 - exit 0 ;; - m88k:*:4*:R4*) - echo m88k-motorola-sysv4 - exit 0 ;; - m88k:*:3*:R3*) - echo m88k-motorola-sysv3 - exit 0 ;; - AViiON:dgux:*:*) - # DG/UX returns AViiON for all architectures - UNAME_PROCESSOR=`/usr/bin/uname -p` - if [ $UNAME_PROCESSOR = mc88100 ] || [ $UNAME_PROCESSOR = mc88110 ] - then - if [ ${TARGET_BINARY_INTERFACE}x = m88kdguxelfx ] || \ - [ ${TARGET_BINARY_INTERFACE}x = x ] - then - echo m88k-dg-dgux${UNAME_RELEASE} - else - echo m88k-dg-dguxbcs${UNAME_RELEASE} - fi - else - echo i586-dg-dgux${UNAME_RELEASE} - fi - exit 0 ;; - M88*:DolphinOS:*:*) # DolphinOS (SVR3) - echo m88k-dolphin-sysv3 - exit 0 ;; - M88*:*:R3*:*) - # Delta 88k system running SVR3 - echo m88k-motorola-sysv3 - exit 0 ;; - XD88*:*:*:*) # Tektronix XD88 system running UTekV (SVR3) - echo m88k-tektronix-sysv3 - exit 0 ;; - Tek43[0-9][0-9]:UTek:*:*) # Tektronix 4300 system running UTek (BSD) - echo m68k-tektronix-bsd - exit 0 ;; - *:IRIX*:*:*) - echo mips-sgi-irix`echo ${UNAME_RELEASE}|sed -e 's/-/_/g'` - exit 0 ;; - ????????:AIX?:[12].1:2) # AIX 2.2.1 or AIX 2.1.1 is RT/PC AIX. - echo romp-ibm-aix # uname -m gives an 8 hex-code CPU id - exit 0 ;; # Note that: echo "'`uname -s`'" gives 'AIX ' - i*86:AIX:*:*) - echo i386-ibm-aix - exit 0 ;; - ia64:AIX:*:*) - if [ -x /usr/bin/oslevel ] ; then - IBM_REV=`/usr/bin/oslevel` - else - IBM_REV=${UNAME_VERSION}.${UNAME_RELEASE} - fi - echo ${UNAME_MACHINE}-ibm-aix${IBM_REV} - exit 0 ;; - *:AIX:2:3) - if grep bos325 /usr/include/stdio.h >/dev/null 2>&1; then - sed 's/^ //' << EOF >$dummy.c - #include - - main() - { - if (!__power_pc()) - exit(1); - puts("powerpc-ibm-aix3.2.5"); - exit(0); - } -EOF - $CC_FOR_BUILD $dummy.c -o $dummy && ./$dummy && rm -f $dummy.c $dummy && exit 0 - rm -f $dummy.c $dummy - echo rs6000-ibm-aix3.2.5 - elif grep bos324 /usr/include/stdio.h >/dev/null 2>&1; then - echo rs6000-ibm-aix3.2.4 - else - echo rs6000-ibm-aix3.2 - fi - exit 0 ;; - *:AIX:*:[45]) - IBM_CPU_ID=`/usr/sbin/lsdev -C -c processor -S available | awk 'NR == 1 { print $1 }'` - if /usr/sbin/lsattr -El ${IBM_CPU_ID} | grep ' POWER' >/dev/null 2>&1; then - IBM_ARCH=rs6000 - else - IBM_ARCH=powerpc - fi - if [ -x /usr/bin/oslevel ] ; then - IBM_REV=`/usr/bin/oslevel` - else - IBM_REV=${UNAME_VERSION}.${UNAME_RELEASE} - fi - echo ${IBM_ARCH}-ibm-aix${IBM_REV} - exit 0 ;; - *:AIX:*:*) - echo rs6000-ibm-aix - exit 0 ;; - ibmrt:4.4BSD:*|romp-ibm:BSD:*) - echo romp-ibm-bsd4.4 - exit 0 ;; - ibmrt:*BSD:*|romp-ibm:BSD:*) # covers RT/PC BSD and - echo romp-ibm-bsd${UNAME_RELEASE} # 4.3 with uname added to - exit 0 ;; # report: romp-ibm BSD 4.3 - *:BOSX:*:*) - echo rs6000-bull-bosx - exit 0 ;; - DPX/2?00:B.O.S.:*:*) - echo m68k-bull-sysv3 - exit 0 ;; - 9000/[34]??:4.3bsd:1.*:*) - echo m68k-hp-bsd - exit 0 ;; - hp300:4.4BSD:*:* | 9000/[34]??:4.3bsd:2.*:*) - echo m68k-hp-bsd4.4 - exit 0 ;; - 9000/[34678]??:HP-UX:*:*) - HPUX_REV=`echo ${UNAME_RELEASE}|sed -e 's/[^.]*.[0B]*//'` - case "${UNAME_MACHINE}" in - 9000/31? ) HP_ARCH=m68000 ;; - 9000/[34]?? ) HP_ARCH=m68k ;; - 9000/[678][0-9][0-9]) - case "${HPUX_REV}" in - 11.[0-9][0-9]) - if [ -x /usr/bin/getconf ]; then - sc_cpu_version=`/usr/bin/getconf SC_CPU_VERSION 2>/dev/null` - sc_kernel_bits=`/usr/bin/getconf SC_KERNEL_BITS 2>/dev/null` - case "${sc_cpu_version}" in - 523) HP_ARCH="hppa1.0" ;; # CPU_PA_RISC1_0 - 528) HP_ARCH="hppa1.1" ;; # CPU_PA_RISC1_1 - 532) # CPU_PA_RISC2_0 - case "${sc_kernel_bits}" in - 32) HP_ARCH="hppa2.0n" ;; - 64) HP_ARCH="hppa2.0w" ;; - esac ;; - esac - fi ;; - esac - if [ "${HP_ARCH}" = "" ]; then - sed 's/^ //' << EOF >$dummy.c - - #define _HPUX_SOURCE - #include - #include - - int main () - { - #if defined(_SC_KERNEL_BITS) - long bits = sysconf(_SC_KERNEL_BITS); - #endif - long cpu = sysconf (_SC_CPU_VERSION); - - switch (cpu) - { - case CPU_PA_RISC1_0: puts ("hppa1.0"); break; - case CPU_PA_RISC1_1: puts ("hppa1.1"); break; - case CPU_PA_RISC2_0: - #if defined(_SC_KERNEL_BITS) - switch (bits) - { - case 64: puts ("hppa2.0w"); break; - case 32: puts ("hppa2.0n"); break; - default: puts ("hppa2.0"); break; - } break; - #else /* !defined(_SC_KERNEL_BITS) */ - puts ("hppa2.0"); break; - #endif - default: puts ("hppa1.0"); break; - } - exit (0); - } -EOF - (CCOPTS= $CC_FOR_BUILD $dummy.c -o $dummy 2>/dev/null ) && HP_ARCH=`./$dummy` - if test -z "$HP_ARCH"; then HP_ARCH=hppa; fi - rm -f $dummy.c $dummy - fi ;; - esac - echo ${HP_ARCH}-hp-hpux${HPUX_REV} - exit 0 ;; - ia64:HP-UX:*:*) - HPUX_REV=`echo ${UNAME_RELEASE}|sed -e 's/[^.]*.[0B]*//'` - echo ia64-hp-hpux${HPUX_REV} - exit 0 ;; - 3050*:HI-UX:*:*) - sed 's/^ //' << EOF >$dummy.c - #include - int - main () - { - long cpu = sysconf (_SC_CPU_VERSION); - /* The order matters, because CPU_IS_HP_MC68K erroneously returns - true for CPU_PA_RISC1_0. CPU_IS_PA_RISC returns correct - results, however. */ - if (CPU_IS_PA_RISC (cpu)) - { - switch (cpu) - { - case CPU_PA_RISC1_0: puts ("hppa1.0-hitachi-hiuxwe2"); break; - case CPU_PA_RISC1_1: puts ("hppa1.1-hitachi-hiuxwe2"); break; - case CPU_PA_RISC2_0: puts ("hppa2.0-hitachi-hiuxwe2"); break; - default: puts ("hppa-hitachi-hiuxwe2"); break; - } - } - else if (CPU_IS_HP_MC68K (cpu)) - puts ("m68k-hitachi-hiuxwe2"); - else puts ("unknown-hitachi-hiuxwe2"); - exit (0); - } -EOF - $CC_FOR_BUILD $dummy.c -o $dummy && ./$dummy && rm -f $dummy.c $dummy && exit 0 - rm -f $dummy.c $dummy - echo unknown-hitachi-hiuxwe2 - exit 0 ;; - 9000/7??:4.3bsd:*:* | 9000/8?[79]:4.3bsd:*:* ) - echo hppa1.1-hp-bsd - exit 0 ;; - 9000/8??:4.3bsd:*:*) - echo hppa1.0-hp-bsd - exit 0 ;; - *9??*:MPE/iX:*:*) - echo hppa1.0-hp-mpeix - exit 0 ;; - hp7??:OSF1:*:* | hp8?[79]:OSF1:*:* ) - echo hppa1.1-hp-osf - exit 0 ;; - hp8??:OSF1:*:*) - echo hppa1.0-hp-osf - exit 0 ;; - i*86:OSF1:*:*) - if [ -x /usr/sbin/sysversion ] ; then - echo ${UNAME_MACHINE}-unknown-osf1mk - else - echo ${UNAME_MACHINE}-unknown-osf1 - fi - exit 0 ;; - parisc*:Lites*:*:*) - echo hppa1.1-hp-lites - exit 0 ;; - hppa*:OpenBSD:*:*) - echo hppa-unknown-openbsd - exit 0 ;; - C1*:ConvexOS:*:* | convex:ConvexOS:C1*:*) - echo c1-convex-bsd - exit 0 ;; - C2*:ConvexOS:*:* | convex:ConvexOS:C2*:*) - if getsysinfo -f scalar_acc - then echo c32-convex-bsd - else echo c2-convex-bsd - fi - exit 0 ;; - C34*:ConvexOS:*:* | convex:ConvexOS:C34*:*) - echo c34-convex-bsd - exit 0 ;; - C38*:ConvexOS:*:* | convex:ConvexOS:C38*:*) - echo c38-convex-bsd - exit 0 ;; - C4*:ConvexOS:*:* | convex:ConvexOS:C4*:*) - echo c4-convex-bsd - exit 0 ;; - CRAY*X-MP:*:*:*) - echo xmp-cray-unicos - exit 0 ;; - CRAY*Y-MP:*:*:*) - echo ymp-cray-unicos${UNAME_RELEASE} - exit 0 ;; - CRAY*[A-Z]90:*:*:*) - echo ${UNAME_MACHINE}-cray-unicos${UNAME_RELEASE} \ - | sed -e 's/CRAY.*\([A-Z]90\)/\1/' \ - -e y/ABCDEFGHIJKLMNOPQRSTUVWXYZ/abcdefghijklmnopqrstuvwxyz/ - exit 0 ;; - CRAY*TS:*:*:*) - echo t90-cray-unicos${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' - exit 0 ;; - CRAY*T3D:*:*:*) - echo alpha-cray-unicosmk${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' - exit 0 ;; - CRAY*T3E:*:*:*) - echo alphaev5-cray-unicosmk${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' - exit 0 ;; - CRAY*SV1:*:*:*) - echo sv1-cray-unicos${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' - exit 0 ;; - CRAY-2:*:*:*) - echo cray2-cray-unicos - exit 0 ;; - F30[01]:UNIX_System_V:*:* | F700:UNIX_System_V:*:*) - FUJITSU_PROC=`uname -m | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz'` - FUJITSU_SYS=`uname -p | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz' | sed -e 's/\///'` - FUJITSU_REL=`echo ${UNAME_RELEASE} | sed -e 's/ /_/'` - echo "${FUJITSU_PROC}-fujitsu-${FUJITSU_SYS}${FUJITSU_REL}" - exit 0 ;; - hp300:OpenBSD:*:*) - echo m68k-unknown-openbsd${UNAME_RELEASE} - exit 0 ;; - i*86:BSD/386:*:* | i*86:BSD/OS:*:* | *:Ascend\ Embedded/OS:*:*) - echo ${UNAME_MACHINE}-pc-bsdi${UNAME_RELEASE} - exit 0 ;; - sparc*:BSD/OS:*:*) - echo sparc-unknown-bsdi${UNAME_RELEASE} - exit 0 ;; - *:BSD/OS:*:*) - echo ${UNAME_MACHINE}-unknown-bsdi${UNAME_RELEASE} - exit 0 ;; - *:FreeBSD:*:*) - echo ${UNAME_MACHINE}-unknown-freebsd`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` - exit 0 ;; - *:OpenBSD:*:*) - echo ${UNAME_MACHINE}-unknown-openbsd`echo ${UNAME_RELEASE}|sed -e 's/[-_].*/\./'` - exit 0 ;; - i*:CYGWIN*:*) - echo ${UNAME_MACHINE}-pc-cygwin - exit 0 ;; - i*:MINGW*:*) - echo ${UNAME_MACHINE}-pc-mingw32 - exit 0 ;; - i*:PW*:*) - echo ${UNAME_MACHINE}-pc-pw32 - exit 0 ;; - i*:Windows_NT*:* | Pentium*:Windows_NT*:*) - # How do we know it's Interix rather than the generic POSIX subsystem? - # It also conflicts with pre-2.0 versions of AT&T UWIN. Should we - # UNAME_MACHINE based on the output of uname instead of i386? - echo i386-pc-interix - exit 0 ;; - i*:UWIN*:*) - echo ${UNAME_MACHINE}-pc-uwin - exit 0 ;; - p*:CYGWIN*:*) - echo powerpcle-unknown-cygwin - exit 0 ;; - prep*:SunOS:5.*:*) - echo powerpcle-unknown-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` - exit 0 ;; - *:GNU:*:*) - echo `echo ${UNAME_MACHINE}|sed -e 's,[-/].*$,,'`-unknown-gnu`echo ${UNAME_RELEASE}|sed -e 's,/.*$,,'` - exit 0 ;; - i*86:Minix:*:*) - echo ${UNAME_MACHINE}-pc-minix - exit 0 ;; - arm*:Linux:*:*) - echo ${UNAME_MACHINE}-unknown-linux-gnu - exit 0 ;; - sa110:Linux:*:*) - echo arm-unknown-linux-gnu - exit 0 ;; - ia64:Linux:*:*) - echo ${UNAME_MACHINE}-unknown-linux - exit 0 ;; - m68*:Linux:*:*) - echo ${UNAME_MACHINE}-unknown-linux-gnu - exit 0 ;; - mips:Linux:*:*) - cat >$dummy.c < /* for printf() prototype */ -int main (int argc, char *argv[]) { -#else -int main (argc, argv) int argc; char *argv[]; { -#endif -#ifdef __MIPSEB__ - printf ("%s-unknown-linux-gnu\n", argv[1]); -#endif -#ifdef __MIPSEL__ - printf ("%sel-unknown-linux-gnu\n", argv[1]); -#endif - return 0; -} -EOF - $CC_FOR_BUILD $dummy.c -o $dummy 2>/dev/null && ./$dummy "${UNAME_MACHINE}" && rm -f $dummy.c $dummy && exit 0 - rm -f $dummy.c $dummy - ;; - ppc:Linux:*:*) - # Determine Lib Version - cat >$dummy.c < -#if defined(__GLIBC__) -extern char __libc_version[]; -extern char __libc_release[]; -#endif -main(argc, argv) - int argc; - char *argv[]; -{ -#if defined(__GLIBC__) - printf("%s %s\n", __libc_version, __libc_release); -#else - printf("unknown\n"); -#endif - return 0; -} -EOF - LIBC="" - $CC_FOR_BUILD $dummy.c -o $dummy 2>/dev/null - if test "$?" = 0 ; then - ./$dummy | grep 1\.99 > /dev/null - if test "$?" = 0 ; then LIBC="libc1" ; fi - fi - rm -f $dummy.c $dummy - echo powerpc-unknown-linux-gnu${LIBC} - exit 0 ;; - alpha:Linux:*:*) - cat <$dummy.s - .data - \$Lformat: - .byte 37,100,45,37,120,10,0 # "%d-%x\n" - .text - .globl main - .align 4 - .ent main - main: - .frame \$30,16,\$26,0 - ldgp \$29,0(\$27) - .prologue 1 - .long 0x47e03d80 # implver \$0 - lda \$2,-1 - .long 0x47e20c21 # amask \$2,\$1 - lda \$16,\$Lformat - mov \$0,\$17 - not \$1,\$18 - jsr \$26,printf - ldgp \$29,0(\$26) - mov 0,\$16 - jsr \$26,exit - .end main -EOF - LIBC="" - $CC_FOR_BUILD $dummy.s -o $dummy 2>/dev/null - if test "$?" = 0 ; then - case `./$dummy` in - 0-0) UNAME_MACHINE="alpha" ;; - 1-0) UNAME_MACHINE="alphaev5" ;; - 1-1) UNAME_MACHINE="alphaev56" ;; - 1-101) UNAME_MACHINE="alphapca56" ;; - 2-303) UNAME_MACHINE="alphaev6" ;; - 2-307) UNAME_MACHINE="alphaev67" ;; - esac - objdump --private-headers $dummy | \ - grep ld.so.1 > /dev/null - if test "$?" = 0 ; then - LIBC="libc1" - fi - fi - rm -f $dummy.s $dummy - echo ${UNAME_MACHINE}-unknown-linux-gnu${LIBC} - exit 0 ;; - parisc:Linux:*:* | hppa:Linux:*:*) - # Look for CPU level - case `grep '^cpu[^a-z]*:' /proc/cpuinfo 2>/dev/null | cut -d' ' -f2` in - PA7*) echo hppa1.1-unknown-linux-gnu ;; - PA8*) echo hppa2.0-unknown-linux-gnu ;; - *) echo hppa-unknown-linux-gnu ;; - esac - exit 0 ;; - parisc64:Linux:*:* | hppa64:Linux:*:*) - echo hppa64-unknown-linux-gnu - exit 0 ;; - s390:Linux:*:* | s390x:Linux:*:*) - echo ${UNAME_MACHINE}-ibm-linux - exit 0 ;; - sh*:Linux:*:*) - echo ${UNAME_MACHINE}-unknown-linux-gnu - exit 0 ;; - sparc:Linux:*:* | sparc64:Linux:*:*) - echo ${UNAME_MACHINE}-unknown-linux-gnu - exit 0 ;; - x86_64:Linux:*:*) - echo x86_64-unknown-linux-gnu - exit 0 ;; - i*86:Linux:*:*) - # The BFD linker knows what the default object file format is, so - # first see if it will tell us. cd to the root directory to prevent - # problems with other programs or directories called `ld' in the path. - ld_supported_targets=`cd /; ld --help 2>&1 \ - | sed -ne '/supported targets:/!d - s/[ ][ ]*/ /g - s/.*supported targets: *// - s/ .*// - p'` - case "$ld_supported_targets" in - elf32-i386) - TENTATIVE="${UNAME_MACHINE}-pc-linux-gnu" - ;; - a.out-i386-linux) - echo "${UNAME_MACHINE}-pc-linux-gnuaout" - exit 0 ;; - coff-i386) - echo "${UNAME_MACHINE}-pc-linux-gnucoff" - exit 0 ;; - "") - # Either a pre-BFD a.out linker (linux-gnuoldld) or - # one that does not give us useful --help. - echo "${UNAME_MACHINE}-pc-linux-gnuoldld" - exit 0 ;; - esac - # Determine whether the default compiler is a.out or elf - cat >$dummy.c < -#ifdef __cplusplus -#include /* for printf() prototype */ - int main (int argc, char *argv[]) { -#else - int main (argc, argv) int argc; char *argv[]; { -#endif -#ifdef __ELF__ -# ifdef __GLIBC__ -# if __GLIBC__ >= 2 - printf ("%s-pc-linux-gnu\n", argv[1]); -# else - printf ("%s-pc-linux-gnulibc1\n", argv[1]); -# endif -# else - printf ("%s-pc-linux-gnulibc1\n", argv[1]); -# endif -#else - printf ("%s-pc-linux-gnuaout\n", argv[1]); -#endif - return 0; -} -EOF - $CC_FOR_BUILD $dummy.c -o $dummy 2>/dev/null && ./$dummy "${UNAME_MACHINE}" && rm -f $dummy.c $dummy && exit 0 - rm -f $dummy.c $dummy - test x"${TENTATIVE}" != x && echo "${TENTATIVE}" && exit 0 - ;; -# ptx 4.0 does uname -s correctly, with DYNIX/ptx in there. earlier versions -# are messed up and put the nodename in both sysname and nodename. - i*86:DYNIX/ptx:4*:*) - echo i386-sequent-sysv4 - exit 0 ;; - i*86:UNIX_SV:4.2MP:2.*) - # Unixware is an offshoot of SVR4, but it has its own version - # number series starting with 2... - # I am not positive that other SVR4 systems won't match this, - # I just have to hope. -- rms. - # Use sysv4.2uw... so that sysv4* matches it. - echo ${UNAME_MACHINE}-pc-sysv4.2uw${UNAME_VERSION} - exit 0 ;; - i*86:*:4.*:* | i*86:SYSTEM_V:4.*:*) - UNAME_REL=`echo ${UNAME_RELEASE} | sed 's/\/MP$//'` - if grep Novell /usr/include/link.h >/dev/null 2>/dev/null; then - echo ${UNAME_MACHINE}-univel-sysv${UNAME_REL} - else - echo ${UNAME_MACHINE}-pc-sysv${UNAME_REL} - fi - exit 0 ;; - i*86:*:5:[78]*) - case `/bin/uname -X | grep "^Machine"` in - *486*) UNAME_MACHINE=i486 ;; - *Pentium*) UNAME_MACHINE=i586 ;; - *Pent*|*Celeron) UNAME_MACHINE=i686 ;; - esac - echo ${UNAME_MACHINE}-unknown-sysv${UNAME_RELEASE}${UNAME_SYSTEM}${UNAME_VERSION} - exit 0 ;; - i*86:*:3.2:*) - if test -f /usr/options/cb.name; then - UNAME_REL=`sed -n 's/.*Version //p' /dev/null >/dev/null ; then - UNAME_REL=`(/bin/uname -X|egrep Release|sed -e 's/.*= //')` - (/bin/uname -X|egrep i80486 >/dev/null) && UNAME_MACHINE=i486 - (/bin/uname -X|egrep '^Machine.*Pentium' >/dev/null) \ - && UNAME_MACHINE=i586 - (/bin/uname -X|egrep '^Machine.*Pent ?II' >/dev/null) \ - && UNAME_MACHINE=i686 - (/bin/uname -X|egrep '^Machine.*Pentium Pro' >/dev/null) \ - && UNAME_MACHINE=i686 - echo ${UNAME_MACHINE}-pc-sco$UNAME_REL - else - echo ${UNAME_MACHINE}-pc-sysv32 - fi - exit 0 ;; - i*86:*DOS:*:*) - echo ${UNAME_MACHINE}-pc-msdosdjgpp - exit 0 ;; - pc:*:*:*) - # Left here for compatibility: - # uname -m prints for DJGPP always 'pc', but it prints nothing about - # the processor, so we play safe by assuming i386. - echo i386-pc-msdosdjgpp - exit 0 ;; - Intel:Mach:3*:*) - echo i386-pc-mach3 - exit 0 ;; - paragon:*:*:*) - echo i860-intel-osf1 - exit 0 ;; - i860:*:4.*:*) # i860-SVR4 - if grep Stardent /usr/include/sys/uadmin.h >/dev/null 2>&1 ; then - echo i860-stardent-sysv${UNAME_RELEASE} # Stardent Vistra i860-SVR4 - else # Add other i860-SVR4 vendors below as they are discovered. - echo i860-unknown-sysv${UNAME_RELEASE} # Unknown i860-SVR4 - fi - exit 0 ;; - mini*:CTIX:SYS*5:*) - # "miniframe" - echo m68010-convergent-sysv - exit 0 ;; - M68*:*:R3V[567]*:*) - test -r /sysV68 && echo 'm68k-motorola-sysv' && exit 0 ;; - 3[34]??:*:4.0:3.0 | 3[34]??A:*:4.0:3.0 | 3[34]??,*:*:4.0:3.0 | 4850:*:4.0:3.0) - OS_REL='' - test -r /etc/.relid \ - && OS_REL=.`sed -n 's/[^ ]* [^ ]* \([0-9][0-9]\).*/\1/p' < /etc/.relid` - /bin/uname -p 2>/dev/null | grep 86 >/dev/null \ - && echo i486-ncr-sysv4.3${OS_REL} && exit 0 - /bin/uname -p 2>/dev/null | /bin/grep entium >/dev/null \ - && echo i586-ncr-sysv4.3${OS_REL} && exit 0 ;; - 3[34]??:*:4.0:* | 3[34]??,*:*:4.0:*) - /bin/uname -p 2>/dev/null | grep 86 >/dev/null \ - && echo i486-ncr-sysv4 && exit 0 ;; - m68*:LynxOS:2.*:* | m68*:LynxOS:3.0*:*) - echo m68k-unknown-lynxos${UNAME_RELEASE} - exit 0 ;; - mc68030:UNIX_System_V:4.*:*) - echo m68k-atari-sysv4 - exit 0 ;; - i*86:LynxOS:2.*:* | i*86:LynxOS:3.[01]*:* | i*86:LynxOS:4.0*:*) - echo i386-unknown-lynxos${UNAME_RELEASE} - exit 0 ;; - TSUNAMI:LynxOS:2.*:*) - echo sparc-unknown-lynxos${UNAME_RELEASE} - exit 0 ;; - rs6000:LynxOS:2.*:*) - echo rs6000-unknown-lynxos${UNAME_RELEASE} - exit 0 ;; - PowerPC:LynxOS:2.*:* | PowerPC:LynxOS:3.[01]*:* | PowerPC:LynxOS:4.0*:*) - echo powerpc-unknown-lynxos${UNAME_RELEASE} - exit 0 ;; - SM[BE]S:UNIX_SV:*:*) - echo mips-dde-sysv${UNAME_RELEASE} - exit 0 ;; - RM*:ReliantUNIX-*:*:*) - echo mips-sni-sysv4 - exit 0 ;; - RM*:SINIX-*:*:*) - echo mips-sni-sysv4 - exit 0 ;; - *:SINIX-*:*:*) - if uname -p 2>/dev/null >/dev/null ; then - UNAME_MACHINE=`(uname -p) 2>/dev/null` - echo ${UNAME_MACHINE}-sni-sysv4 - else - echo ns32k-sni-sysv - fi - exit 0 ;; - PENTIUM:CPunix:4.0*:*) # Unisys `ClearPath HMP IX 4000' SVR4/MP effort - # says - echo i586-unisys-sysv4 - exit 0 ;; - *:UNIX_System_V:4*:FTX*) - # From Gerald Hewes . - # How about differentiating between stratus architectures? -djm - echo hppa1.1-stratus-sysv4 - exit 0 ;; - *:*:*:FTX*) - # From seanf@swdc.stratus.com. - echo i860-stratus-sysv4 - exit 0 ;; - mc68*:A/UX:*:*) - echo m68k-apple-aux${UNAME_RELEASE} - exit 0 ;; - news*:NEWS-OS:6*:*) - echo mips-sony-newsos6 - exit 0 ;; - R[34]000:*System_V*:*:* | R4000:UNIX_SYSV:*:* | R*000:UNIX_SV:*:*) - if [ -d /usr/nec ]; then - echo mips-nec-sysv${UNAME_RELEASE} - else - echo mips-unknown-sysv${UNAME_RELEASE} - fi - exit 0 ;; - BeBox:BeOS:*:*) # BeOS running on hardware made by Be, PPC only. - echo powerpc-be-beos - exit 0 ;; - BeMac:BeOS:*:*) # BeOS running on Mac or Mac clone, PPC only. - echo powerpc-apple-beos - exit 0 ;; - BePC:BeOS:*:*) # BeOS running on Intel PC compatible. - echo i586-pc-beos - exit 0 ;; - SX-4:SUPER-UX:*:*) - echo sx4-nec-superux${UNAME_RELEASE} - exit 0 ;; - SX-5:SUPER-UX:*:*) - echo sx5-nec-superux${UNAME_RELEASE} - exit 0 ;; - osfmach3_ppc:*:*:*) - echo powerpc-unknown-linux - exit 0 ;; - Power*:Rhapsody:*:*) - echo powerpc-apple-rhapsody${UNAME_RELEASE} - exit 0 ;; - *:Rhapsody:*:*) - echo ${UNAME_MACHINE}-apple-rhapsody${UNAME_RELEASE} - exit 0 ;; - *:Darwin:*:*) - echo `uname -p`-apple-darwin${UNAME_RELEASE} - exit 0 ;; - *:procnto*:*:* | *:QNX:[0123456789]*:*) - if test "${UNAME_MACHINE}" = "x86pc"; then - UNAME_MACHINE=pc - fi - echo `uname -p`-${UNAME_MACHINE}-nto-qnx - exit 0 ;; - *:QNX:*:4*) - echo i386-pc-qnx - exit 0 ;; - NSR-[KW]:NONSTOP_KERNEL:*:*) - echo nsr-tandem-nsk${UNAME_RELEASE} - exit 0 ;; - *:NonStop-UX:*:*) - echo mips-compaq-nonstopux - exit 0 ;; - BS2000:POSIX*:*:*) - echo bs2000-siemens-sysv - exit 0 ;; - DS/*:UNIX_System_V:*:*) - echo ${UNAME_MACHINE}-${UNAME_SYSTEM}-${UNAME_RELEASE} - exit 0 ;; - *:Plan9:*:*) - # "uname -m" is not consistent, so use $cputype instead. 386 - # is converted to i386 for consistency with other x86 - # operating systems. - if test "$cputype" = "386"; then - UNAME_MACHINE=i386 - else - UNAME_MACHINE="$cputype" - fi - echo ${UNAME_MACHINE}-unknown-plan9 - exit 0 ;; - i*86:OS/2:*:*) - # If we were able to find `uname', then EMX Unix compatibility - # is probably installed. - echo ${UNAME_MACHINE}-pc-os2-emx - exit 0 ;; - *:TOPS-10:*:*) - echo pdp10-unknown-tops10 - exit 0 ;; - *:TENEX:*:*) - echo pdp10-unknown-tenex - exit 0 ;; - KS10:TOPS-20:*:* | KL10:TOPS-20:*:* | TYPE4:TOPS-20:*:*) - echo pdp10-dec-tops20 - exit 0 ;; - XKL-1:TOPS-20:*:* | TYPE5:TOPS-20:*:*) - echo pdp10-xkl-tops20 - exit 0 ;; - *:TOPS-20:*:*) - echo pdp10-unknown-tops20 - exit 0 ;; - *:ITS:*:*) - echo pdp10-unknown-its - exit 0 ;; -esac - -#echo '(No uname command or uname output not recognized.)' 1>&2 -#echo "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" 1>&2 - -cat >$dummy.c < -# include -#endif -main () -{ -#if defined (sony) -#if defined (MIPSEB) - /* BFD wants "bsd" instead of "newsos". Perhaps BFD should be changed, - I don't know.... */ - printf ("mips-sony-bsd\n"); exit (0); -#else -#include - printf ("m68k-sony-newsos%s\n", -#ifdef NEWSOS4 - "4" -#else - "" -#endif - ); exit (0); -#endif -#endif - -#if defined (__arm) && defined (__acorn) && defined (__unix) - printf ("arm-acorn-riscix"); exit (0); -#endif - -#if defined (hp300) && !defined (hpux) - printf ("m68k-hp-bsd\n"); exit (0); -#endif - -#if defined (NeXT) - char * arch; - int version; -#if !defined (__ARCHITECTURE__) - arch = "m68k"; -#else - arch = __ARCHITECTURE__; - if (strcmp(arch, "hppa") == 0) arch = "hppa1.1"; -#endif - version=`(hostinfo | sed -n 's/.*NeXT Mach \([0-9]*\).*/\1/p') 2>/dev/null`; - printf ("%s-next-nextstep%d\n", arch, version); - exit (0); -#endif - -#if defined (MULTIMAX) || defined (n16) -#if defined (UMAXV) - printf ("ns32k-encore-sysv\n"); exit (0); -#else -#if defined (CMU) - printf ("ns32k-encore-mach\n"); exit (0); -#else - printf ("ns32k-encore-bsd\n"); exit (0); -#endif -#endif -#endif - -#if defined (__386BSD__) - printf ("i386-pc-bsd\n"); exit (0); -#endif - -#if defined (sequent) -#if defined (i386) - printf ("i386-sequent-dynix\n"); exit (0); -#endif -#if defined (ns32000) - printf ("ns32k-sequent-dynix\n"); exit (0); -#endif -#endif - -#if defined (_SEQUENT_) - struct utsname un; - - uname(&un); - - if (strncmp(un.version, "V2", 2) == 0) { - printf ("i386-sequent-ptx2\n"); exit (0); - } - if (strncmp(un.version, "V1", 2) == 0) { /* XXX is V1 correct? */ - printf ("i386-sequent-ptx1\n"); exit (0); - } - printf ("i386-sequent-ptx\n"); exit (0); - -#endif - -#if defined (vax) -# if !defined (ultrix) -# include -# if defined (BSD) -# if BSD == 43 - printf ("vax-dec-bsd4.3\n"); exit (0); -# else -# if BSD == 199006 - printf ("vax-dec-bsd4.3reno\n"); exit (0); -# else - printf ("vax-dec-bsd\n"); exit (0); -# endif -# endif -# else - printf ("vax-dec-bsd\n"); exit (0); -# endif -# else - printf ("vax-dec-ultrix\n"); exit (0); -# endif -#endif - -#if defined (alliant) && defined (i860) - printf ("i860-alliant-bsd\n"); exit (0); -#endif - - exit (1); -} -EOF - -$CC_FOR_BUILD $dummy.c -o $dummy 2>/dev/null && ./$dummy && rm -f $dummy.c $dummy && exit 0 -rm -f $dummy.c $dummy - -# Apollos put the system type in the environment. - -test -d /usr/apollo && { echo ${ISP}-apollo-${SYSTYPE}; exit 0; } - -# Convex versions that predate uname can use getsysinfo(1) - -if [ -x /usr/convex/getsysinfo ] -then - case `getsysinfo -f cpu_type` in - c1*) - echo c1-convex-bsd - exit 0 ;; - c2*) - if getsysinfo -f scalar_acc - then echo c32-convex-bsd - else echo c2-convex-bsd - fi - exit 0 ;; - c34*) - echo c34-convex-bsd - exit 0 ;; - c38*) - echo c38-convex-bsd - exit 0 ;; - c4*) - echo c4-convex-bsd - exit 0 ;; - esac -fi - -cat >&2 < in order to provide the needed -information to handle your system. - -config.guess timestamp = $timestamp - -uname -m = `(uname -m) 2>/dev/null || echo unknown` -uname -r = `(uname -r) 2>/dev/null || echo unknown` -uname -s = `(uname -s) 2>/dev/null || echo unknown` -uname -v = `(uname -v) 2>/dev/null || echo unknown` - -/usr/bin/uname -p = `(/usr/bin/uname -p) 2>/dev/null` -/bin/uname -X = `(/bin/uname -X) 2>/dev/null` - -hostinfo = `(hostinfo) 2>/dev/null` -/bin/universe = `(/bin/universe) 2>/dev/null` -/usr/bin/arch -k = `(/usr/bin/arch -k) 2>/dev/null` -/bin/arch = `(/bin/arch) 2>/dev/null` -/usr/bin/oslevel = `(/usr/bin/oslevel) 2>/dev/null` -/usr/convex/getsysinfo = `(/usr/convex/getsysinfo) 2>/dev/null` - -UNAME_MACHINE = ${UNAME_MACHINE} -UNAME_RELEASE = ${UNAME_RELEASE} -UNAME_SYSTEM = ${UNAME_SYSTEM} -UNAME_VERSION = ${UNAME_VERSION} -EOF - -exit 1 - -# Local variables: -# eval: (add-hook 'write-file-hooks 'time-stamp) -# time-stamp-start: "timestamp='" -# time-stamp-format: "%:y-%02m-%02d" -# time-stamp-end: "'" -# End: diff --git a/config/gnu/config.sub b/config/gnu/config.sub deleted file mode 100755 index fdcc42bcce..0000000000 --- a/config/gnu/config.sub +++ /dev/null @@ -1,1375 +0,0 @@ -#! /bin/sh -# Configuration validation subroutine script. -# Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001 -# Free Software Foundation, Inc. - -timestamp='2001-06-08' - -# This file is (in principle) common to ALL GNU software. -# The presence of a machine in this file suggests that SOME GNU software -# can handle that machine. It does not imply ALL GNU software can. -# -# This file is free software; you can redistribute it and/or modify -# it under the terms of the GNU General Public License as published by -# the Free Software Foundation; either version 2 of the License, or -# (at your option) any later version. -# -# This program is distributed in the hope that it will be useful, -# but WITHOUT ANY WARRANTY; without even the implied warranty of -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, -# Boston, MA 02111-1307, USA. - -# As a special exception to the GNU General Public License, if you -# distribute this file as part of a program that contains a -# configuration script generated by Autoconf, you may include it under -# the same distribution terms that you use for the rest of that program. - -# Please send patches to . -# -# Configuration subroutine to validate and canonicalize a configuration type. -# Supply the specified configuration type as an argument. -# If it is invalid, we print an error message on stderr and exit with code 1. -# Otherwise, we print the canonical config type on stdout and succeed. - -# This file is supposed to be the same for all GNU packages -# and recognize all the CPU types, system types and aliases -# that are meaningful with *any* GNU software. -# Each package is responsible for reporting which valid configurations -# it does not support. The user should be able to distinguish -# a failure to support a valid configuration from a meaningless -# configuration. - -# The goal of this file is to map all the various variations of a given -# machine specification into a single specification in the form: -# CPU_TYPE-MANUFACTURER-OPERATING_SYSTEM -# or in some cases, the newer four-part form: -# CPU_TYPE-MANUFACTURER-KERNEL-OPERATING_SYSTEM -# It is wrong to echo any other type of specification. - -me=`echo "$0" | sed -e 's,.*/,,'` - -usage="\ -Usage: $0 [OPTION] CPU-MFR-OPSYS - $0 [OPTION] ALIAS - -Canonicalize a configuration name. - -Operation modes: - -h, --help print this help, then exit - -t, --time-stamp print date of last modification, then exit - -v, --version print version number, then exit - -Report bugs and patches to ." - -version="\ -GNU config.sub ($timestamp) - -Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001 -Free Software Foundation, Inc. - -This is free software; see the source for copying conditions. There is NO -warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE." - -help=" -Try \`$me --help' for more information." - -# Parse command line -while test $# -gt 0 ; do - case $1 in - --time-stamp | --time* | -t ) - echo "$timestamp" ; exit 0 ;; - --version | -v ) - echo "$version" ; exit 0 ;; - --help | --h* | -h ) - echo "$usage"; exit 0 ;; - -- ) # Stop option processing - shift; break ;; - - ) # Use stdin as input. - break ;; - -* ) - echo "$me: invalid option $1$help" - exit 1 ;; - - *local*) - # First pass through any local machine types. - echo $1 - exit 0;; - - * ) - break ;; - esac -done - -case $# in - 0) echo "$me: missing argument$help" >&2 - exit 1;; - 1) ;; - *) echo "$me: too many arguments$help" >&2 - exit 1;; -esac - -# Separate what the user gave into CPU-COMPANY and OS or KERNEL-OS (if any). -# Here we must recognize all the valid KERNEL-OS combinations. -maybe_os=`echo $1 | sed 's/^\(.*\)-\([^-]*-[^-]*\)$/\2/'` -case $maybe_os in - nto-qnx* | linux-gnu* | storm-chaos* | os2-emx* | windows32-*) - os=-$maybe_os - basic_machine=`echo $1 | sed 's/^\(.*\)-\([^-]*-[^-]*\)$/\1/'` - ;; - *) - basic_machine=`echo $1 | sed 's/-[^-]*$//'` - if [ $basic_machine != $1 ] - then os=`echo $1 | sed 's/.*-/-/'` - else os=; fi - ;; -esac - -### Let's recognize common machines as not being operating systems so -### that things like config.sub decstation-3100 work. We also -### recognize some manufacturers as not being operating systems, so we -### can provide default operating systems below. -case $os in - -sun*os*) - # Prevent following clause from handling this invalid input. - ;; - -dec* | -mips* | -sequent* | -encore* | -pc532* | -sgi* | -sony* | \ - -att* | -7300* | -3300* | -delta* | -motorola* | -sun[234]* | \ - -unicom* | -ibm* | -next | -hp | -isi* | -apollo | -altos* | \ - -convergent* | -ncr* | -news | -32* | -3600* | -3100* | -hitachi* |\ - -c[123]* | -convex* | -sun | -crds | -omron* | -dg | -ultra | -tti* | \ - -harris | -dolphin | -highlevel | -gould | -cbm | -ns | -masscomp | \ - -apple | -axis) - os= - basic_machine=$1 - ;; - -sim | -cisco | -oki | -wec | -winbond) - os= - basic_machine=$1 - ;; - -scout) - ;; - -wrs) - os=-vxworks - basic_machine=$1 - ;; - -chorusos*) - os=-chorusos - basic_machine=$1 - ;; - -chorusrdb) - os=-chorusrdb - basic_machine=$1 - ;; - -hiux*) - os=-hiuxwe2 - ;; - -sco5) - os=-sco3.2v5 - basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` - ;; - -sco4) - os=-sco3.2v4 - basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` - ;; - -sco3.2.[4-9]*) - os=`echo $os | sed -e 's/sco3.2./sco3.2v/'` - basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` - ;; - -sco3.2v[4-9]*) - # Don't forget version if it is 3.2v4 or newer. - basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` - ;; - -sco*) - os=-sco3.2v2 - basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` - ;; - -udk*) - basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` - ;; - -isc) - os=-isc2.2 - basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` - ;; - -clix*) - basic_machine=clipper-intergraph - ;; - -isc*) - basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` - ;; - -lynx*) - os=-lynxos - ;; - -ptx*) - basic_machine=`echo $1 | sed -e 's/86-.*/86-sequent/'` - ;; - -windowsnt*) - os=`echo $os | sed -e 's/windowsnt/winnt/'` - ;; - -psos*) - os=-psos - ;; - -mint | -mint[0-9]*) - basic_machine=m68k-atari - os=-mint - ;; -esac - -# Decode aliases for certain CPU-COMPANY combinations. -case $basic_machine in - # Recognize the basic CPU types without company name. - # Some are omitted here because they have special meanings below. - tahoe | i860 | ia64 | m32r | m68k | m68000 | m88k | ns32k | arc \ - | arm | arme[lb] | arm[bl]e | armv[2345] | armv[345][lb] | strongarm | xscale \ - | pyramid | mn10200 | mn10300 | tron | a29k \ - | 580 | i960 | h8300 \ - | x86 | ppcbe | mipsbe | mipsle | shbe | shle \ - | hppa | hppa1.0 | hppa1.1 | hppa2.0 | hppa2.0w | hppa2.0n \ - | hppa64 \ - | alpha | alphaev[4-8] | alphaev56 | alphapca5[67] \ - | alphaev6[78] \ - | we32k | ns16k | clipper | i370 | sh | sh[34] \ - | powerpc | powerpcle \ - | 1750a | dsp16xx | pdp10 | pdp11 \ - | mips16 | mips64 | mipsel | mips64el \ - | mips64orion | mips64orionel | mipstx39 | mipstx39el \ - | mips64vr4300 | mips64vr4300el | mips64vr4100 | mips64vr4100el \ - | mips64vr5000 | miprs64vr5000el | mcore | s390 | s390x \ - | sparc | sparclet | sparclite | sparc64 | sparcv9 | sparcv9b \ - | v850 | c4x \ - | thumb | d10v | d30v | fr30 | avr | openrisc | tic80 \ - | pj | pjl | h8500 | z8k) - basic_machine=$basic_machine-unknown - ;; - m6811 | m68hc11 | m6812 | m68hc12) - # Motorola 68HC11/12. - basic_machine=$basic_machine-unknown - os=-none - ;; - m88110 | m680[12346]0 | m683?2 | m68360 | m5200 | v70 | w65 | z8k) - ;; - - # We use `pc' rather than `unknown' - # because (1) that's what they normally are, and - # (2) the word "unknown" tends to confuse beginning users. - i*86 | x86_64) - basic_machine=$basic_machine-pc - ;; - # Object if more than one company name word. - *-*-*) - echo Invalid configuration \`$1\': machine \`$basic_machine\' not recognized 1>&2 - exit 1 - ;; - # Recognize the basic CPU types with company name. - # FIXME: clean up the formatting here. - vax-* | tahoe-* | i*86-* | i860-* | ia64-* | m32r-* | m68k-* | m68000-* \ - | m88k-* | sparc-* | ns32k-* | fx80-* | arc-* | c[123]* \ - | arm-* | armbe-* | armle-* | armv*-* | strongarm-* | xscale-* \ - | mips-* | pyramid-* | tron-* | a29k-* | romp-* | rs6000-* \ - | power-* | none-* | 580-* | cray2-* | h8300-* | h8500-* | i960-* \ - | xmp-* | ymp-* \ - | x86-* | ppcbe-* | mipsbe-* | mipsle-* | shbe-* | shle-* \ - | hppa-* | hppa1.0-* | hppa1.1-* | hppa2.0-* | hppa2.0w-* \ - | hppa2.0n-* | hppa64-* \ - | alpha-* | alphaev[4-8]-* | alphaev56-* | alphapca5[67]-* \ - | alphaev6[78]-* \ - | we32k-* | cydra-* | ns16k-* | pn-* | np1-* | xps100-* \ - | clipper-* | orion-* \ - | sparclite-* | pdp10-* | pdp11-* | sh-* | sh[34]-* | sh[34]eb-* \ - | powerpc-* | powerpcle-* | sparc64-* | sparcv9-* | sparcv9b-* | sparc86x-* \ - | mips16-* | mips64-* | mipsel-* \ - | mips64el-* | mips64orion-* | mips64orionel-* \ - | mips64vr4100-* | mips64vr4100el-* | mips64vr4300-* | mips64vr4300el-* \ - | mipstx39-* | mipstx39el-* | mcore-* \ - | f30[01]-* | f700-* | s390-* | s390x-* | sv1-* | t3e-* \ - | [cjt]90-* \ - | m88110-* | m680[01234]0-* | m683?2-* | m68360-* | z8k-* | d10v-* \ - | thumb-* | v850-* | d30v-* | tic30-* | tic80-* | c30-* | fr30-* \ - | bs2000-* | tic54x-* | c54x-* | x86_64-* | pj-* | pjl-*) - ;; - # Recognize the various machine names and aliases which stand - # for a CPU type and a company and sometimes even an OS. - 386bsd) - basic_machine=i386-unknown - os=-bsd - ;; - 3b1 | 7300 | 7300-att | att-7300 | pc7300 | safari | unixpc) - basic_machine=m68000-att - ;; - 3b*) - basic_machine=we32k-att - ;; - a29khif) - basic_machine=a29k-amd - os=-udi - ;; - adobe68k) - basic_machine=m68010-adobe - os=-scout - ;; - alliant | fx80) - basic_machine=fx80-alliant - ;; - altos | altos3068) - basic_machine=m68k-altos - ;; - am29k) - basic_machine=a29k-none - os=-bsd - ;; - amdahl) - basic_machine=580-amdahl - os=-sysv - ;; - amiga | amiga-*) - basic_machine=m68k-unknown - ;; - amigaos | amigados) - basic_machine=m68k-unknown - os=-amigaos - ;; - amigaunix | amix) - basic_machine=m68k-unknown - os=-sysv4 - ;; - apollo68) - basic_machine=m68k-apollo - os=-sysv - ;; - apollo68bsd) - basic_machine=m68k-apollo - os=-bsd - ;; - aux) - basic_machine=m68k-apple - os=-aux - ;; - balance) - basic_machine=ns32k-sequent - os=-dynix - ;; - convex-c1) - basic_machine=c1-convex - os=-bsd - ;; - convex-c2) - basic_machine=c2-convex - os=-bsd - ;; - convex-c32) - basic_machine=c32-convex - os=-bsd - ;; - convex-c34) - basic_machine=c34-convex - os=-bsd - ;; - convex-c38) - basic_machine=c38-convex - os=-bsd - ;; - cray | ymp) - basic_machine=ymp-cray - os=-unicos - ;; - cray2) - basic_machine=cray2-cray - os=-unicos - ;; - [cjt]90) - basic_machine=${basic_machine}-cray - os=-unicos - ;; - crds | unos) - basic_machine=m68k-crds - ;; - cris | cris-* | etrax*) - basic_machine=cris-axis - ;; - da30 | da30-*) - basic_machine=m68k-da30 - ;; - decstation | decstation-3100 | pmax | pmax-* | pmin | dec3100 | decstatn) - basic_machine=mips-dec - ;; - delta | 3300 | motorola-3300 | motorola-delta \ - | 3300-motorola | delta-motorola) - basic_machine=m68k-motorola - ;; - delta88) - basic_machine=m88k-motorola - os=-sysv3 - ;; - dpx20 | dpx20-*) - basic_machine=rs6000-bull - os=-bosx - ;; - dpx2* | dpx2*-bull) - basic_machine=m68k-bull - os=-sysv3 - ;; - ebmon29k) - basic_machine=a29k-amd - os=-ebmon - ;; - elxsi) - basic_machine=elxsi-elxsi - os=-bsd - ;; - encore | umax | mmax) - basic_machine=ns32k-encore - ;; - es1800 | OSE68k | ose68k | ose | OSE) - basic_machine=m68k-ericsson - os=-ose - ;; - fx2800) - basic_machine=i860-alliant - ;; - genix) - basic_machine=ns32k-ns - ;; - gmicro) - basic_machine=tron-gmicro - os=-sysv - ;; - go32) - basic_machine=i386-pc - os=-go32 - ;; - h3050r* | hiux*) - basic_machine=hppa1.1-hitachi - os=-hiuxwe2 - ;; - h8300hms) - basic_machine=h8300-hitachi - os=-hms - ;; - h8300xray) - basic_machine=h8300-hitachi - os=-xray - ;; - h8500hms) - basic_machine=h8500-hitachi - os=-hms - ;; - harris) - basic_machine=m88k-harris - os=-sysv3 - ;; - hp300-*) - basic_machine=m68k-hp - ;; - hp300bsd) - basic_machine=m68k-hp - os=-bsd - ;; - hp300hpux) - basic_machine=m68k-hp - os=-hpux - ;; - hp3k9[0-9][0-9] | hp9[0-9][0-9]) - basic_machine=hppa1.0-hp - ;; - hp9k2[0-9][0-9] | hp9k31[0-9]) - basic_machine=m68000-hp - ;; - hp9k3[2-9][0-9]) - basic_machine=m68k-hp - ;; - hp9k6[0-9][0-9] | hp6[0-9][0-9]) - basic_machine=hppa1.0-hp - ;; - hp9k7[0-79][0-9] | hp7[0-79][0-9]) - basic_machine=hppa1.1-hp - ;; - hp9k78[0-9] | hp78[0-9]) - # FIXME: really hppa2.0-hp - basic_machine=hppa1.1-hp - ;; - hp9k8[67]1 | hp8[67]1 | hp9k80[24] | hp80[24] | hp9k8[78]9 | hp8[78]9 | hp9k893 | hp893) - # FIXME: really hppa2.0-hp - basic_machine=hppa1.1-hp - ;; - hp9k8[0-9][13679] | hp8[0-9][13679]) - basic_machine=hppa1.1-hp - ;; - hp9k8[0-9][0-9] | hp8[0-9][0-9]) - basic_machine=hppa1.0-hp - ;; - hppa-next) - os=-nextstep3 - ;; - hppaosf) - basic_machine=hppa1.1-hp - os=-osf - ;; - hppro) - basic_machine=hppa1.1-hp - os=-proelf - ;; - i370-ibm* | ibm*) - basic_machine=i370-ibm - ;; -# I'm not sure what "Sysv32" means. Should this be sysv3.2? - i*86v32) - basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'` - os=-sysv32 - ;; - i*86v4*) - basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'` - os=-sysv4 - ;; - i*86v) - basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'` - os=-sysv - ;; - i*86sol2) - basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'` - os=-solaris2 - ;; - i386mach) - basic_machine=i386-mach - os=-mach - ;; - i386-vsta | vsta) - basic_machine=i386-unknown - os=-vsta - ;; - iris | iris4d) - basic_machine=mips-sgi - case $os in - -irix*) - ;; - *) - os=-irix4 - ;; - esac - ;; - isi68 | isi) - basic_machine=m68k-isi - os=-sysv - ;; - m88k-omron*) - basic_machine=m88k-omron - ;; - magnum | m3230) - basic_machine=mips-mips - os=-sysv - ;; - merlin) - basic_machine=ns32k-utek - os=-sysv - ;; - mingw32) - basic_machine=i386-pc - os=-mingw32 - ;; - miniframe) - basic_machine=m68000-convergent - ;; - *mint | -mint[0-9]* | *MiNT | *MiNT[0-9]*) - basic_machine=m68k-atari - os=-mint - ;; - mipsel*-linux*) - basic_machine=mipsel-unknown - os=-linux-gnu - ;; - mips*-linux*) - basic_machine=mips-unknown - os=-linux-gnu - ;; - mips3*-*) - basic_machine=`echo $basic_machine | sed -e 's/mips3/mips64/'` - ;; - mips3*) - basic_machine=`echo $basic_machine | sed -e 's/mips3/mips64/'`-unknown - ;; - mmix*) - basic_machine=mmix-knuth - os=-mmixware - ;; - monitor) - basic_machine=m68k-rom68k - os=-coff - ;; - msdos) - basic_machine=i386-pc - os=-msdos - ;; - mvs) - basic_machine=i370-ibm - os=-mvs - ;; - ncr3000) - basic_machine=i486-ncr - os=-sysv4 - ;; - netbsd386) - basic_machine=i386-unknown - os=-netbsd - ;; - netwinder) - basic_machine=armv4l-rebel - os=-linux - ;; - news | news700 | news800 | news900) - basic_machine=m68k-sony - os=-newsos - ;; - news1000) - basic_machine=m68030-sony - os=-newsos - ;; - news-3600 | risc-news) - basic_machine=mips-sony - os=-newsos - ;; - necv70) - basic_machine=v70-nec - os=-sysv - ;; - next | m*-next ) - basic_machine=m68k-next - case $os in - -nextstep* ) - ;; - -ns2*) - os=-nextstep2 - ;; - *) - os=-nextstep3 - ;; - esac - ;; - nh3000) - basic_machine=m68k-harris - os=-cxux - ;; - nh[45]000) - basic_machine=m88k-harris - os=-cxux - ;; - nindy960) - basic_machine=i960-intel - os=-nindy - ;; - mon960) - basic_machine=i960-intel - os=-mon960 - ;; - nonstopux) - basic_machine=mips-compaq - os=-nonstopux - ;; - np1) - basic_machine=np1-gould - ;; - nsr-tandem) - basic_machine=nsr-tandem - ;; - op50n-* | op60c-*) - basic_machine=hppa1.1-oki - os=-proelf - ;; - OSE68000 | ose68000) - basic_machine=m68000-ericsson - os=-ose - ;; - os68k) - basic_machine=m68k-none - os=-os68k - ;; - pa-hitachi) - basic_machine=hppa1.1-hitachi - os=-hiuxwe2 - ;; - paragon) - basic_machine=i860-intel - os=-osf - ;; - pbd) - basic_machine=sparc-tti - ;; - pbb) - basic_machine=m68k-tti - ;; - pc532 | pc532-*) - basic_machine=ns32k-pc532 - ;; - pentium | p5 | k5 | k6 | nexgen) - basic_machine=i586-pc - ;; - pentiumpro | p6 | 6x86 | athlon) - basic_machine=i686-pc - ;; - pentiumii | pentium2) - basic_machine=i686-pc - ;; - pentium-* | p5-* | k5-* | k6-* | nexgen-*) - basic_machine=i586-`echo $basic_machine | sed 's/^[^-]*-//'` - ;; - pentiumpro-* | p6-* | 6x86-* | athlon-*) - basic_machine=i686-`echo $basic_machine | sed 's/^[^-]*-//'` - ;; - pentiumii-* | pentium2-*) - basic_machine=i686-`echo $basic_machine | sed 's/^[^-]*-//'` - ;; - pn) - basic_machine=pn-gould - ;; - power) basic_machine=power-ibm - ;; - ppc) basic_machine=powerpc-unknown - ;; - ppc-*) basic_machine=powerpc-`echo $basic_machine | sed 's/^[^-]*-//'` - ;; - ppcle | powerpclittle | ppc-le | powerpc-little) - basic_machine=powerpcle-unknown - ;; - ppcle-* | powerpclittle-*) - basic_machine=powerpcle-`echo $basic_machine | sed 's/^[^-]*-//'` - ;; - ps2) - basic_machine=i386-ibm - ;; - pw32) - basic_machine=i586-unknown - os=-pw32 - ;; - rom68k) - basic_machine=m68k-rom68k - os=-coff - ;; - rm[46]00) - basic_machine=mips-siemens - ;; - rtpc | rtpc-*) - basic_machine=romp-ibm - ;; - sa29200) - basic_machine=a29k-amd - os=-udi - ;; - sequent) - basic_machine=i386-sequent - ;; - sh) - basic_machine=sh-hitachi - os=-hms - ;; - sparclite-wrs) - basic_machine=sparclite-wrs - os=-vxworks - ;; - sps7) - basic_machine=m68k-bull - os=-sysv2 - ;; - spur) - basic_machine=spur-unknown - ;; - st2000) - basic_machine=m68k-tandem - ;; - stratus) - basic_machine=i860-stratus - os=-sysv4 - ;; - sun2) - basic_machine=m68000-sun - ;; - sun2os3) - basic_machine=m68000-sun - os=-sunos3 - ;; - sun2os4) - basic_machine=m68000-sun - os=-sunos4 - ;; - sun3os3) - basic_machine=m68k-sun - os=-sunos3 - ;; - sun3os4) - basic_machine=m68k-sun - os=-sunos4 - ;; - sun4os3) - basic_machine=sparc-sun - os=-sunos3 - ;; - sun4os4) - basic_machine=sparc-sun - os=-sunos4 - ;; - sun4sol2) - basic_machine=sparc-sun - os=-solaris2 - ;; - sun3 | sun3-*) - basic_machine=m68k-sun - ;; - sun4) - basic_machine=sparc-sun - ;; - sun386 | sun386i | roadrunner) - basic_machine=i386-sun - ;; - sv1) - basic_machine=sv1-cray - os=-unicos - ;; - symmetry) - basic_machine=i386-sequent - os=-dynix - ;; - t3e) - basic_machine=t3e-cray - os=-unicos - ;; - tic54x | c54x*) - basic_machine=tic54x-unknown - os=-coff - ;; - tx39) - basic_machine=mipstx39-unknown - ;; - tx39el) - basic_machine=mipstx39el-unknown - ;; - tower | tower-32) - basic_machine=m68k-ncr - ;; - udi29k) - basic_machine=a29k-amd - os=-udi - ;; - ultra3) - basic_machine=a29k-nyu - os=-sym1 - ;; - v810 | necv810) - basic_machine=v810-nec - os=-none - ;; - vaxv) - basic_machine=vax-dec - os=-sysv - ;; - vms) - basic_machine=vax-dec - os=-vms - ;; - vpp*|vx|vx-*) - basic_machine=f301-fujitsu - ;; - vxworks960) - basic_machine=i960-wrs - os=-vxworks - ;; - vxworks68) - basic_machine=m68k-wrs - os=-vxworks - ;; - vxworks29k) - basic_machine=a29k-wrs - os=-vxworks - ;; - w65*) - basic_machine=w65-wdc - os=-none - ;; - w89k-*) - basic_machine=hppa1.1-winbond - os=-proelf - ;; - windows32) - basic_machine=i386-pc - os=-windows32-msvcrt - ;; - xmp) - basic_machine=xmp-cray - os=-unicos - ;; - xps | xps100) - basic_machine=xps100-honeywell - ;; - z8k-*-coff) - basic_machine=z8k-unknown - os=-sim - ;; - none) - basic_machine=none-none - os=-none - ;; - -# Here we handle the default manufacturer of certain CPU types. It is in -# some cases the only manufacturer, in others, it is the most popular. - w89k) - basic_machine=hppa1.1-winbond - ;; - op50n) - basic_machine=hppa1.1-oki - ;; - op60c) - basic_machine=hppa1.1-oki - ;; - mips) - if [ x$os = x-linux-gnu ]; then - basic_machine=mips-unknown - else - basic_machine=mips-mips - fi - ;; - romp) - basic_machine=romp-ibm - ;; - rs6000) - basic_machine=rs6000-ibm - ;; - vax) - basic_machine=vax-dec - ;; - pdp10) - # there are many clones, so DEC is not a safe bet - basic_machine=pdp10-unknown - ;; - pdp11) - basic_machine=pdp11-dec - ;; - we32k) - basic_machine=we32k-att - ;; - sh3 | sh4) - basic_machine=sh-unknown - ;; - sparc | sparcv9 | sparcv9b) - basic_machine=sparc-sun - ;; - cydra) - basic_machine=cydra-cydrome - ;; - orion) - basic_machine=orion-highlevel - ;; - orion105) - basic_machine=clipper-highlevel - ;; - mac | mpw | mac-mpw) - basic_machine=m68k-apple - ;; - pmac | pmac-mpw) - basic_machine=powerpc-apple - ;; - c4x*) - basic_machine=c4x-none - os=-coff - ;; - *-unknown) - # Make sure to match an already-canonicalized machine name. - ;; - *) - echo Invalid configuration \`$1\': machine \`$basic_machine\' not recognized 1>&2 - exit 1 - ;; -esac - -# Here we canonicalize certain aliases for manufacturers. -case $basic_machine in - *-digital*) - basic_machine=`echo $basic_machine | sed 's/digital.*/dec/'` - ;; - *-commodore*) - basic_machine=`echo $basic_machine | sed 's/commodore.*/cbm/'` - ;; - *) - ;; -esac - -# Decode manufacturer-specific aliases for certain operating systems. - -if [ x"$os" != x"" ] -then -case $os in - # First match some system type aliases - # that might get confused with valid system types. - # -solaris* is a basic system type, with this one exception. - -solaris1 | -solaris1.*) - os=`echo $os | sed -e 's|solaris1|sunos4|'` - ;; - -solaris) - os=-solaris2 - ;; - -svr4*) - os=-sysv4 - ;; - -unixware*) - os=-sysv4.2uw - ;; - -gnu/linux*) - os=`echo $os | sed -e 's|gnu/linux|linux-gnu|'` - ;; - # First accept the basic system types. - # The portable systems comes first. - # Each alternative MUST END IN A *, to match a version number. - # -sysv* is not here because it comes later, after sysvr4. - -gnu* | -bsd* | -mach* | -minix* | -genix* | -ultrix* | -irix* \ - | -*vms* | -sco* | -esix* | -isc* | -aix* | -sunos | -sunos[34]*\ - | -hpux* | -unos* | -osf* | -luna* | -dgux* | -solaris* | -sym* \ - | -amigaos* | -amigados* | -msdos* | -newsos* | -unicos* | -aof* \ - | -aos* \ - | -nindy* | -vxsim* | -vxworks* | -ebmon* | -hms* | -mvs* \ - | -clix* | -riscos* | -uniplus* | -iris* | -rtu* | -xenix* \ - | -hiux* | -386bsd* | -netbsd* | -openbsd* | -freebsd* | -riscix* \ - | -lynxos* | -bosx* | -nextstep* | -cxux* | -aout* | -elf* | -oabi* \ - | -ptx* | -coff* | -ecoff* | -winnt* | -domain* | -vsta* \ - | -udi* | -eabi* | -lites* | -ieee* | -go32* | -aux* \ - | -chorusos* | -chorusrdb* \ - | -cygwin* | -pe* | -psos* | -moss* | -proelf* | -rtems* \ - | -mingw32* | -linux-gnu* | -uxpv* | -beos* | -mpeix* | -udk* \ - | -interix* | -uwin* | -rhapsody* | -darwin* | -opened* \ - | -openstep* | -oskit* | -conix* | -pw32* | -nonstopux* \ - | -storm-chaos* | -tops10* | -tenex* | -tops20* | -its* | -os2*) - # Remember, each alternative MUST END IN *, to match a version number. - ;; - -qnx*) - case $basic_machine in - x86-* | i*86-*) - ;; - *) - os=-nto$os - ;; - esac - ;; - -nto*) - os=-nto-qnx - ;; - -sim | -es1800* | -hms* | -xray | -os68k* | -none* | -v88r* \ - | -windows* | -osx | -abug | -netware* | -os9* | -beos* \ - | -macos* | -mpw* | -magic* | -mmixware* | -mon960* | -lnews*) - ;; - -mac*) - os=`echo $os | sed -e 's|mac|macos|'` - ;; - -linux*) - os=`echo $os | sed -e 's|linux|linux-gnu|'` - ;; - -sunos5*) - os=`echo $os | sed -e 's|sunos5|solaris2|'` - ;; - -sunos6*) - os=`echo $os | sed -e 's|sunos6|solaris3|'` - ;; - -opened*) - os=-openedition - ;; - -wince*) - os=-wince - ;; - -osfrose*) - os=-osfrose - ;; - -osf*) - os=-osf - ;; - -utek*) - os=-bsd - ;; - -dynix*) - os=-bsd - ;; - -acis*) - os=-aos - ;; - -386bsd) - os=-bsd - ;; - -ctix* | -uts*) - os=-sysv - ;; - -ns2 ) - os=-nextstep2 - ;; - -nsk*) - os=-nsk - ;; - # Preserve the version number of sinix5. - -sinix5.*) - os=`echo $os | sed -e 's|sinix|sysv|'` - ;; - -sinix*) - os=-sysv4 - ;; - -triton*) - os=-sysv3 - ;; - -oss*) - os=-sysv3 - ;; - -svr4) - os=-sysv4 - ;; - -svr3) - os=-sysv3 - ;; - -sysvr4) - os=-sysv4 - ;; - # This must come after -sysvr4. - -sysv*) - ;; - -ose*) - os=-ose - ;; - -es1800*) - os=-ose - ;; - -xenix) - os=-xenix - ;; - -*mint | -mint[0-9]* | -*MiNT | -MiNT[0-9]*) - os=-mint - ;; - -none) - ;; - *) - # Get rid of the `-' at the beginning of $os. - os=`echo $os | sed 's/[^-]*-//'` - echo Invalid configuration \`$1\': system \`$os\' not recognized 1>&2 - exit 1 - ;; -esac -else - -# Here we handle the default operating systems that come with various machines. -# The value should be what the vendor currently ships out the door with their -# machine or put another way, the most popular os provided with the machine. - -# Note that if you're going to try to match "-MANUFACTURER" here (say, -# "-sun"), then you have to tell the case statement up towards the top -# that MANUFACTURER isn't an operating system. Otherwise, code above -# will signal an error saying that MANUFACTURER isn't an operating -# system, and we'll never get to this point. - -case $basic_machine in - *-acorn) - os=-riscix1.2 - ;; - arm*-rebel) - os=-linux - ;; - arm*-semi) - os=-aout - ;; - pdp10-*) - os=-tops20 - ;; - pdp11-*) - os=-none - ;; - *-dec | vax-*) - os=-ultrix4.2 - ;; - m68*-apollo) - os=-domain - ;; - i386-sun) - os=-sunos4.0.2 - ;; - m68000-sun) - os=-sunos3 - # This also exists in the configure program, but was not the - # default. - # os=-sunos4 - ;; - m68*-cisco) - os=-aout - ;; - mips*-cisco) - os=-elf - ;; - mips*-*) - os=-elf - ;; - *-tti) # must be before sparc entry or we get the wrong os. - os=-sysv3 - ;; - sparc-* | *-sun) - os=-sunos4.1.1 - ;; - *-be) - os=-beos - ;; - *-ibm) - os=-aix - ;; - *-wec) - os=-proelf - ;; - *-winbond) - os=-proelf - ;; - *-oki) - os=-proelf - ;; - *-hp) - os=-hpux - ;; - *-hitachi) - os=-hiux - ;; - i860-* | *-att | *-ncr | *-altos | *-motorola | *-convergent) - os=-sysv - ;; - *-cbm) - os=-amigaos - ;; - *-dg) - os=-dgux - ;; - *-dolphin) - os=-sysv3 - ;; - m68k-ccur) - os=-rtu - ;; - m88k-omron*) - os=-luna - ;; - *-next ) - os=-nextstep - ;; - *-sequent) - os=-ptx - ;; - *-crds) - os=-unos - ;; - *-ns) - os=-genix - ;; - i370-*) - os=-mvs - ;; - *-next) - os=-nextstep3 - ;; - *-gould) - os=-sysv - ;; - *-highlevel) - os=-bsd - ;; - *-encore) - os=-bsd - ;; - *-sgi) - os=-irix - ;; - *-siemens) - os=-sysv4 - ;; - *-masscomp) - os=-rtu - ;; - f30[01]-fujitsu | f700-fujitsu) - os=-uxpv - ;; - *-rom68k) - os=-coff - ;; - *-*bug) - os=-coff - ;; - *-apple) - os=-macos - ;; - *-atari*) - os=-mint - ;; - *) - os=-none - ;; -esac -fi - -# Here we handle the case where we know the os, and the CPU type, but not the -# manufacturer. We pick the logical manufacturer. -vendor=unknown -case $basic_machine in - *-unknown) - case $os in - -riscix*) - vendor=acorn - ;; - -sunos*) - vendor=sun - ;; - -aix*) - vendor=ibm - ;; - -beos*) - vendor=be - ;; - -hpux*) - vendor=hp - ;; - -mpeix*) - vendor=hp - ;; - -hiux*) - vendor=hitachi - ;; - -unos*) - vendor=crds - ;; - -dgux*) - vendor=dg - ;; - -luna*) - vendor=omron - ;; - -genix*) - vendor=ns - ;; - -mvs* | -opened*) - vendor=ibm - ;; - -ptx*) - vendor=sequent - ;; - -vxsim* | -vxworks*) - vendor=wrs - ;; - -aux*) - vendor=apple - ;; - -hms*) - vendor=hitachi - ;; - -mpw* | -macos*) - vendor=apple - ;; - -*mint | -mint[0-9]* | -*MiNT | -MiNT[0-9]*) - vendor=atari - ;; - esac - basic_machine=`echo $basic_machine | sed "s/unknown/$vendor/"` - ;; -esac - -echo $basic_machine$os -exit 0 - -# Local variables: -# eval: (add-hook 'write-file-hooks 'time-stamp) -# time-stamp-start: "timestamp='" -# time-stamp-format: "%:y-%02m-%02d" -# time-stamp-end: "'" -# End: diff --git a/config/m-MacOS.h b/config/m-MacOS.h deleted file mode 100644 index ec3b65c41b..0000000000 --- a/config/m-MacOS.h +++ /dev/null @@ -1,33 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Damien Doligez, projet Moscova, INRIA Rocquencourt */ -/* */ -/* Copyright 2000 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 file ../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#define ARCH_BIG_ENDIAN - -#define SIZEOF_INT 4 -#define SIZEOF_LONG 4 -#define SIZEOF_SHORT 2 - -#if powerc -#define ARCH_INT64_TYPE long long -#define ARCH_UINT64_TYPE unsigned long long -#define ARCH_INT64_PRINTF_FORMAT "ll" -#endif - -#if powerc -#define CPU_TYPE_STRING "PPC" -#else -#define CPU_TYPE_STRING "68k" -#define THREADED_CODE -#endif diff --git a/config/m-nt.h b/config/m-nt.h deleted file mode 100644 index 46e8817bd7..0000000000 --- a/config/m-nt.h +++ /dev/null @@ -1,34 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 1996 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 file ../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -/* Machine configuration, Intel x86 processors, Win32, - Visual C++ or Mingw compiler */ - -#undef ARCH_SIXTYFOUR -#undef ARCH_BIG_ENDIAN -#undef ARCH_ALIGN_DOUBLE -#define SIZEOF_INT 4 -#define SIZEOF_LONG 4 -#define SIZEOF_SHORT 2 -#ifdef __MINGW32__ -#define ARCH_INT64_TYPE long long -#define ARCH_UINT64_TYPE unsigned long long -#else -#define ARCH_INT64_TYPE __int64 -#define ARCH_UINT64_TYPE unsigned __int64 -#endif -#define ARCH_INT64_PRINTF_FORMAT "I64" -#undef NONSTANDARD_DIV_MOD - diff --git a/config/m-templ.h b/config/m-templ.h deleted file mode 100644 index fdfc0c8c85..0000000000 --- a/config/m-templ.h +++ /dev/null @@ -1,81 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 1996 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 file ../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -/* Processor dependencies */ - -#define ARCH_SIXTYFOUR - -/* Define ARCH_SIXTYFOUR if the processor has a natural word size of 64 bits. - That is, both sizeof(long) = 8 and sizeof(char *) = 8. - Otherwise, leave ARCH_SIXTYFOUR undefined. This assumes - sizeof(long) = sizeof(char *) = 4. */ - -#define ARCH_BIG_ENDIAN - -/* Define ARCH_BIG_ENDIAN if the processor is big endian (the most - significant byte of an integer stored in memory comes first). - Leave ARCH_BIG_ENDIAN undefined if the processor is little-endian - (the least significant byte comes first). -*/ - -#define ARCH_ALIGN_DOUBLE - -/* Define ARCH_ALIGN_DOUBLE if the processor requires doubles to be - doubleword-aligned. Leave ARCH_ALIGN_DOUBLE undefined if the processor - supports word-aligned doubles. */ - -#undef ARCH_CODE32 - -/* Define ARCH_CODE32 if, on a 64-bit machine, code pointers fit in 32 bits, - i.e. the code segment resides in the low 4G of the addressing space. - ARCH_CODE32 is ignored on 32-bit machines. */ - -#define SIZEOF_INT 4 -#define SIZEOF_LONG 4 -#define SIZEOF_SHORT 2 - -/* Define SIZEOF_INT, SIZEOF_LONG and SIZEOF_SHORT to the sizes in byte - of the C types "int", "long" and "short", respectively. */ - -#define ARCH_INT64_TYPE long long -#define ARCH_UINT64_TYPE unsigned long long - -/* Define ARCH_INT64_TYPE and ARCH_UINT64_TYPE to 64-bit integer types, - typically "long long" and "unsigned long long" on 32-bit platforms, - and "long" and "unsigned long" on 64-bit platforms. - If the C compiler doesn't support any 64-bit integer type, - leave both ARCH_INT64_TYPE and ARCH_UINT64_TYPE undefined. */ - -#define ARCH_INT64_PRINTF_FORMAT "ll" - -/* Define ARCH_INT64_PRINTF_FORMAT to the printf format used for formatting - values of type ARCH_INT64_TYPE. This is usually "ll" on 32-bit - platforms and "l" on 64-bit platforms. - Leave undefined if ARCH_INT64_TYPE is undefined. */ - -#define ARCH_ALIGN_INT64 - -/* Define ARCH_ALIGN_INT64 if the processor requires 64-bit integers to be - doubleword-aligned. Leave ARCH_ALIGN_INT64 undefined if the processor - supports word-aligned 64-bit integers. Leave undefined if - 64-bit integers are not supported. */ - -#undef NONSTANDARD_DIV_MOD - -/* Leave NONSTANDARD_DIV_MOD undefined if the C operators / and % implement - round-towards-zero semantics, as specified by ISO C 9x and implemented - by most contemporary processors. Otherwise, or if you don't know, - define NONSTANDARD_DIV_MOD: this will select a slower but correct - software emulation of division and modulus. */ diff --git a/config/s-MacOS.h b/config/s-MacOS.h deleted file mode 100644 index 0138ced95b..0000000000 --- a/config/s-MacOS.h +++ /dev/null @@ -1,20 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Damien Doligez, projet Moscova, INRIA Rocquencourt */ -/* */ -/* Copyright 2000 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 file ../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#define OCAML_OS_TYPE "MacOS" -#define HAS_STRERROR -#define HAS_GETCWD - -#define HAS_UI diff --git a/config/s-nt.h b/config/s-nt.h deleted file mode 100644 index 5eaf3770f4..0000000000 --- a/config/s-nt.h +++ /dev/null @@ -1,29 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 1996 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 file ../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -/* Operating system dependencies, Intel x86 processors, Windows NT */ - -#define OCAML_OS_TYPE "Win32" - -#undef BSD_SIGNALS -#define HAS_STRERROR -#define HAS_SOCKETS -#define HAS_GETCWD -#define HAS_UTIME -#define HAS_DUP2 -#define HAS_GETHOSTNAME -#define HAS_MKTIME -#define HAS_PUTENV -#define HAS_LOCALE diff --git a/config/s-templ.h b/config/s-templ.h deleted file mode 100644 index 8411ce41c9..0000000000 --- a/config/s-templ.h +++ /dev/null @@ -1,207 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 1996 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 file ../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -/* Operating system and standard library dependencies. */ - -/* 0. Operating system type string. */ - -#define OCAML_OS_TYPE "Unix" -/* #define OCAML_OS_TYPE "Win32" */ -/* #define OCAML_OS_TYPE "MacOS" */ - -/* 1. For the runtime system. */ - -#define POSIX_SIGNALS - -/* Define POSIX_SIGNALS if signal handling is POSIX-compliant. - In particular, sigaction(), sigprocmask() and the operations on - sigset_t are provided. */ - -#define BSD_SIGNALS - -/* Define BSD_SIGNALS if signal handlers have the BSD semantics: the handler - remains attached to the signal when the signal is received. Leave it - undefined if signal handlers have the System V semantics: the signal - resets the behavior to default. */ - -#define HAS_SIGSETMASK - -/* Define HAS_SIGSETMASK if you have sigsetmask(), as in BSD. */ - -#define HAS_TERMCAP - -/* Define HAS_TERMCAP if you have the termcap functions to read the - terminal database, e.g. tgetent(), tgetstr(), tgetnum(), tputs(). - Also add the required libraries (e.g. -lcurses -ltermcap) to $(CCLIBS) - in ../Makefile.config */ - -#define HAS_STRERROR - -/* Define HAS_STRERROR if you have strerror(). */ - -#define SUPPORT_DYNAMIC_LINKING - -/* Define SUPPORT_DYNAMIC_LINKING if dynamic loading of C stub code - via dlopen() is available. */ - -/* 2. For the Unix library. */ - -#define HAS_SOCKETS - -/* Define HAS_SOCKETS if you have BSD sockets. */ - -#define HAS_SOCKLEN_T - -/* Define HAS_SOCKLEN_T if the type socklen_t is defined in - /usr/include/sys/socket.h. */ - -#define HAS_UNISTD - -/* Define HAS_UNISTD if you have /usr/include/unistd.h. */ - -#define HAS_DIRENT - -/* Define HAS_DIRENT if you have /usr/include/dirent.h and the result of - readdir() is of type struct dirent *. - Otherwise, we'll load /usr/include/sys/dir.h, and readdir() is expected to - return a struct direct *. */ - -#define HAS_REWINDDIR - -/* Define HAS_REWINDDIR if you have rewinddir(). */ - -#define HAS_LOCKF - -/* Define HAS_LOCKF if the library provides the lockf() function. */ - -#define HAS_MKFIFO - -/* Define HAS_MKFIFO if the library provides the mkfifo() function. */ - -#define HAS_GETCWD -#define HAS_GETWD - -/* Define HAS_GETCWD if the library provides the getcwd() function. */ -/* Define HAS_GETWD if the library provides the getwd() function. */ - -#define HAS_GETPRIORITY - -/* Define HAS_GETPRIORITY if the library provides getpriority() and - setpriority(). Otherwise, we'll use nice(). */ - -#define HAS_UTIME -#define HAS_UTIMES - -/* Define HAS_UTIME if you have /usr/include/utime.h and the library - provides utime(). Define HAS_UTIMES if the library provides utimes(). */ - -#define HAS_DUP2 - -/* Define HAS_DUP2 if you have dup2(). */ - -#define HAS_FCHMOD - -/* Define HAS_FCHMOD if you have fchmod() and fchown(). */ - -#define HAS_TRUNCATE - -/* Define HAS_TRUNCATE if you have truncate() and - ftruncate(). */ - -#define HAS_SELECT - -/* Define HAS_SELECT if you have select(). */ - -#define HAS_SYS_SELECT_H - -/* Define HAS_SYS_SELECT_H if /usr/include/sys/select.h exists - and should be included before using select(). */ - -#define HAS_SYMLINK - -/* Define HAS_SYMLINK if you have symlink() and readlink() and lstat(). */ - -#define HAS_WAIT4 -#define HAS_WAITPID - -/* Define HAS_WAIT4 if you have wait4(). - Define HAS_WAITPID if you have waitpid(). */ - -#define HAS_GETGROUPS - -/* Define HAS_GETGROUPS if you have getgroups(). */ - -#define HAS_TERMIOS - -/* Define HAS_TERMIOS if you have /usr/include/termios.h and it is - Posix-compliant. */ - -#define HAS_ASYNC_IO - -/* Define HAS_ASYNC_IO if BSD-style asynchronous I/O are supported - (the process can request to be sent a SIGIO signal when a descriptor - is ready for reading). */ - -#define HAS_SETITIMER - -/* Define HAS_SETITIMER if you have setitimer(). */ - -#define HAS_GETHOSTNAME - -/* Define HAS_GETHOSTNAME if you have gethostname(). */ - -#define HAS_UNAME - -/* Define HAS_UNAME if you have uname(). */ - -#define HAS_GETTIMEOFDAY - -/* Define HAS_GETTIMEOFDAY if you have gettimeofday(). */ - -#define HAS_MKTIME - -/* Define HAS_MKTIME if you have mktime(). */ - -#define HAS_SETSID - -/* Define HAS_SETSID if you have setsid(). */ - -#define HAS_PUTENV - -/* Define HAS_PUTENV if you have putenv(). */ - -#define HAS_LOCALE - -/* Define HAS_LOCALE if you have the include file and the - setlocale() function. */ - -#define HAS_MMAP - -/* Define HAS_MMAP if you have the include file and the - functions mmap() and munmap(). */ - -#define HAS_GETHOSTBYNAME_R 6 - -/* Define HAS_GETHOSTBYNAME_R if gethostbyname_r() is available. - The value of this symbol is the number of arguments of - gethostbyname_r(): either 5 or 6 depending on prototype. - (5 is the Solaris version, 6 is the Linux version). */ - -#define HAS_GETHOSTBYADDR_R 8 - -/* Define HAS_GETHOSTBYADDR_R if gethostbyname_r() is available. - The value of this symbol is the number of arguments of - gethostbyaddr_r(): either 7 or 8 depending on prototype. - (7 is the Solaris version, 8 is the Linux version). */ diff --git a/configure b/configure deleted file mode 100755 index 8380147c4e..0000000000 --- a/configure +++ /dev/null @@ -1,1533 +0,0 @@ -#! /bin/sh - -######################################################################### -# # -# Objective Caml # -# # -# Xavier Leroy, projet Cristal, INRIA Rocquencourt # -# # -# Copyright 1999 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the GNU Library General Public License, with # -# the special exception on linking described in file LICENSE. # -# # -######################################################################### - -# $Id$ - -configure_options="$*" -prefix=/usr/local -bindir='' -libdir='' -mandir='' -manext=1 -host_type=unknown -ccoption='' -cclibs='' -curseslibs='' -mathlib='-lm' -dllib='' -x11_include_dir='' -x11_lib_dir='' -tk_wanted=yes -pthread_wanted=yes -tk_defs='' -tk_libs='' -tk_x11=yes -dl_defs='' -verbose=no -withcurses=yes -withsharedlibs=yes -binutils_dir='' -gcc_warnings="-Wall -Wno-unused" - -# Try to turn internationalization off, can cause config.guess to malfunction! -unset LANG -unset LC_ALL LC_CTYPE LC_COLLATE LC_MESSAGES LC_MONETARY LC_NUMERIC LC_TIME - -# Turn off some MacOS X debugging stuff, same reason -unset RC_TRACE_ARCHIVES RC_TRACE_DYLIBS RC_TRACE_PREBINDING_DISABLED - -# Parse command-line arguments - -while : ; do - case "$1" in - "") break;; - -prefix|--prefix) - prefix=$2; shift;; - -bindir|--bindir) - bindir=$2; shift;; - -libdir|--libdir) - libdir=$2; shift;; - -mandir|--mandir) - case "$2" in - */man[1-9ln]) - mandir=`echo $2 | sed -e 's|^\(.*\)/man.$|\1|'` - manext=`echo $2 | sed -e 's/^.*\(.\)$/\1/'`;; - *) - mandir=$2 - manext=1;; - esac - shift;; - -host*|--host*) - host_type=$2; shift;; - -cc*) - ccoption="$2"; shift;; - -lib*) - cclibs="$2 $cclibs"; shift;; - -no-curses) - withcurses=no;; - -no-shared-libs) - withsharedlibs=no;; - -x11include*|--x11include*) - x11_include_dir=$2; shift;; - -x11lib*|--x11lib*) - x11_lib_dir=$2; shift;; - -with-pthread*|--with-pthread*) - ;; # Ignored for backward compatibility - -no-pthread*|--no-pthread*) - pthread_wanted=no;; - -no-tk|--no-tk) - tk_wanted=no;; - -tkdefs*|--tkdefs*) - tk_defs=$2; shift;; - -tklibs*|--tklibs*) - tk_libs=$2; shift;; - -tk-no-x11|--tk-no-x11) - tk_x11=no;; - -dldefs*|--dldefs*) - dl_defs="$2"; shift;; - -dllibs*|--dllibs*) - dllib="$2"; shift;; - -binutils*|--binutils*) - binutils_dir=$2; shift;; - -verbose|--verbose) - verbose=yes;; - *) echo "Unknown option \"$1\"." 1>&2; exit 2;; - esac - shift -done - -# Sanity checks - -case "$prefix" in - /*) ;; - *) echo "The -prefix directory must be absolute." 1>&2; exit 2;; -esac -case "$bindir" in - /*) ;; - "") ;; - *) echo "The -bindir directory must be absolute." 1>&2; exit 2;; -esac -case "$libdir" in - /*) ;; - "") ;; - *) echo "The -libdir directory must be absolute." 1>&2; exit 2;; -esac -case "$mandir" in - /*) ;; - "") ;; - *) echo "The -mandir directory must be absolute." 1>&2; exit 2;; -esac - -# Generate the files - -cd config/auto-aux -rm -f s.h m.h Makefile -touch s.h m.h Makefile - -# Write options to Makefile - -echo "# generated by ./configure $configure_options" >> Makefile - -# Where to install - -echo "PREFIX=$prefix" >> Makefile -case "$bindir" in - "") echo 'BINDIR=$(PREFIX)/bin' >> Makefile - bindir="$prefix/bin";; - *) echo "BINDIR=$bindir" >> Makefile;; -esac -case "$libdir" in - "") echo 'LIBDIR=$(PREFIX)/lib/ocaml' >> Makefile - libdir="$prefix/lib/ocaml";; - *) echo "LIBDIR=$libdir" >> Makefile;; -esac -echo 'STUBLIBDIR=$(LIBDIR)/stublibs' >> Makefile -case "$mandir" in - "") echo 'MANDIR=$(PREFIX)/man' >> Makefile - mandir="$prefix/man";; - *) echo "MANDIR=$mandir" >> Makefile;; -esac -echo "MANEXT=$manext" >> Makefile - -# Determine the system type - -if test "$host_type" = "unknown"; then - if host_type=`../gnu/config.guess`; then :; else - echo "Cannot guess host type" - echo "You must specify one with the -host option" - exit 2 - fi -fi -if host=`../gnu/config.sub $host_type`; then :; else - echo "Please specify the correct host type with the -host option" - exit 2 -fi -echo "Configuring for a $host ..." - -# Do we have gcc? - -if test -z "$ccoption"; then - if sh ./searchpath gcc; then - echo "gcc found" - cc=gcc - else - cc=cc - fi -else - cc="$ccoption" -fi - -# Check for buggy versions of GCC - -buggycc="no" - -case "$host,$cc" in - i[3456]86-*-*,gcc*) - case `$cc --version` in - 2.7.2.1) cat <<'EOF' - -WARNING: you are using gcc version 2.7.2.1 on an Intel x86 processor. -This version of gcc is known to generate incorrect code for the -Objective Caml runtime system on some Intel x86 machines. (The symptom -is a crash of boot/ocamlc when compiling stdlib/pervasives.mli.) -In particular, the version of gcc 2.7.2.1 that comes with -Linux RedHat 4.x / Intel is affected by this problem. -Other Linux distributions might also be affected. -If you are using one of these configurations, you are strongly advised -to use another version of gcc, such as 2.95, which are -known to work well with Objective Caml. - -Press to proceed or to stop. -EOF - read reply;; - 2.96*) cat <<'EOF' - -WARNING: you are using gcc version 2.96 on an Intel x86 processor. -Certain patched versions of gcc 2.96 are known to generate incorrect -code for the Objective Caml runtime system. (The symptom is a segmentation -violation on boot/ocamlc.) Those incorrectly patched versions can be found -in RedHat 7.2 and Mandrake 8.0 and 8.1; other Linux distributions -might also be affected. (See bug #57760 on bugzilla.redhat.com) - -Auto-configuration will now select gcc compiler flags that work around -the problem. Still, if you observe segmentation faults while running -ocamlc or ocamlopt, you are advised to try another version of gcc, -such as 2.95.3 or 3.2. - -EOF - buggycc="gcc.2.96";; - - esac;; -esac - -# Configure the bytecode compiler - -bytecc="$cc" -bytecccompopts="" -bytecclinkopts="" -ostype="Unix" -exe="" - -case "$bytecc,$host" in - cc,*-*-nextstep*) - # GNU C extensions disabled, but __GNUC__ still defined! - bytecccompopts="-fno-defer-pop $gcc_warnings -U__GNUC__ -posix" - bytecclinkopts="-posix";; - *,*-*-rhapsody*) - # Almost the same as NeXTStep - bytecccompopts="-fno-defer-pop $gcc_warnings -DSHRINKED_GNUC" - mathlib="";; - *,*-*-darwin*) - # Almost the same as rhapsody - bytecccompopts="-fno-defer-pop -no-cpp-precomp $gcc_warnings" - mathlib="";; - *,*-*-beos*) - bytecccompopts="-fno-defer-pop $gcc_warnings" - # No -lm library - mathlib="";; - gcc,alpha*-*-osf*) - bytecccompopts="-fno-defer-pop $gcc_warnings" - if cc="$bytecc" sh ./hasgot -mieee; then - bytecccompopts="-mieee $bytecccompopts"; - fi - # Put code and static data in lower 4GB - bytecclinkopts="-Wl,-T,12000000 -Wl,-D,14000000" - # Tell gcc that we can use 32-bit code addresses for threaded code - echo "#define ARCH_CODE32" >> m.h;; - cc,alpha*-*-osf*) - bytecccompopts="-std1 -ieee";; - gcc,alpha*-*-linux*) - if cc="$bytecc" sh ./hasgot -mieee; then - bytecccompopts="-mieee $bytecccompopts"; - fi;; - cc,mips-*-irix6*) - # Add -n32 flag to ensure compatibility with native-code compiler - bytecccompopts="-n32" - # Turn off warning "unused library" - bytecclinkopts="-n32 -Wl,-woff,84";; - cc*,mips-*-irix6*) - # (For those who want to force "cc -64") - # Turn off warning "unused library" - bytecclinkopts="-Wl,-woff,84";; - *,alpha*-*-unicos*) - # For the Cray T3E - bytecccompopts="-DUMK";; - gcc*,powerpc-*-aix4.3*) - # Avoid name-space pollution by requiring Unix98-conformant includes - bytecccompopts="-fno-defer-pop $gcc_warnings -D_XOPEN_SOURCE=500";; - *,powerpc-*-aix4.3*) - bytecccompopts="-D_XOPEN_SOURCE=500";; - gcc*,*-*-cygwin*) - bytecccompopts="-fno-defer-pop $gcc_warnings -U_WIN32" - exe=".exe" - ostype="Cygwin";; - gcc*,x86_64-*-linux*) - bytecccompopts="-fno-defer-pop $gcc_warnings" - # Tell gcc that we can use 32-bit code addresses for threaded code - echo "#define ARCH_CODE32" >> m.h;; - gcc*) - bytecccompopts="-fno-defer-pop $gcc_warnings";; -esac - -# Configure compiler to use in further tests - -cc="$bytecc -O $bytecclinkopts" -export cc cclibs verbose - -# Check C compiler - -sh ./runtest ansi.c -case $? in - 0) echo "The C compiler is ANSI-compliant.";; - 1) echo "The C compiler $cc is not ANSI-compliant." - echo "You need an ANSI C compiler to build Objective Caml." - exit 2;; - *) echo "Unable to compile the test program." - echo "Make sure the C compiler $cc is properly installed." - exit 2;; -esac - -# Check the sizes of data types - -echo "Checking the sizes of integers and pointers..." -set `sh ./runtest sizes.c` -case "$2,$3" in - 4,4) echo "OK, this is a regular 32 bit architecture." - echo "#undef ARCH_SIXTYFOUR" >> m.h;; - 8,8) echo "Wow! A 64 bit architecture!" - echo "#define ARCH_SIXTYFOUR" >> m.h;; - *,8) echo "Wow! A 64 bit architecture!" - echo "Unfortunately, Objective Caml cannot work in the case" - echo "sizeof(long) != sizeof(long *)." - echo "Objective Caml won't run on this architecture." - exit 2;; - *,*) echo "This architecture seems to be neither 32 bits nor 64 bits." - echo "Objective Caml won't run on this architecture." - exit 2;; - *) echo "Unable to compile the test program." - echo "Make sure the C compiler $cc is properly installed." - exit 2;; -esac -if test $1 != 4 && test $2 != 4 && test $4 != 4; then - echo "Sorry, we can't find a 32-bit integer type" - echo "(sizeof(short) = $4, sizeof(int) = $1, sizeof(long) = $2)" - echo "Objective Caml won't run on this architecture." - exit 2 -fi - -echo "#define SIZEOF_INT $1" >> m.h -echo "#define SIZEOF_LONG $2" >> m.h -echo "#define SIZEOF_SHORT $4" >> m.h - -if test $2 = 8; then - echo "#define ARCH_INT64_TYPE long" >> m.h - echo "#define ARCH_UINT64_TYPE unsigned long" >> m.h - echo '#define ARCH_INT64_PRINTF_FORMAT "l"' >> m.h - int64_native=true -else - sh ./runtest longlong.c - case $? in - 0) echo "64-bit \"long long\" integer type found (printf with \"%ll\")." - echo "#define ARCH_INT64_TYPE long long" >> m.h - echo "#define ARCH_UINT64_TYPE unsigned long long" >> m.h - echo '#define ARCH_INT64_PRINTF_FORMAT "ll"' >> m.h - int64_native=true;; - 1) echo "64-bit \"long long\" integer type found (printf with \"%q\")." - echo "#define ARCH_INT64_TYPE long long" >> m.h - echo "#define ARCH_UINT64_TYPE unsigned long long" >> m.h - echo '#define ARCH_INT64_PRINTF_FORMAT "q"' >> m.h - int64_native=true;; - 2) echo "64-bit \"long long\" integer type found (but no printf)." - echo "#define ARCH_INT64_TYPE long long" >> m.h - echo "#define ARCH_UINT64_TYPE unsigned long long" >> m.h - echo '#undef ARCH_INT64_PRINTF_FORMAT' >> m.h - int64_native=true;; - *) echo "No suitable 64-bit integer type found, will use software emulation." - echo "#undef ARCH_INT64_TYPE" >> m.h - echo "#undef ARCH_UINT64_TYPE" >> m.h - echo '#undef ARCH_INT64_PRINTF_FORMAT' >> m.h - int64_native=false;; - esac -fi - -# Determine endianness - -sh ./runtest endian.c -case $? in - 0) echo "This is a big-endian architecture." - echo "#define ARCH_BIG_ENDIAN" >> m.h;; - 1) echo "This is a little-endian architecture." - echo "#undef ARCH_BIG_ENDIAN" >> m.h;; - 2) echo "This architecture seems to be neither big endian nor little endian." - echo "Objective Caml won't run on this architecture." - exit 2;; - *) echo "Something went wrong during endianness determination." - echo "You'll have to figure out endianness yourself" - echo "(option ARCH_BIG_ENDIAN in m.h).";; -esac - -# Determine alignment constraints - -case "$host" in - sparc-*-*|hppa*-*-*) - # On Sparc V9 with certain versions of gcc, determination of double - # alignment is not reliable (PR#1521), hence force it. - # Same goes for hppa. - echo "Doubles must be doubleword-aligned." - echo "#define ARCH_ALIGN_DOUBLE" >> m.h;; - *) - sh ./runtest dblalign.c - case $? in - 0) echo "Doubles can be word-aligned." - echo "#undef ARCH_ALIGN_DOUBLE" >> m.h;; - 1) echo "Doubles must be doubleword-aligned." - echo "#define ARCH_ALIGN_DOUBLE" >> m.h;; - *) echo "Something went wrong during alignment determination for doubles." - echo "I'm going to assume this architecture has alignment constraints over doubles." - echo "That's a safe bet: Objective Caml will work even if" - echo "this architecture has actually no alignment constraints." - echo "#define ARCH_ALIGN_DOUBLE" >> m.h;; - esac;; -esac - -if $int64_native; then - sh ./runtest int64align.c - case $? in - 0) echo "64-bit integers can be word-aligned." - echo "#undef ARCH_ALIGN_INT64" >> m.h;; - 1) echo "64-bit integers must be doubleword-aligned." - echo "#define ARCH_ALIGN_INT64" >> m.h;; - *) echo "Something went wrong during alignment determination for 64-bit integers." - echo "I'm going to assume this architecture has alignment constraints." - echo "That's a safe bet: Objective Caml will work even if" - echo "this architecture has actually no alignment constraints." - echo "#define ARCH_ALIGN_INT64" >> m.h;; - esac -else - echo "#undef ARCH_ALIGN_INT64" >> m.h -fi - -# Check semantics of division and modulus - -sh ./runtest divmod.c -case $? in - 0) echo "Native division and modulus have round-towards-zero semantics, will use them." - echo "#undef NONSTANDARD_DIV_MOD" >> m.h;; - 1) echo "Native division and modulus do not have round-towards-zero semantics, will use software emulation." - echo "#define NONSTANDARD_DIV_MOD" >> m.h;; - *) echo "Something went wrong while checking native division and modulus, please report it." - echo "#define NONSTANDARD_DIV_MOD" >> m.h;; -esac - -# Shared library support - -shared_libraries_supported=false -dl_needs_underscore=false -sharedcccompopts='' -mksharedlib='' -byteccrpath='' -mksharedlibrpath='' - -if test $withsharedlibs = "yes"; then - case "$host" in - *-*-linux-gnu|*-*-linux|*-*-freebsd[3-9]*) - sharedcccompopts="-fPIC" - mksharedlib="$bytecc -shared -o" - bytecclinkopts="$bytecclinkopts -Wl,-E" - byteccrpath="-Wl,-rpath," - mksharedlibrpath="-Wl,-rpath," - shared_libraries_supported=true;; - alpha*-*-osf*) - case "$bytecc" in - cc*) sharedcccompopts="";; - gcc*) sharedcccompopts="-fPIC";; - esac - mksharedlib="ld -shared -expect_unresolved '*' -o" - byteccrpath="-Wl,-rpath," - mksharedlibrpath="-rpath " - shared_libraries_supported=true;; - *-*-solaris2*) - case "$bytecc" in - gcc*) - sharedcccompopts="-fPIC" - if sh ./solaris-ld; then - mksharedlib="$bytecc -shared -o" - byteccrpath="-R" - mksharedlibrpath="-R" - else - mksharedlib="$bytecc -shared -o" - bytecclinkopts="$bytecclinkopts -Wl,-E" - byteccrpath="-Wl,-rpath," - mksharedlibrpath="-Wl,-rpath," - fi - shared_libraries_supported=true;; - *) - sharedcccompopts="-KPIC" - byteccrpath="-R" - mksharedlibrpath="-R" - mksharedlib="/usr/ccs/bin/ld -G -o" - shared_libraries_supported=true;; - esac;; - mips*-*-irix[56]*) - case "$bytecc" in - cc*) sharedcccompopts="";; - gcc*) sharedcccompopts="-fPIC";; - esac - mksharedlib="ld -shared -rdata_shared -o" - byteccrpath="-Wl,-rpath," - mksharedlibrpath="-rpath " - shared_libraries_supported=true;; - powerpc-apple-darwin*) - mksharedlib="cc -bundle -flat_namespace -undefined suppress -o" - bytecccompopts="$dl_defs $bytecccompopts" - #sharedcccompopts="-fnocommon" - dl_needs_underscore=true - shared_libraries_supported=true;; - esac -fi - -# Further machine-specific hacks - -case "$host" in - ia64-*-linux*|alpha*-*-linux*|x86_64-*-linux*) - echo "Will use mmap() instead of malloc() for allocation of major heap chunks." - echo "#define USE_MMAP_INSTEAD_OF_MALLOC" >> s.h;; -esac - -# Configure the native-code compiler - -arch=none -model=default -system=unknown - -case "$host" in - alpha*-*-osf*) arch=alpha; system=digital;; - alpha*-*-linux*) arch=alpha; system=linux;; - alpha*-*-freebsd*) arch=alpha; system=freebsd;; - alpha*-*-netbsd*) arch=alpha; system=netbsd;; - alpha*-*-openbsd*) arch=alpha; system=openbsd;; - sparc*-*-sunos4.*) arch=sparc; system=sunos;; - sparc*-*-solaris2.*) arch=sparc; system=solaris;; - sparc*-*-*bsd*) arch=sparc; system=bsd;; - sparc*-*-linux*) arch=sparc; system=linux;; - i[3456]86-*-linux*) arch=i386; system=linux_`sh ./runtest elf.c`;; - i[3456]86-*-*bsd*) arch=i386; system=bsd_`sh ./runtest elf.c`;; - i[3456]86-*-nextstep*) arch=i386; system=nextstep;; - i[3456]86-*-solaris*) arch=i386; system=solaris;; - i[3456]86-*-beos*) arch=i386; system=beos;; - i[3456]86-*-cygwin*) arch=i386; system=cygwin;; - mips-*-irix6*) arch=mips; system=irix;; - hppa1.1-*-hpux*) arch=hppa; system=hpux;; - hppa2.0*-*-hpux*) arch=hppa; system=hpux;; - hppa1.1-*-nextstep*) arch=hppa; system=nextstep;; - rs6000-*-aix*) arch=power; model=rs6000; system=aix;; - powerpc-*-aix*) arch=power; model=ppc; system=aix;; - powerpc-*-linux*) arch=power; model=ppc; system=elf;; - powerpc-*-netbsd*) arch=power; model=ppc; system=bsd;; - powerpc-*-rhapsody*) arch=power; model=ppc; system=rhapsody;; - powerpc-*-darwin*) arch=power; model=ppc; system=rhapsody;; - arm*-*-linux*) arch=arm; system=linux;; - ia64-*-linux*) arch=ia64; system=linux;; - x86_64-*-linux*) arch=amd64; system=linux;; -esac - -if test -z "$ccoption"; then - case "$arch,$system,$cc" in - alpha,digital,gcc*) nativecc=cc;; - mips,*,gcc*) nativecc=cc;; - *) nativecc="$bytecc";; - esac -else - nativecc="$ccoption" -fi - -nativecccompopts='' -nativecclinkopts='' -nativeccrpath="$byteccrpath" - -case "$arch,$nativecc,$system,$host_type" in - alpha,cc*,digital,*) nativecccompopts=-std1;; - mips,cc*,irix,*) nativecccompopts=-n32 - nativecclinkopts="-n32 -Wl,-woff,84";; - power,gcc*,aix,*aix4.3*) - nativecccompopts="$gcc_warnings -D_XOPEN_SOURCE=500";; - power,*,aix,*aix4.3*) - nativecccompopts="-D_XOPEN_SOURCE=500";; - *,*,nextstep,*) nativecccompopts="$gcc_warnings -U__GNUC__ -posix" - nativecclinkopts="-posix";; - *,*,rhapsody,*darwin6*) - nativecccompopts="$gcc_warnings -DDARWIN_VERSION_6 $dl_defs";; - *,*,rhapsody,*) nativecccompopts="$gcc_warnings -DSHRINKED_GNUC";; - *,gcc*,cygwin,*) nativecccompopts="$gcc_warnings -U_WIN32";; - *,gcc*,*,*) nativecccompopts="$gcc_warnings";; -esac - -asflags='' -aspp='$(AS)' -asppflags='' -asppprofflags='-DPROFILING' - -case "$arch,$model,$system" in - alpha,*,digital) asflags='-O2'; asppflags='-O2 -DSYS_$(SYSTEM)'; - asppprofflags='-pg -DPROFILING';; - alpha,*,linux) aspp='gcc'; asppflags='-c -DSYS_$(SYSTEM)';; - alpha,*,freebsd) aspp='gcc'; asppflags='-c -DSYS_$(SYSTEM)';; - alpha,*,netbsd) aspp='gcc'; asppflags='-c -DSYS_$(SYSTEM)';; - alpha,*,openbsd) aspp='gcc'; asppflags='-c -DSYS_$(SYSTEM)';; - mips,*,irix) asflags='-n32 -O2'; asppflags="$asflags";; - sparc,*,bsd) aspp='gcc'; asppflags='-c -DSYS_$(SYSTEM)';; - sparc,*,linux) aspp='gcc'; asppflags='-c -DSYS_$(SYSTEM)';; - sparc,*,*) case "$cc" in - gcc*) aspp='gcc'; asppflags='-c -DSYS_$(SYSTEM)';; - *) asppflags='-P -DSYS_$(SYSTEM)';; - esac;; - i386,*,solaris) aspp='/usr/ccs/bin/as'; asppflags='-P -DSYS_$(SYSTEM)';; - i386,*,*) aspp='gcc'; asppflags='-c -DSYS_$(SYSTEM)';; - hppa,*,*) aspp="$cc"; asppflags='-traditional -c -DSYS_$(SYSTEM)';; - power,rs6000,aix) asflags='-u -m pwr -w'; asppflags="$asflags";; - power,ppc,aix) asflags='-u -m ppc -w'; asppflags="$asflags";; - power,*,elf) aspp='gcc'; asppflags='-c';; - power,*,bsd) aspp='gcc'; asppflags='-c -DSYS_$(SYSTEM)';; - power,*,rhapsody) ;; - arm,*,linux) aspp='gcc'; asppflags='-c -DSYS_$(SYSTEM)';; - ia64,*,linux) asflags=-xexplicit - aspp='gcc'; asppflags='-c -DSYS_$(SYSTEM) -Wa,-xexplicit';; - amd64,*,*) aspp='gcc'; asppflags='-c -DSYS_$(SYSTEM)';; -esac - -cc_profile='-pg' -case "$arch,$model,$system" in - alpha,*,digital) profiling='prof';; - i386,*,linux_elf) profiling='prof';; - i386,*,bsd_elf) profiling='prof';; - sparc,*,solaris) - profiling='prof' - case "$nativecc" in gcc*) ;; *) cc_profile='-xpg';; esac;; - *) profiling='noprof';; -esac - -# Where are GNU binutils? - -binutils_objcopy='' -binutils_nm='' - -if test "$arch" != "none"; then - binutils_path="${binutils_dir}:${PATH}:/usr/libexec/binutils" - old_IFS="$IFS" - IFS=':' - for d in ${binutils_path}; do - if test -z "$d"; then continue; fi - if test -f "$d/objcopy" && test -f "$d/nm"; then - echo "objcopy and nm found in $d" - if test `$d/objcopy --help | grep -s -c 'redefine-sym'` -eq 0; then - echo "$d/objcopy does not support option --redefine-sym, discarded" - continue; - fi - if test `$d/nm --version | grep -s -c 'GNU nm'` -eq 0; then - echo "$d/nm is not from GNU binutils, discarded" - continue; - fi - binutils_objcopy="$d/objcopy" - binutils_nm="$d/nm" - break - fi - done - IFS="$old_IFS" -fi - -# Where is ranlib? - -if sh ./searchpath ranlib; then - echo "ranlib found" - echo "RANLIB=ranlib" >> Makefile - echo "RANLIBCMD=ranlib" >> Makefile -else - echo "ranlib not used" - echo "RANLIB=ar rs" >> Makefile - echo "RANLIBCMD=" >> Makefile -fi - -# Do #! scripts work? - -if (SHELL=/bin/sh; export SHELL; (./sharpbang || ./sharpbang2) >/dev/null); then - echo "#! appears to work in shell scripts" - case "$host" in - *-*-sunos*|*-*-unicos*) - echo "We won't use it, though, because under SunOS and Unicos it breaks" - echo "on pathnames longer than 30 characters" - echo "SHARPBANGSCRIPTS=false" >> Makefile;; - *-*-cygwin*) - echo "We won't use it, though, because of conflicts with .exe extension" - echo "under Cygwin" - echo "SHARPBANGSCRIPTS=false" >> Makefile;; - *) - echo "SHARPBANGSCRIPTS=true" >> Makefile;; - esac -else - echo "No support for #! in shell scripts" - echo "SHARPBANGSCRIPTS=false" >> Makefile -fi - -# Write the OS type (Unix or Cygwin) - -echo "#define OCAML_OS_TYPE \"$ostype\"" >> s.h -echo "#define OCAML_STDLIB_DIR \"$libdir\"" >> s.h - -# Use 64-bit file offset if possible - -bytecccompopts="$bytecccompopts -D_FILE_OFFSET_BITS=64" -nativecccompopts="$nativecccompopts -D_FILE_OFFSET_BITS=64" - -# Check the semantics of signal handlers - -if sh ./hasgot sigaction sigprocmask; then - echo "POSIX signal handling found." - echo "#define POSIX_SIGNALS" >> s.h -else - if sh ./runtest signals.c; then - echo "Signals have the BSD semantics." - echo "#define BSD_SIGNALS" >> s.h - else - echo "Signals have the System V semantics." - fi - if sh ./hasgot sigsetmask; then - echo "sigsetmask() found" - echo "#define HAS_SIGSETMASK" >> s.h - fi -fi - -# For the sys module - -if sh ./hasgot strerror; then - echo "strerror() found." - echo "#define HAS_STRERROR" >> s.h -fi - -if sh ./hasgot times; then - echo "times() found." - echo "#define HAS_TIMES" >> s.h -fi - -# For the terminfo module - -if test "$withcurses" = "yes"; then - for libs in "" "-lcurses" "-ltermcap" "-lcurses -ltermcap" "-lncurses"; do - if sh ./hasgot $libs tgetent tgetstr tgetnum tputs; then - echo "termcap functions found (with libraries '$libs')" - echo "#define HAS_TERMCAP" >> s.h - curseslibs="${libs}" - break - fi - done -fi - -# Configuration for the libraries - -otherlibraries="unix str num dynlink bigarray" - -# For the Unix library - -has_sockets=no -if sh ./hasgot socket socketpair bind listen accept connect; then - echo "You have BSD sockets." - echo "#define HAS_SOCKETS" >> s.h - has_sockets=yes -elif sh ./hasgot -lnsl -lsocket socket socketpair bind listen accept connect; then - echo "You have BSD sockets (with libraries '-lnsl -lsocket')" - cclibs="$cclibs -lnsl -lsocket" - echo "#define HAS_SOCKETS" >> s.h - has_sockets=yes -fi - -if sh ./hasgot -i sys/socket.h -t socklen_t; then - echo "socklen_t is defined in " - echo "#define HAS_SOCKLEN_T" >> s.h -fi - -if sh ./hasgot inet_aton; then - echo "inet_aton() found." - echo "#define HAS_INET_ATON" >> s.h -fi - -if sh ./hasgot -i unistd.h; then - echo "unistd.h found." - echo "#define HAS_UNISTD" >> s.h -fi - -if sh ./hasgot -i sys/types.h -t off_t; then - echo "off_t is defined in " - echo "#define HAS_OFF_T" >> s.h -fi - -if sh ./hasgot -i sys/types.h -i dirent.h; then - echo "dirent.h found." - echo "#define HAS_DIRENT" >> s.h -fi - -if sh ./hasgot rewinddir; then - echo "rewinddir() found." - echo "#define HAS_REWINDDIR" >> s.h -fi - -if sh ./hasgot lockf; then - echo "lockf() found." - echo "#define HAS_LOCKF" >> s.h -fi - -if sh ./hasgot mkfifo; then - echo "mkfifo() found." - echo "#define HAS_MKFIFO" >> s.h -fi - -if sh ./hasgot getcwd; then - echo "getcwd() found." - echo "#define HAS_GETCWD" >> s.h -fi - -if sh ./hasgot getwd; then - echo "getwd() found." - echo "#define HAS_GETWD" >> s.h -fi - -if sh ./hasgot getpriority setpriority; then - echo "getpriority() found." - echo "#define HAS_GETPRIORITY" >> s.h -fi - -if sh ./hasgot -i sys/types.h -i utime.h && sh ./hasgot utime; then - echo "utime() found." - echo "#define HAS_UTIME" >> s.h -fi - -if sh ./hasgot utimes; then - echo "utimes() found." - echo "#define HAS_UTIMES" >> s.h -fi - -if sh ./hasgot dup2; then - echo "dup2() found." - echo "#define HAS_DUP2" >> s.h -fi - -if sh ./hasgot fchmod fchown; then - echo "fchmod() found." - echo "#define HAS_FCHMOD" >> s.h -fi - -if sh ./hasgot truncate ftruncate; then - echo "truncate() found." - echo "#define HAS_TRUNCATE" >> s.h -fi - -select_include='' -if sh ./hasgot -i sys/types.h -i sys/select.h; then - echo "sys/select.h found." - echo "#define HAS_SYS_SELECT_H" >> s.h - select_include='-i sys/select.h' -fi - -has_select=no -if sh ./hasgot select && \ - sh ./hasgot -i sys/types.h $select_include -t fd_set ; then - echo "select() found." - echo "#define HAS_SELECT" >> s.h - has_select=yes -fi - -if sh ./hasgot symlink readlink lstat; then - echo "symlink() found." - echo "#define HAS_SYMLINK" >> s.h -fi - -has_wait=no -if sh ./hasgot waitpid; then - echo "waitpid() found." - echo "#define HAS_WAITPID" >> s.h - has_wait=yes -fi - -if sh ./hasgot wait4; then - echo "wait4() found." - echo "#define HAS_WAIT4" >> s.h - has_wait=yes -fi - -if sh ./hasgot -i limits.h && sh ./runtest getgroups.c; then - echo "getgroups() found." - echo "#define HAS_GETGROUPS" >> s.h -fi - -if sh ./hasgot -i termios.h && - sh ./hasgot tcgetattr tcsetattr tcsendbreak tcflush tcflow; then - echo "POSIX termios found." - echo "#define HAS_TERMIOS" >> s.h -fi - -# Async I/O under OSF1 3.x are so buggy that the test program hangs... -testasyncio=true -if test -f /usr/bin/uname; then - case "`/usr/bin/uname -s -r`" in - "OSF1 V3."*) testasyncio=false;; - esac -fi -if $testasyncio && sh ./runtest async_io.c; then - echo "Asynchronous I/O are supported." - echo "#define HAS_ASYNC_IO" >> s.h -fi - -has_setitimer=no -if sh ./hasgot setitimer; then - echo "setitimer() found." - echo "#define HAS_SETITIMER" >> s.h - has_setitimer="yes" -fi - -if sh ./hasgot gethostname; then - echo "gethostname() found." - echo "#define HAS_GETHOSTNAME" >> s.h -fi - -if sh ./hasgot -i sys/utsname.h && sh ./hasgot uname; then - echo "uname() found." - echo "#define HAS_UNAME" >> s.h -fi - -has_gettimeofday=no -if sh ./hasgot gettimeofday; then - echo "gettimeofday() found." - echo "#define HAS_GETTIMEOFDAY" >> s.h - has_gettimeofday="yes" -fi - -if sh ./hasgot mktime; then - echo "mktime() found." - echo "#define HAS_MKTIME" >> s.h -fi - -case "$host" in - *-*-cygwin*) ;; # setsid emulation under Cygwin breaks the debugger - *) if sh ./hasgot setsid; then - echo "setsid() found." - echo "#define HAS_SETSID" >> s.h - fi;; -esac - -if sh ./hasgot putenv; then - echo "putenv() found." - echo "#define HAS_PUTENV" >> s.h -fi - -if sh ./hasgot -i locale.h && sh ./hasgot setlocale; then - echo "setlocale() and found." - echo "#define HAS_LOCALE" >> s.h -fi - -if sh ./hasgot -i mach-o/dyld.h && sh ./hasgot NSLinkModule; then - echo "NSLinkModule() found. Using darwin dynamic loading." - echo "#define HAS_NSLINKMODULE" >> s.h -elif sh ./hasgot $dllib dlopen; then - echo "dlopen() found." -elif sh ./hasgot $dllib -ldl dlopen; then - echo "dlopen() found in -ldl." - dllib="$dllib -ldl" -else - shared_libraries_supported=no -fi - -if $shared_libraries_supported; then - echo "Dynamic loading of shared libraries is supported." - echo "#define SUPPORT_DYNAMIC_LINKING" >> s.h - if $dl_needs_underscore; then - echo '#define DL_NEEDS_UNDERSCORE' >>s.h - fi -fi - -if sh ./hasgot -i sys/types.h -i sys/mman.h && sh ./hasgot mmap munmap; then - echo "mmap() found." - echo "#define HAS_MMAP" >> s.h -fi - -nargs=none -for i in 5 6; do - if sh ./trycompile -DNUM_ARGS=${i} gethostbyname.c; then nargs=$i; break; fi -done -if test $nargs != "none"; then - echo "gethostbyname_r() found (with ${nargs} arguments)." - echo "#define HAS_GETHOSTBYNAME_R $nargs" >> s.h -fi - -nargs=none -for i in 7 8; do - if sh ./trycompile -DNUM_ARGS=${i} gethostbyaddr.c; then nargs=$i; break; fi -done -if test $nargs != "none"; then - echo "gethostbyaddr_r() found (with ${nargs} arguments)." - echo "#define HAS_GETHOSTBYADDR_R $nargs" >> s.h -fi - -# Determine if the debugger is supported - -if test "$has_sockets" = "yes"; then - echo "Replay debugger supported." - debugger="ocamldebugger" -else - echo "No replay debugger (missing system calls)" - debugger="" -fi - - -# Determine if system stack overflows can be detected - -case "$arch,$system" in - i386,linux_elf) - echo "System stack overflow can be detected." - echo "#define HAS_STACK_OVERFLOW_DETECTION" >> s.h;; - *) - echo "Cannot detect system stack overflow.";; -esac - -# Determine the target architecture for the "num" library - -case "$host" in - alpha*-*-*) bng_arch=alpha; bng_asm_level=1;; - i[3456]86-*-*) bng_arch=ia32 - if `sh ./trycompile ia32sse2.c` - then bng_asm_level=2 - else bng_asm_level=1 - fi;; - mips-*-*) bng_arch=mips; bng_asm_level=1;; - powerpc-*-*) bng_arch=ppc; bng_asm_level=1;; - sparc*-*-*) bng_arch=sparc; bng_asm_level=1;; - x86_64-*-*) bng_arch=amd64; bng_asm_level=1;; - *) bng_arch=generic; bng_asm_level=0;; -esac - -echo "BNG_ARCH=$bng_arch" >> Makefile -echo "BNG_ASM_LEVEL=$bng_asm_level" >> Makefile - -# Determine if the POSIX threads library is supported - -case "$host" in - *-*-solaris*) pthread_link="-lpthread -lposix4";; - *-*-freebsd*) pthread_link="-pthread";; - *-*-openbsd*) pthread_link="-pthread";; - *) pthread_link="-lpthread";; -esac - -if test "$pthread_wanted" = "yes"; then -if ./hasgot -i pthread.h $pthread_link pthread_self; then - echo "POSIX threads library supported." - otherlibraries="$otherlibraries systhreads" - bytecccompopts="$bytecccompopts -D_REENTRANT" - nativecccompopts="$nativecccompopts -D_REENTRANT" - case "$host" in - *-*-freebsd*) - bytecccompopts="$bytecccompopts -D_THREAD_SAFE" - nativecccompopts="$nativecccompopts -D_THREAD_SAFE";; - *-*-openbsd*) - bytecccompopts="$bytecccompopts -pthread" - asppflags="$asppflags -pthread" - nativecccompopts="$nativecccompopts -pthread";; - esac - echo "Options for linking with POSIX threads: $pthread_link" - echo "PTHREAD_LINK=$pthread_link" >> Makefile - if sh ./hasgot $pthread_link sigwait; then - echo "sigwait() found" - echo "#define HAS_SIGWAIT" >> s.h - fi -else - echo "POSIX threads not found." -fi -fi - -# Determine if the bytecode thread library is supported - -if test "$has_select" = "yes" \ -&& test "$has_setitimer" = "yes" \ -&& test "$has_gettimeofday" = "yes" \ -&& test "$has_wait" = "yes"; then - echo "Bytecode threads library supported." - otherlibraries="$otherlibraries threads" -else - echo "Bytecode threads library not supported (missing system calls)" -fi - -# Determine the location of X include files and libraries - -x11_include="not found" -x11_link="not found" - -for dir in \ - $x11_include_dir \ - \ - /usr/X11R6/include \ - /usr/include/X11R6 \ - /usr/local/X11R6/include \ - /usr/local/include/X11R6 \ - /opt/X11R6/include \ - \ - /usr/X11/include \ - /usr/include/X11 \ - /usr/local/X11/include \ - /usr/local/include/X11 \ - /opt/X11/include \ - \ - /usr/X11R5/include \ - /usr/include/X11R5 \ - /usr/local/X11R5/include \ - /usr/local/include/X11R5 \ - /usr/local/x11r5/include \ - /opt/X11R5/include \ - \ - /usr/X11R4/include \ - /usr/include/X11R4 \ - /usr/local/X11R4/include \ - /usr/local/include/X11R4 \ - \ - /usr/X386/include \ - /usr/x386/include \ - /usr/XFree86/include/X11 \ - \ - /usr/include \ - /usr/local/include \ - /usr/unsupported/include \ - /usr/athena/include \ - /usr/lpp/Xamples/include \ - \ - /usr/openwin/include \ - /usr/openwin/share/include \ - ; \ -do - if test -f $dir/X11/X.h; then - x11_include=$dir - break - fi -done - -if test "$x11_include" = "not found"; then - x11_try_lib_dir='' -else - x11_try_lib_dir=`echo $x11_include | sed -e 's|include|lib|'` -fi - -for dir in \ - $x11_lib_dir \ - $x11_try_lib_dir \ - \ - /usr/X11R6/lib \ - /usr/lib/X11R6 \ - /usr/local/X11R6/lib \ - /usr/local/lib/X11R6 \ - /opt/X11R6/lib \ - \ - /usr/X11/lib \ - /usr/lib/X11 \ - /usr/local/X11/lib \ - /usr/local/lib/X11 \ - /opt/X11/lib \ - \ - /usr/X11R5/lib \ - /usr/lib/X11R5 \ - /usr/local/X11R5/lib \ - /usr/local/lib/X11R5 \ - /usr/local/x11r5/lib \ - /opt/X11R5/lib \ - \ - /usr/X11R4/lib \ - /usr/lib/X11R4 \ - /usr/local/X11R4/lib \ - /usr/local/lib/X11R4 \ - \ - /usr/X386/lib \ - /usr/x386/lib \ - /usr/XFree86/lib/X11 \ - \ - /usr/lib \ - /usr/local/lib \ - /usr/unsupported/lib \ - /usr/athena/lib \ - /usr/lpp/Xamples/lib \ - /lib/usr/lib/X11 \ - \ - /usr/openwin/lib \ - /usr/openwin/share/lib \ - ; \ -do - if test -f $dir/libX11.a || \ - test -f $dir/libX11.so || \ - test -f $dir/libX11.dll.a || \ - test -f $dir/libX11.sa; then - if test $dir = /usr/lib; then - x11_link="-lX11" - else - x11_link="-L$dir -lX11" - x11_libs="-L$dir" - fi - break - fi -done - - -if test "$x11_include" = "not found" || test "$x11_link" = "not found" -then - echo "X11 not found, the \"graph\" library will not be supported." - x11_include="" -else - echo "Location of X11 include files: $x11_include/X11" - echo "Options for linking with X11: $x11_link" - otherlibraries="$otherlibraries graph" - if test "$x11_include" = "/usr/include"; then - x11_include="" - else - x11_include="-I$x11_include" - fi - echo "X11_INCLUDES=$x11_include" >> Makefile - echo "X11_LINK=$x11_link" >> Makefile -fi - -# See if we can compile the dbm library - -dbm_include="not found" -dbm_link="not found" -use_gdbm_ndbm=no - -for dir in /usr/include /usr/include/db1 /usr/include/gdbm; do - if test -f $dir/ndbm.h; then - dbm_include=$dir - if sh ./hasgot dbm_open; then - dbm_link="" - elif sh ./hasgot -lndbm dbm_open; then - dbm_link="-lndbm" - elif sh ./hasgot -ldb1 dbm_open; then - dbm_link="-ldb1" - elif sh ./hasgot -lgdbm dbm_open; then - dbm_link="-lgdbm" - elif sh ./hasgot -lgdbm_compat -lgdbm dbm_open; then - dbm_link="-lgdbm_compat -lgdbm" - fi - break - fi - if test -f $dir/gdbm-ndbm.h; then - dbm_include=$dir - use_gdbm_ndbm=yes - if sh ./hasgot -lgdbm_compat -lgdbm dbm_open; then - dbm_link="-lgdbm_compat -lgdbm" - fi - break - fi -done -if test "$dbm_include" = "not found" || test "$dbm_link" = "not found"; then - echo "NDBM not found, the \"dbm\" library will not be supported." -else - echo "NDBM found (in $dbm_include)" - if test "$dbm_include" = "/usr/include"; then - dbm_include="" - else - dbm_include="-I$dbm_include" - fi - echo "DBM_INCLUDES=$dbm_include" >> Makefile - echo "DBM_LINK=$dbm_link" >> Makefile - if test "$use_gdbm_ndbm" = "yes"; then - echo "#define DBM_USES_GDBM_NDBM" >> s.h - fi - otherlibraries="$otherlibraries dbm" -fi - -# Look for tcl/tk - -echo "Configuring LablTk..." - -if test $tk_wanted = no; then - has_tk=false -elif test $tk_x11 = no; then - has_tk=true -elif test "$x11_include" = "not found" || test "$x11_link" = "not found"; then - echo "X11 not found." - has_tk=false -else - tk_x11_include="$x11_include" - tk_x11_libs="$x11_libs -lX11" - has_tk=true -fi - -if test $has_tk = true; then - tcl_version='' - tcl_version=`sh ./runtest $tk_defs $tk_x11_include tclversion.c` - if test -z "$tcl_version" && test -z "$tk_defs"; then - tk_defs=-I/usr/local/include - tcl_version=`sh ./runtest $tk_defs $tk_x11_include tclversion.c` - fi - if test -z "$tcl_version"; then - tk_defs="-I/usr/local/include/tcl8.2 -I/usr/local/include/tk8.2" - tcl_version=`sh ./runtest $tk_defs $tk_x11_include tclversion.c` - fi - if test -z "$tcl_version"; then - tk_defs="-I/usr/local/include/tcl8.3 -I/usr/local/include/tk8.3" - tcl_version=`sh ./runtest $tk_defs $tk_x11_include tclversion.c` - fi - if test -z "$tcl_version"; then - tk_defs="-I/usr/local/include/tcl8.4 -I/usr/local/include/tk8.4" - tcl_version=`sh ./runtest $tk_defs $tk_x11_include tclversion.c` - fi - if test -z "$tcl_version"; then - tk_defs="-I/usr/include/tcl8.2 -I/usr/include/tk8.2" - tcl_version=`sh ./runtest $tk_defs $tk_x11_include tclversion.c` - fi - if test -z "$tcl_version"; then - tk_defs="-I/usr/include/tcl8.3 -I/usr/include/tk8.3" - tcl_version=`sh ./runtest $tk_defs $tk_x11_include tclversion.c` - fi - if test -z "$tcl_version"; then - tk_defs="-I/usr/include/tcl8.4 -I/usr/include/tk8.4" - tcl_version=`sh ./runtest $tk_defs $tk_x11_include tclversion.c` - fi - if test -z "$tcl_version"; then - tk_defs="-I/sw/include" - tcl_version=`sh ./runtest $tk_defs $tk_x11_include tclversion.c` - fi - if test -n "$tcl_version"; then - echo "tcl.h version $tcl_version found with \"$tk_defs\"." - case $tcl_version in - 7.5) tclmaj=7 tclmin=5 tkmaj=4 tkmin=1 ;; - 7.6) tclmaj=7 tclmin=6 tkmaj=4 tkmin=2 ;; - 8.0) tclmaj=8 tclmin=0 tkmaj=8 tkmin=0 ;; - 8.1) tclmaj=8 tclmin=1 tkmaj=8 tkmin=1 ;; - 8.2) tclmaj=8 tclmin=2 tkmaj=8 tkmin=2 ;; - 8.3) tclmaj=8 tclmin=3 tkmaj=8 tkmin=3 ;; - 8.4) tclmaj=8 tclmin=4 tkmaj=8 tkmin=4 ;; - *) echo "This version is not known."; has_tk=false ;; - esac - else - echo "tcl.h not found." - has_tk=false - fi -fi - -if test $has_tk = true; then - if sh ./hasgot $tk_x11_include $tk_defs -i tk.h; then - echo "tk.h found." - else - echo "tk.h not found." - has_tk=false - fi -fi - -tkauxlibs="$mathlib $dllib" -tcllib='' -tklib='' -if test $has_tk = true; then - if sh ./hasgot $tk_libs $tk_x11_libs $tkauxlibs Tcl_DoOneEvent - then tk_libs="$tk_libs $dllib" - elif sh ./hasgot $tk_libs -ltcl$tclmaj.$tclmin $tkauxlibs Tcl_DoOneEvent - then - tk_libs="$tk_libs -ltk$tkmaj.$tkmin -ltcl$tclmaj.$tclmin $dllib" - elif sh ./hasgot $tk_libs -ltcl$tclmaj$tclmin $tkauxlibs Tcl_DoOneEvent - then - tk_libs="$tk_libs -ltk$tkmaj$tkmin -ltcl$tclmaj$tclmin $dllib" - elif test -z "$tk_libs" && tk_libs=-L/usr/local/lib && \ - sh ./hasgot $tk_libs -ltcl$tclmaj.$tclmin $tkauxlibs Tcl_DoOneEvent - then - tk_libs="$tk_libs -ltk$tkmaj.$tkmin -ltcl$tclmaj.$tclmin $dllib" - elif sh ./hasgot $tk_libs -ltcl$tclmaj$tclmin $tkauxlibs Tcl_DoOneEvent - then - tk_libs="$tk_libs -ltk$tkmaj$tkmin -ltcl$tclmaj$tclmin $dllib" -# elif sh ./hasgot $tk_libs -ltcl $tkauxlibs Tcl_DoOneEvent; then -# tk_libs="$tk_libs -ltk -ltcl" - elif sh ./hasgot -L/sw/lib $tk_libs -ltcl$tclmaj.$tclmin $tkauxlibs \ - Tcl_DoOneEvent - then tk_libs="-L/sw/lib -ltk$tkmaj.$tkmin -ltcl$tclmaj.$tclmin $dllib" - else - echo "Tcl library not found." - has_tk=false - fi -fi -if test $has_tk = true; then - if sh ./hasgot $tk_libs $tk_x11_libs $tkauxlibs Tk_SetGrid; then - echo "Tcl/Tk libraries found." - elif sh ./hasgot -L/sw/lib $tk_libs $tk_x11_libs $tkauxlibs Tk_SetGrid; then - tk_libs="-L/sw/lib $tk_libs" - echo "Tcl/Tk libraries found." - else - echo "Tcl library found." - echo "Tk library not found." - has_tk=false - fi -fi - -if test $has_tk = true; then - if test $tk_x11 = yes; then - echo "TK_DEFS=$tk_defs "'$(X11_INCLUDES)' >> Makefile - echo "TK_LINK=$tk_libs "'$(X11_LINK)' >> Makefile - else - echo "TK_DEFS=$tk_defs" >> Makefile - echo "TK_LINK=$tk_libs" >> Makefile - fi - otherlibraries="$otherlibraries labltk" -else - echo "Configuration failed, LablTk will not be built." -fi - -# Camlp4 - -( -cd ../../camlp4/config -EXE=$exe ./configure_batch -bindir "$bindir" -libdir "$libdir" -mandir "$mandir" -ocaml-top ../.. > /dev/null -) - -# Final twiddling of compiler options to work around known bugs - -nativeccprofopts="$nativecccompopts" -case "$buggycc" in - gcc.2.96) - bytecccompopts="$bytecccompopts -fomit-frame-pointer" - nativecccompopts="$nativecccompopts -fomit-frame-pointer";; -esac - -# Finish generated files - -cclibs="$cclibs $mathlib" - -echo "BYTECC=$bytecc" >> Makefile -echo "BYTECCCOMPOPTS=$bytecccompopts" >> Makefile -echo "BYTECCLINKOPTS=$bytecclinkopts" >> Makefile -echo "BYTECCLIBS=$cclibs $dllib $curseslibs $pthread_link" >> Makefile -echo "BYTECCRPATH=$byteccrpath" >> Makefile -echo "EXE=$exe" >> Makefile -echo "SUPPORTS_SHARED_LIBRARIES=$shared_libraries_supported" >> Makefile -echo "SHAREDCCCOMPOPTS=$sharedcccompopts" >> Makefile -echo "MKSHAREDLIB=$mksharedlib" >> Makefile -echo "MKSHAREDLIBRPATH=$mksharedlibrpath" >> Makefile -echo "ARCH=$arch" >> Makefile -echo "MODEL=$model" >> Makefile -echo "SYSTEM=$system" >> Makefile -echo "NATIVECC=$nativecc" >> Makefile -echo "NATIVECCCOMPOPTS=$nativecccompopts" >> Makefile -echo "NATIVECCPROFOPTS=$nativeccprofopts" >> Makefile -echo "NATIVECCLINKOPTS=$nativecclinkopts" >> Makefile -echo "NATIVECCRPATH=$nativeccrpath" >> Makefile -echo "NATIVECCLIBS=$cclibs $dllib" >> Makefile -echo "ASFLAGS=$asflags" >> Makefile -echo "ASPP=$aspp" >> Makefile -echo "ASPPFLAGS=$asppflags" >> Makefile -echo "ASPPPROFFLAGS=$asppprofflags" >> Makefile -echo "PROFILING=$profiling" >> Makefile -echo "BINUTILS_OBJCOPY=$binutils_objcopy" >> Makefile -echo "BINUTILS_NM=$binutils_nm" >> Makefile -echo "DYNLINKOPTS=$dllib" >> Makefile -echo "OTHERLIBRARIES=$otherlibraries" >> Makefile -echo "DEBUGGER=$debugger" >> Makefile -echo "CC_PROFILE=$cc_profile" >> Makefile - -rm -f tst hasgot.c -rm -f ../m.h ../s.h ../Makefile -mv m.h s.h Makefile .. - -# Print a summary - -echo -echo "** Configuration summary **" -echo -echo "Directories where Objective Caml will be installed:" -echo " binaries.................. $bindir" -echo " standard library.......... $libdir" -echo " manual pages.............. $mandir (with extension .$manext)" - -echo "Configuration for the bytecode compiler:" -echo " C compiler used........... $bytecc" -echo " options for compiling..... $bytecccompopts" -echo " options for linking....... $bytecclinkopts $cclibs $dllib $curseslibs $pthread_link" -if $shared_libraries_supported; then -echo " shared libraries are supported" -echo " options for compiling..... $sharedcccompopts $bytecccompopts" -echo " command for building...... $mksharedlib lib.so $mksharedlibrpath/a/path objs" -else -echo " shared libraries not supported" -fi - -echo "Configuration for the native-code compiler:" -if test "$arch" = "none"; then - echo " (not supported on this platform)" -else - if test "$model" = "default"; then - echo " hardware architecture..... $arch" - else - echo " hardware architecture..... $arch ($model)" - fi - if test "$system" = "unknown"; then : ; else - echo " OS variant................ $system" - fi - echo " C compiler used........... $nativecc" - echo " options for compiling..... $nativecccompopts" - echo " options for linking....... $nativecclinkopts $cclibs" - echo " assembler ................ \$(AS) $asflags" - echo " preprocessed assembler ... $aspp $asppflags" - if test "$profiling" = "prof"; then - echo " profiling with gprof ..... supported" - else - echo " profiling with gprof ..... not supported" - fi - if test -n "$binutils_objcopy" && test -n "$binutils_nm"; then - echo " ocamlopt -pack ........... supported" - else - echo " ocamlopt -pack ........... not supported (no binutils)" - fi -fi - -if test "$debugger" = "ocamldebugger"; then - echo "Source-level replay debugger: supported" -else - echo "Source-level replay debugger: not supported" -fi - -echo "Additional libraries supported:" -echo " $otherlibraries" - -echo "Configuration for the \"num\" library:" -echo " target architecture ...... $bng_arch (asm level $bng_asm_level)" - -if test "$x11_include" != "not found" && test "$x11_lib" != "not found"; then -echo "Configuration for the \"graph\" library:" -echo " options for compiling .... $x11_include" -echo " options for linking ...... $x11_link" -fi - -if test $has_tk = true; then -echo "Configuration for the \"labltk\" library:" -echo " use tcl/tk version ....... $tcl_version" -echo " options for compiling .... $tk_defs" -echo " options for linking ...... $tk_libs" -else -echo "The \"labltk\" library: not found" -fi diff --git a/debugger/.cvsignore b/debugger/.cvsignore deleted file mode 100644 index b608cf5532..0000000000 --- a/debugger/.cvsignore +++ /dev/null @@ -1,4 +0,0 @@ -lexer.ml -parser.ml -parser.mli -ocamldebug diff --git a/debugger/.depend b/debugger/.depend deleted file mode 100644 index 3a303e336d..0000000000 --- a/debugger/.depend +++ /dev/null @@ -1,189 +0,0 @@ -breakpoints.cmi: ../bytecomp/instruct.cmi primitives.cmi -checkpoints.cmi: debugcom.cmi primitives.cmi -debugcom.cmi: primitives.cmi -envaux.cmi: ../typing/env.cmi ../bytecomp/instruct.cmi ../typing/path.cmi -eval.cmi: debugcom.cmi ../typing/env.cmi ../typing/ident.cmi \ - ../bytecomp/instruct.cmi ../parsing/longident.cmi parser_aux.cmi \ - ../typing/path.cmi ../typing/types.cmi -events.cmi: ../bytecomp/instruct.cmi -frames.cmi: ../bytecomp/instruct.cmi primitives.cmi -input_handling.cmi: primitives.cmi -loadprinter.cmi: ../otherlibs/dynlink/dynlink.cmi ../parsing/longident.cmi -parser.cmi: ../parsing/longident.cmi parser_aux.cmi -parser_aux.cmi: ../parsing/longident.cmi primitives.cmi -pattern_matching.cmi: debugcom.cmi parser_aux.cmi ../typing/typedtree.cmi -pos.cmi: ../bytecomp/instruct.cmi -primitives.cmi: ../otherlibs/unix/unix.cmi -printval.cmi: debugcom.cmi ../typing/env.cmi parser_aux.cmi \ - ../typing/path.cmi ../typing/types.cmi -program_loading.cmi: primitives.cmi -show_information.cmi: ../bytecomp/instruct.cmi -symbols.cmi: ../bytecomp/instruct.cmi -time_travel.cmi: primitives.cmi -unix_tools.cmi: ../otherlibs/unix/unix.cmi -breakpoints.cmo: checkpoints.cmi debugcom.cmi exec.cmi \ - ../bytecomp/instruct.cmi pos.cmi primitives.cmi source.cmi symbols.cmi \ - breakpoints.cmi -breakpoints.cmx: checkpoints.cmx debugcom.cmx exec.cmx \ - ../bytecomp/instruct.cmx pos.cmx primitives.cmx source.cmx symbols.cmx \ - breakpoints.cmi -checkpoints.cmo: debugcom.cmi int64ops.cmi primitives.cmi checkpoints.cmi -checkpoints.cmx: debugcom.cmx int64ops.cmx primitives.cmx checkpoints.cmi -command_line.cmo: breakpoints.cmi checkpoints.cmi ../utils/config.cmi \ - ../typing/ctype.cmi debugcom.cmi debugger_config.cmi envaux.cmi eval.cmi \ - events.cmi frames.cmi history.cmi input_handling.cmi \ - ../bytecomp/instruct.cmi int64ops.cmi ../parsing/lexer.cmi \ - loadprinter.cmi ../utils/misc.cmi parameters.cmi parser.cmi \ - parser_aux.cmi pos.cmi primitives.cmi printval.cmi program_loading.cmi \ - program_management.cmi show_information.cmi show_source.cmi source.cmi \ - symbols.cmi time_travel.cmi ../typing/types.cmi \ - ../otherlibs/unix/unix.cmi unix_tools.cmi command_line.cmi -command_line.cmx: breakpoints.cmx checkpoints.cmx ../utils/config.cmx \ - ../typing/ctype.cmx debugcom.cmx debugger_config.cmx envaux.cmx eval.cmx \ - events.cmx frames.cmx history.cmx input_handling.cmx \ - ../bytecomp/instruct.cmx int64ops.cmx ../parsing/lexer.cmx \ - loadprinter.cmx ../utils/misc.cmx parameters.cmx parser.cmx \ - parser_aux.cmi pos.cmx primitives.cmx printval.cmx program_loading.cmx \ - program_management.cmx show_information.cmx show_source.cmx source.cmx \ - symbols.cmx time_travel.cmx ../typing/types.cmx \ - ../otherlibs/unix/unix.cmx unix_tools.cmx command_line.cmi -debugcom.cmo: input_handling.cmi int64ops.cmi ../utils/misc.cmi \ - primitives.cmi debugcom.cmi -debugcom.cmx: input_handling.cmx int64ops.cmx ../utils/misc.cmx \ - primitives.cmx debugcom.cmi -debugger_config.cmo: int64ops.cmi debugger_config.cmi -debugger_config.cmx: int64ops.cmx debugger_config.cmi -envaux.cmo: ../typing/env.cmi ../bytecomp/instruct.cmi ../utils/misc.cmi \ - ../typing/mtype.cmi ../typing/path.cmi ../typing/printtyp.cmi \ - ../typing/types.cmi envaux.cmi -envaux.cmx: ../typing/env.cmx ../bytecomp/instruct.cmx ../utils/misc.cmx \ - ../typing/mtype.cmx ../typing/path.cmx ../typing/printtyp.cmx \ - ../typing/types.cmx envaux.cmi -eval.cmo: ../typing/btype.cmi ../typing/ctype.cmi debugcom.cmi \ - debugger_config.cmi ../typing/env.cmi frames.cmi ../typing/ident.cmi \ - ../bytecomp/instruct.cmi ../parsing/longident.cmi ../utils/misc.cmi \ - parser_aux.cmi ../typing/path.cmi ../typing/predef.cmi \ - ../typing/printtyp.cmi printval.cmi ../bytecomp/symtable.cmi \ - ../typing/types.cmi eval.cmi -eval.cmx: ../typing/btype.cmx ../typing/ctype.cmx debugcom.cmx \ - debugger_config.cmx ../typing/env.cmx frames.cmx ../typing/ident.cmx \ - ../bytecomp/instruct.cmx ../parsing/longident.cmx ../utils/misc.cmx \ - parser_aux.cmi ../typing/path.cmx ../typing/predef.cmx \ - ../typing/printtyp.cmx printval.cmx ../bytecomp/symtable.cmx \ - ../typing/types.cmx eval.cmi -events.cmo: checkpoints.cmi ../bytecomp/instruct.cmi primitives.cmi \ - symbols.cmi events.cmi -events.cmx: checkpoints.cmx ../bytecomp/instruct.cmx primitives.cmx \ - symbols.cmx events.cmi -exec.cmo: exec.cmi -exec.cmx: exec.cmi -frames.cmo: checkpoints.cmi debugcom.cmi events.cmi ../bytecomp/instruct.cmi \ - ../utils/misc.cmi primitives.cmi symbols.cmi frames.cmi -frames.cmx: checkpoints.cmx debugcom.cmx events.cmx ../bytecomp/instruct.cmx \ - ../utils/misc.cmx primitives.cmx symbols.cmx frames.cmi -history.cmo: checkpoints.cmi debugger_config.cmi int64ops.cmi \ - ../utils/misc.cmi primitives.cmi history.cmi -history.cmx: checkpoints.cmx debugger_config.cmx int64ops.cmx \ - ../utils/misc.cmx primitives.cmx history.cmi -input_handling.cmo: ../parsing/lexer.cmi primitives.cmi \ - ../otherlibs/unix/unix.cmi input_handling.cmi -input_handling.cmx: ../parsing/lexer.cmx primitives.cmx \ - ../otherlibs/unix/unix.cmx input_handling.cmi -int64ops.cmo: int64ops.cmi -int64ops.cmx: int64ops.cmi -lexer.cmo: parser.cmi primitives.cmi -lexer.cmx: parser.cmx primitives.cmx -loadprinter.cmo: ../utils/config.cmi ../typing/ctype.cmi debugger_config.cmi \ - ../otherlibs/dynlink/dynlink.cmi ../typing/env.cmi ../typing/ident.cmi \ - ../parsing/longident.cmi ../utils/misc.cmi ../typing/path.cmi \ - ../typing/printtyp.cmi printval.cmi ../bytecomp/symtable.cmi \ - ../typing/types.cmi loadprinter.cmi -loadprinter.cmx: ../utils/config.cmx ../typing/ctype.cmx debugger_config.cmx \ - ../otherlibs/dynlink/dynlink.cmx ../typing/env.cmx ../typing/ident.cmx \ - ../parsing/longident.cmx ../utils/misc.cmx ../typing/path.cmx \ - ../typing/printtyp.cmx printval.cmx ../bytecomp/symtable.cmx \ - ../typing/types.cmx loadprinter.cmi -main.cmo: checkpoints.cmi command_line.cmi ../utils/config.cmi \ - debugger_config.cmi exec.cmi frames.cmi input_handling.cmi \ - ../utils/misc.cmi parameters.cmi primitives.cmi program_management.cmi \ - show_information.cmi time_travel.cmi ../otherlibs/unix/unix.cmi \ - unix_tools.cmi -main.cmx: checkpoints.cmx command_line.cmx ../utils/config.cmx \ - debugger_config.cmx exec.cmx frames.cmx input_handling.cmx \ - ../utils/misc.cmx parameters.cmx primitives.cmx program_management.cmx \ - show_information.cmx time_travel.cmx ../otherlibs/unix/unix.cmx \ - unix_tools.cmx -parameters.cmo: ../utils/config.cmi envaux.cmi ../utils/misc.cmi \ - primitives.cmi parameters.cmi -parameters.cmx: ../utils/config.cmx envaux.cmx ../utils/misc.cmx \ - primitives.cmx parameters.cmi -parser.cmo: input_handling.cmi int64ops.cmi ../parsing/longident.cmi \ - parser_aux.cmi primitives.cmi parser.cmi -parser.cmx: input_handling.cmx int64ops.cmx ../parsing/longident.cmx \ - parser_aux.cmi primitives.cmx parser.cmi -pattern_matching.cmo: ../typing/ctype.cmi debugcom.cmi debugger_config.cmi \ - ../utils/misc.cmi parser_aux.cmi ../typing/typedtree.cmi \ - pattern_matching.cmi -pattern_matching.cmx: ../typing/ctype.cmx debugcom.cmx debugger_config.cmx \ - ../utils/misc.cmx parser_aux.cmi ../typing/typedtree.cmx \ - pattern_matching.cmi -pos.cmo: ../bytecomp/instruct.cmi primitives.cmi source.cmi pos.cmi -pos.cmx: ../bytecomp/instruct.cmx primitives.cmx source.cmx pos.cmi -primitives.cmo: ../otherlibs/unix/unix.cmi primitives.cmi -primitives.cmx: ../otherlibs/unix/unix.cmx primitives.cmi -printval.cmo: debugcom.cmi ../toplevel/genprintval.cmi ../utils/misc.cmi \ - ../typing/oprint.cmi ../typing/outcometree.cmi parser_aux.cmi \ - ../typing/path.cmi ../typing/printtyp.cmi ../bytecomp/symtable.cmi \ - ../typing/types.cmi printval.cmi -printval.cmx: debugcom.cmx ../toplevel/genprintval.cmx ../utils/misc.cmx \ - ../typing/oprint.cmx ../typing/outcometree.cmi parser_aux.cmi \ - ../typing/path.cmx ../typing/printtyp.cmx ../bytecomp/symtable.cmx \ - ../typing/types.cmx printval.cmi -program_loading.cmo: debugger_config.cmi input_handling.cmi ../utils/misc.cmi \ - parameters.cmi primitives.cmi ../otherlibs/unix/unix.cmi unix_tools.cmi \ - program_loading.cmi -program_loading.cmx: debugger_config.cmx input_handling.cmx ../utils/misc.cmx \ - parameters.cmx primitives.cmx ../otherlibs/unix/unix.cmx unix_tools.cmx \ - program_loading.cmi -program_management.cmo: breakpoints.cmi debugcom.cmi debugger_config.cmi \ - history.cmi input_handling.cmi ../bytecomp/instruct.cmi int64ops.cmi \ - ../utils/misc.cmi parameters.cmi primitives.cmi program_loading.cmi \ - symbols.cmi time_travel.cmi ../otherlibs/unix/unix.cmi unix_tools.cmi \ - program_management.cmi -program_management.cmx: breakpoints.cmx debugcom.cmx debugger_config.cmx \ - history.cmx input_handling.cmx ../bytecomp/instruct.cmx int64ops.cmx \ - ../utils/misc.cmx parameters.cmx primitives.cmx program_loading.cmx \ - symbols.cmx time_travel.cmx ../otherlibs/unix/unix.cmx unix_tools.cmx \ - program_management.cmi -show_information.cmo: breakpoints.cmi checkpoints.cmi debugcom.cmi events.cmi \ - frames.cmi ../bytecomp/instruct.cmi ../utils/misc.cmi primitives.cmi \ - printval.cmi show_source.cmi symbols.cmi show_information.cmi -show_information.cmx: breakpoints.cmx checkpoints.cmx debugcom.cmx events.cmx \ - frames.cmx ../bytecomp/instruct.cmx ../utils/misc.cmx primitives.cmx \ - printval.cmx show_source.cmx symbols.cmx show_information.cmi -show_source.cmo: debugger_config.cmi ../utils/misc.cmi parameters.cmi \ - primitives.cmi source.cmi show_source.cmi -show_source.cmx: debugger_config.cmx ../utils/misc.cmx parameters.cmx \ - primitives.cmx source.cmx show_source.cmi -source.cmo: ../utils/config.cmi ../utils/misc.cmi primitives.cmi source.cmi -source.cmx: ../utils/config.cmx ../utils/misc.cmx primitives.cmx source.cmi -symbols.cmo: ../bytecomp/bytesections.cmi debugcom.cmi debugger_config.cmi \ - ../bytecomp/instruct.cmi primitives.cmi ../bytecomp/symtable.cmi \ - symbols.cmi -symbols.cmx: ../bytecomp/bytesections.cmx debugcom.cmx debugger_config.cmx \ - ../bytecomp/instruct.cmx primitives.cmx ../bytecomp/symtable.cmx \ - symbols.cmi -time_travel.cmo: breakpoints.cmi checkpoints.cmi debugcom.cmi \ - debugger_config.cmi events.cmi exec.cmi input_handling.cmi \ - ../bytecomp/instruct.cmi int64ops.cmi ../utils/misc.cmi primitives.cmi \ - program_loading.cmi symbols.cmi trap_barrier.cmi time_travel.cmi -time_travel.cmx: breakpoints.cmx checkpoints.cmx debugcom.cmx \ - debugger_config.cmx events.cmx exec.cmx input_handling.cmx \ - ../bytecomp/instruct.cmx int64ops.cmx ../utils/misc.cmx primitives.cmx \ - program_loading.cmx symbols.cmx trap_barrier.cmx time_travel.cmi -trap_barrier.cmo: checkpoints.cmi debugcom.cmi exec.cmi trap_barrier.cmi -trap_barrier.cmx: checkpoints.cmx debugcom.cmx exec.cmx trap_barrier.cmi -unix_tools.cmo: ../utils/misc.cmi primitives.cmi ../otherlibs/unix/unix.cmi \ - unix_tools.cmi -unix_tools.cmx: ../utils/misc.cmx primitives.cmx ../otherlibs/unix/unix.cmx \ - unix_tools.cmi diff --git a/debugger/Makefile b/debugger/Makefile deleted file mode 100644 index 674fda9c7a..0000000000 --- a/debugger/Makefile +++ /dev/null @@ -1,114 +0,0 @@ -######################################################################### -# # -# Objective Caml # -# # -# Xavier Leroy, projet Cristal, INRIA Rocquencourt # -# # -# Copyright 1999 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### - -# $Id$ - -include ../config/Makefile - -CAMLC=../ocamlcomp.sh -COMPFLAGS=-warn-error A $(INCLUDES) -LINKFLAGS=-linkall -I ../otherlibs/unix -CAMLYACC=../boot/ocamlyacc -YACCFLAGS= -CAMLLEX=../boot/ocamlrun ../boot/ocamllex -CAMLDEP=../boot/ocamlrun ../tools/ocamldep -DEPFLAGS=$(INCLUDES) - -INCLUDES=\ - -I ../utils -I ../parsing -I ../typing -I ../bytecomp -I ../toplevel \ - -I ../otherlibs/unix -I ../otherlibs/dynlink - -OTHEROBJS=\ - ../otherlibs/unix/unix.cma \ - ../utils/misc.cmo ../utils/config.cmo \ - ../utils/tbl.cmo ../utils/clflags.cmo ../utils/consistbl.cmo \ - ../parsing/longident.cmo \ - ../typing/ident.cmo ../typing/path.cmo ../typing/types.cmo \ - ../typing/btype.cmo ../typing/primitive.cmo ../typing/typedtree.cmo \ - ../typing/subst.cmo ../typing/predef.cmo \ - ../typing/datarepr.cmo ../typing/env.cmo ../typing/oprint.cmo \ - ../typing/ctype.cmo ../typing/printtyp.cmo ../typing/mtype.cmo \ - ../bytecomp/runtimedef.cmo ../bytecomp/bytesections.cmo \ - ../bytecomp/dll.cmo ../bytecomp/symtable.cmo \ - ../bytecomp/opcodes.cmo ../bytecomp/meta.cmo \ - ../toplevel/genprintval.cmo \ - ../otherlibs/dynlink/dynlink.cmo - -OBJS=\ - int64ops.cmo \ - primitives.cmo \ - unix_tools.cmo \ - debugger_config.cmo \ - envaux.cmo \ - parameters.cmo \ - lexer.cmo \ - input_handling.cmo \ - debugcom.cmo \ - exec.cmo \ - source.cmo \ - pos.cmo \ - checkpoints.cmo \ - symbols.cmo \ - events.cmo \ - breakpoints.cmo \ - trap_barrier.cmo \ - history.cmo \ - program_loading.cmo \ - printval.cmo \ - show_source.cmo \ - time_travel.cmo \ - program_management.cmo \ - frames.cmo \ - eval.cmo \ - show_information.cmo \ - loadprinter.cmo \ - parser.cmo \ - command_line.cmo \ - main.cmo - -all: ocamldebug$(EXE) - -ocamldebug$(EXE): $(OBJS) $(OTHEROBJS) - $(CAMLC) $(LINKFLAGS) -o ocamldebug$(EXE) -linkall $(OTHEROBJS) $(OBJS) - -install: - cp ocamldebug$(EXE) $(BINDIR)/ocamldebug$(EXE) - -clean:: - rm -f ocamldebug$(EXE) - rm -f *.cmo *.cmi - -.SUFFIXES: -.SUFFIXES: .ml .cmo .mli .cmi - -.ml.cmo: - $(CAMLC) -c $(COMPFLAGS) $< - -.mli.cmi: - $(CAMLC) -c $(COMPFLAGS) $< - -depend: beforedepend - $(CAMLDEP) $(DEPFLAGS) *.mli *.ml > .depend - -lexer.ml: lexer.mll - $(CAMLLEX) lexer.mll -clean:: - rm -f lexer.ml -beforedepend:: lexer.ml - -parser.ml parser.mli: parser.mly - $(CAMLYACC) parser.mly -clean:: - rm -f parser.ml parser.mli -beforedepend:: parser.ml parser.mli - -include .depend diff --git a/debugger/breakpoints.ml b/debugger/breakpoints.ml deleted file mode 100644 index 09695d87ba..0000000000 --- a/debugger/breakpoints.ml +++ /dev/null @@ -1,222 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(******************************* Breakpoints ***************************) - -open Checkpoints -open Debugcom -open Instruct -open Primitives -open Printf -open Source - -(*** Debugging. ***) -let debug_breakpoints = ref false - -(*** Data. ***) - -(* Number of the last added breakpoint. *) -let breakpoint_number = ref 0 - -(* Breakpoint number -> event. *) -let breakpoints = ref ([] : (int * debug_event) list) - -(* Program counter -> breakpoint count. *) -let positions = ref ([] : (int * int ref) list) - -(* Versions of the breakpoint list. *) -let current_version = ref 0 -let max_version = ref 0 - -(*** Miscellaneous. ***) - -(* Mark breakpoints as installed in current checkpoint. *) -let copy_breakpoints () = - !current_checkpoint.c_breakpoints <- !positions; - !current_checkpoint.c_breakpoint_version <- !current_version - -(* Announce a new version of the breakpoint list. *) -let new_version () = - incr max_version; - current_version := !max_version - -(*** Information about breakpoints. ***) - -let breakpoints_count () = - List.length !breakpoints - -(* List of breakpoints at `pc'. *) -let rec breakpoints_at_pc pc = - begin try - let ev = Symbols.event_at_pc pc in - match ev.ev_repr with - Event_child {contents = pc'} -> breakpoints_at_pc pc' - | _ -> [] - with Not_found -> - [] - end - @ - List.map fst (filter (function (_, {ev_pos = pos}) -> pos = pc) !breakpoints) - -(* Is there a breakpoint at `pc' ? *) -let breakpoint_at_pc pc = - breakpoints_at_pc pc <> [] - -(*** Set and remove breakpoints ***) - -(* Remove all breakpoints. *) -let remove_breakpoints pos = - if !debug_breakpoints then - (print_string "Removing breakpoints..."; print_newline ()); - List.iter - (function (pos, _) -> - if !debug_breakpoints then begin - print_int pos; - print_newline() - end; - reset_instr pos; - Symbols.set_event_at_pc pos) - pos - -(* Set all breakpoints. *) -let set_breakpoints pos = - if !debug_breakpoints then - (print_string "Setting breakpoints..."; print_newline ()); - List.iter - (function (pos, _) -> - if !debug_breakpoints then begin - print_int pos; - print_newline() - end; - set_breakpoint pos) - pos - -(* Ensure the current version in installed in current checkpoint. *) -let update_breakpoints () = - if !debug_breakpoints then begin - prerr_string "Updating breakpoints... "; - prerr_int !current_checkpoint.c_breakpoint_version; - prerr_string " "; - prerr_int !current_version; - prerr_endline "" - end; - if !current_checkpoint.c_breakpoint_version <> !current_version then - Exec.protect - (function () -> - remove_breakpoints !current_checkpoint.c_breakpoints; - set_breakpoints !positions; - copy_breakpoints ()) - -let change_version version pos = - Exec.protect - (function () -> - current_version := version; - positions := pos) - -(* Execute given function with no breakpoint in current checkpoint. *) -(* --- `goto' runs faster this way (does not stop on each breakpoint). *) -let execute_without_breakpoints f = - let version = !current_version - and pos = !positions - in - change_version 0 []; - try - f (); - change_version version pos - with - x -> - change_version version pos - -(* Add a position in the position list. *) -(* Change version if necessary. *) -let insert_position pos = - try - incr (List.assoc pos !positions) - with - Not_found -> - positions := (pos, ref 1) :: !positions; - new_version () - -(* Remove a position in the position list. *) -(* Change version if necessary. *) -let remove_position pos = - let count = List.assoc pos !positions in - decr count; - if !count = 0 then begin - positions := assoc_remove !positions pos; - new_version () - end - -(* Insert a new breakpoint in lists. *) -let rec new_breakpoint = - function - {ev_repr = Event_child pc} -> - new_breakpoint (Symbols.any_event_at_pc !pc) - | event -> - Exec.protect - (function () -> - incr breakpoint_number; - insert_position event.ev_pos; - breakpoints := (!breakpoint_number, event) :: !breakpoints); - printf "Breakpoint %d at %d : %s" !breakpoint_number event.ev_pos - (Pos.get_desc event); - print_newline () - -(* Remove a breakpoint from lists. *) -let remove_breakpoint number = - try - let pos = (List.assoc number !breakpoints).ev_pos in - Exec.protect - (function () -> - breakpoints := assoc_remove !breakpoints number; - remove_position pos) - with - Not_found -> - prerr_endline ("No breakpoint number " ^ (string_of_int number) ^ "."); - raise Not_found - -let remove_all_breakpoints () = - List.iter (function (number, _) -> remove_breakpoint number) !breakpoints - -(*** Temporary breakpoints. ***) - -(* Temporary breakpoint position. *) -let temporary_breakpoint_position = ref (None : int option) - -(* Execute `funct' with a breakpoint added at `pc'. *) -(* --- Used by `finish'. *) -let exec_with_temporary_breakpoint pc funct = - let previous_version = !current_version in - let remove () = - temporary_breakpoint_position := None; - current_version := previous_version; - let count = List.assoc pc !positions in - decr count; - if !count = 0 then begin - positions := assoc_remove !positions pc; - reset_instr pc; - Symbols.set_event_at_pc pc - end - - in - Exec.protect (function () -> insert_position pc); - temporary_breakpoint_position := Some pc; - try - funct (); - Exec.protect remove - with - x -> - Exec.protect remove; - raise x diff --git a/debugger/breakpoints.mli b/debugger/breakpoints.mli deleted file mode 100644 index 091f609981..0000000000 --- a/debugger/breakpoints.mli +++ /dev/null @@ -1,61 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(******************************* Breakpoints ***************************) - -open Primitives -open Instruct - -(*** Debugging. ***) -val debug_breakpoints : bool ref - -(*** Information about breakpoints. ***) - -val breakpoints_count : unit -> int - -(* Breakpoint number -> debug_event_kind. *) -val breakpoints : (int * debug_event) list ref - -(* Is there a breakpoint at `pc' ? *) -val breakpoint_at_pc : int -> bool - -(* List of breakpoints at `pc'. *) -val breakpoints_at_pc : int -> int list - -(*** Set and remove breakpoints ***) - -(* Ensure the current version in installed in current checkpoint. *) -val update_breakpoints : unit -> unit - -(* Execute given function with no breakpoint in current checkpoint. *) -(* --- `goto' run faster so (does not stop on each breakpoint). *) -val execute_without_breakpoints : (unit -> unit) -> unit - -(* Insert a new breakpoint in lists. *) -val new_breakpoint : debug_event -> unit - -(* Remove a breakpoint from lists. *) -val remove_breakpoint : int -> unit - -val remove_all_breakpoints : unit -> unit - -(*** Temporary breakpoints. ***) - -(* Temporary breakpoint position. *) -val temporary_breakpoint_position : int option ref - -(* Execute `funct' with a breakpoint added at `pc'. *) -(* --- Used by `finish'. *) -val exec_with_temporary_breakpoint : int -> (unit -> unit) -> unit diff --git a/debugger/checkpoints.ml b/debugger/checkpoints.ml deleted file mode 100644 index ffcff35e36..0000000000 --- a/debugger/checkpoints.ml +++ /dev/null @@ -1,85 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(*************************** Checkpoints *******************************) - -open Int64ops -open Debugcom -open Primitives - -(*** A type for checkpoints. ***) - -type checkpoint_state = - C_stopped - | C_running of int64 - -(* `c_valid' is true if and only if the corresponding - * process is connected to the debugger. - * `c_parent' is the checkpoint whose process is parent - * of the checkpoint one (`root' if no parent). - * c_pid = -2 for root pseudo-checkpoint. - * c_pid = 0 for ghost checkpoints. - * c_pid = -1 for kill checkpoints. - *) -type checkpoint = { - mutable c_time : int64; - mutable c_pid : int; - mutable c_fd : io_channel; - mutable c_valid : bool; - mutable c_report : report option; - mutable c_state : checkpoint_state; - mutable c_parent : checkpoint; - mutable c_breakpoint_version : int; - mutable c_breakpoints : (int * int ref) list; - mutable c_trap_barrier : int - } - -(*** Pseudo-checkpoint `root'. ***) -(* --- Parents of all checkpoints which have no parent. *) -let rec root = { - c_time = _0; - c_pid = -2; - c_fd = std_io; - c_valid = false; - c_report = None; - c_state = C_stopped; - c_parent = root; - c_breakpoint_version = 0; - c_breakpoints = []; - c_trap_barrier = 0 - } - -(*** Current state ***) -let checkpoints = - ref ([] : checkpoint list) - -let current_checkpoint = - ref root - -let current_time () = - !current_checkpoint.c_time - -let current_report () = - !current_checkpoint.c_report - -let current_pc () = - match current_report () with - None | Some {rep_type = Exited | Uncaught_exc} -> None - | Some {rep_program_pointer = pc } -> Some pc - -let current_pc_sp () = - match current_report () with - None | Some {rep_type = Exited | Uncaught_exc} -> None - | Some {rep_program_pointer = pc; rep_stack_pointer = sp } -> Some (pc, sp) diff --git a/debugger/checkpoints.mli b/debugger/checkpoints.mli deleted file mode 100644 index 17c1037aa2..0000000000 --- a/debugger/checkpoints.mli +++ /dev/null @@ -1,58 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(***************************** Checkpoints *****************************) - -open Primitives -open Debugcom - -(*** A type for checkpoints. ***) - -type checkpoint_state = - C_stopped - | C_running of int64 - -(* `c_valid' is true if and only if the corresponding - * process is connected to the debugger. - * `c_parent' is the checkpoint whose process is parent - * of the checkpoint one (`root' if no parent). - * c_pid = 2 for root pseudo-checkpoint. - * c_pid = 0 for ghost checkpoints. - * c_pid = -1 for kill checkpoints. - *) -type checkpoint = - {mutable c_time : int64; - mutable c_pid : int; - mutable c_fd : io_channel; - mutable c_valid : bool; - mutable c_report : report option; - mutable c_state : checkpoint_state; - mutable c_parent : checkpoint; - mutable c_breakpoint_version : int; - mutable c_breakpoints : (int * int ref) list; - mutable c_trap_barrier : int} - -(*** Pseudo-checkpoint `root'. ***) -(* --- Parents of all checkpoints which have no parent. *) -val root : checkpoint - -(*** Current state ***) -val checkpoints : checkpoint list ref -val current_checkpoint : checkpoint ref - -val current_time : unit -> int64 -val current_report : unit -> report option -val current_pc : unit -> int option -val current_pc_sp : unit -> (int * int) option diff --git a/debugger/command_line.ml b/debugger/command_line.ml deleted file mode 100644 index 7651b53f32..0000000000 --- a/debugger/command_line.ml +++ /dev/null @@ -1,1084 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(************************ Reading and executing commands ***************) - -open Int64ops -open Format -open Misc -open Instruct -open Unix -open Debugger_config -open Types -open Primitives -open Unix_tools -open Parser -open Parser_aux -open Lexer -open Input_handling -open Debugcom -open Program_loading -open Program_management -open Lexing -open Parameters -open Show_source -open Show_information -open Time_travel -open Events -open Symbols -open Source -open Breakpoints -open Checkpoints -open Frames -open Printval - -(** Instructions, variables and infos lists. **) -type dbg_instruction = - { instr_name: string; (* Name of command *) - instr_prio: bool; (* Has priority *) - instr_action: formatter -> lexbuf -> unit; - (* What to do *) - instr_repeat: bool; (* Can be repeated *) - instr_help: string } (* Help message *) - -let instruction_list = ref ([] : dbg_instruction list) - -type dbg_variable = - { var_name: string; (* Name of variable *) - var_action: (lexbuf -> unit) * (formatter -> unit); - (* Reading, writing fns *) - var_help: string } (* Help message *) - -let variable_list = ref ([] : dbg_variable list) - -type dbg_info = - { info_name: string; (* Name of info *) - info_action: lexbuf -> unit; (* What to do *) - info_help: string } (* Help message *) - -let info_list = ref ([] : dbg_info list) - -(** Utilities. **) -let error text = - eprintf "%s@." text; - raise Toplevel - -let eol = - end_of_line Lexer.lexeme - -let matching_elements list name instr = - filter (function a -> isprefix instr (name a)) !list - -let all_matching_instructions = - matching_elements instruction_list (fun i -> i.instr_name) - -(* itz 04-21-96 don't do priority completion in emacs mode *) -(* XL 25-02-97 why? I find it very confusing. *) - -let matching_instructions instr = - let all = all_matching_instructions instr in - let prio = filter (fun i -> i.instr_prio) all in - if prio = [] then all else prio - -let matching_variables = - matching_elements variable_list (fun v -> v.var_name) - -let matching_infos = - matching_elements info_list (fun i -> i.info_name) - -let find_ident name matcher action alternative ppf lexbuf = - match identifier_or_eol Lexer.lexeme lexbuf with - | None -> alternative ppf - | Some ident -> - match matcher ident with - | [] -> error ("Unknown " ^ name ^ ".") - | [a] -> action a ppf lexbuf - | _ -> error ("Ambiguous " ^ name ^ ".") - -let find_variable action alternative ppf lexbuf = - find_ident "variable name" matching_variables action alternative ppf lexbuf - -let find_info action alternative ppf lexbuf = - find_ident "info command" matching_infos action alternative ppf lexbuf - -let add_breakpoint_at_pc pc = - try - new_breakpoint (any_event_at_pc pc) - with - | Not_found -> - eprintf "Can't add breakpoint at pc %i : no event there.@." pc; - raise Toplevel - -let add_breakpoint_after_pc pc = - let rec try_add n = - if n < 3 then begin - try - new_breakpoint (any_event_at_pc (pc + n * 4)) - with - | Not_found -> - try_add (n+1) - end else begin - error - "Can't add breakpoint at beginning of function: no event there" - end - in try_add 0 - -let convert_module mdle = - match mdle with - | Some m -> - (* Strip .ml extension if any, and capitalize *) - String.capitalize(if Filename.check_suffix m ".ml" - then Filename.chop_suffix m ".ml" - else m) - | None -> - try - let (x, _) = current_point () in x - with - | Not_found -> - error "Not in a module." - -(** Toplevel. **) -let current_line = ref "" - -let interprete_line ppf line = - current_line := line; - let lexbuf = Lexing.from_string line in - try - match identifier_or_eol Lexer.lexeme lexbuf with - | Some x -> - begin match matching_instructions x with - | [] -> - error "Unknown command." - | [i] -> - i.instr_action ppf lexbuf; - resume_user_input (); - i.instr_repeat - | l -> - error "Ambiguous command." - end - | None -> - resume_user_input (); - false - with - | Parsing.Parse_error -> - error "Syntax error." - -let line_loop ppf line_buffer = - resume_user_input (); - let previous_line = ref "" in - try - while true do - if !loaded then - History.add_current_time (); - let new_line = string_trim (line line_buffer) in - let line = - if new_line <> "" then - new_line - else - !previous_line - in - previous_line := ""; - if interprete_line ppf line then - previous_line := line - done - with - | Exit -> - stop_user_input () - | Sys_error s -> - error ("System error : " ^ s) - -(** Instructions. **) -let instr_cd ppf lexbuf = - let dir = argument_eol argument lexbuf in - if ask_kill_program () then - try - Sys.chdir (expand_path dir) - with - | Sys_error s -> - error s - -let instr_shell ppf lexbuf = - let cmdarg = argument_list_eol argument lexbuf in - let cmd = String.concat " " cmdarg in - (* perhaps we should use $SHELL -c ? *) - let err = Sys.command cmd in - if (err != 0) then - eprintf "Shell command %S failed with exit code %d\n%!" cmd err - -let instr_pwd ppf lexbuf = - eol lexbuf; - ignore(system "/bin/pwd") - -let instr_dir ppf lexbuf = - let new_directory = argument_list_eol argument lexbuf in - if new_directory = [] then begin - if yes_or_no "Reinitialize directory list" then begin - Config.load_path := !default_load_path; - Envaux.reset_cache (); - flush_buffer_list () - end - end - else - List.iter (function x -> add_path (expand_path x)) - (List.rev new_directory); - let print_dirs ppf l = List.iter (function x -> fprintf ppf "@ %s" x) l in - fprintf ppf "@[<2>Directories :%a@]@." print_dirs !Config.load_path - -let instr_kill ppf lexbuf = - eol lexbuf; - if not !loaded then error "The program is not being run."; - if (yes_or_no "Kill the program being debugged") then begin - kill_program (); - show_no_point() - end - -let instr_run ppf lexbuf = - eol lexbuf; - ensure_loaded (); - reset_named_values (); - run (); - show_current_event ppf;; - -let instr_reverse ppf lexbuf = - eol lexbuf; - ensure_loaded (); - reset_named_values(); - back_run (); - show_current_event ppf - -let instr_step ppf lexbuf = - let step_count = - match opt_signed_int64_eol Lexer.lexeme lexbuf with - | None -> _1 - | Some x -> x - in - ensure_loaded (); - reset_named_values(); - step step_count; - show_current_event ppf - -let instr_back ppf lexbuf = - let step_count = - match opt_signed_int64_eol Lexer.lexeme lexbuf with - | None -> _1 - | Some x -> x - in - ensure_loaded (); - reset_named_values(); - step (_0 -- step_count); - show_current_event ppf - -let instr_finish ppf lexbuf = - eol lexbuf; - ensure_loaded (); - reset_named_values(); - finish (); - show_current_event ppf - -let instr_next ppf lexbuf = - let step_count = - match opt_integer_eol Lexer.lexeme lexbuf with - | None -> 1 - | Some x -> x - in - ensure_loaded (); - reset_named_values(); - next step_count; - show_current_event ppf - -let instr_start ppf lexbuf = - eol lexbuf; - ensure_loaded (); - reset_named_values(); - start (); - show_current_event ppf - -let instr_previous ppf lexbuf = - let step_count = - match opt_integer_eol Lexer.lexeme lexbuf with - | None -> 1 - | Some x -> x - in - ensure_loaded (); - reset_named_values(); - previous step_count; - show_current_event ppf - -let instr_goto ppf lexbuf = - let time = int64_eol Lexer.lexeme lexbuf in - ensure_loaded (); - reset_named_values(); - go_to time; - show_current_event ppf - -let instr_quit _ = - raise Exit - -let print_variable_list ppf = - let pr_vars ppf = List.iter (fun v -> fprintf ppf "%s@ " v.var_name) in - fprintf ppf "List of variables :%a@." pr_vars !variable_list - -let print_info_list ppf = - let pr_infos ppf = List.iter (fun i -> fprintf ppf "%s@ " i.info_name) in - fprintf ppf "List of info commands :%a@." pr_infos !info_list - -let instr_complete ppf lexbuf = - let ppf = Format.err_formatter in - let rec print_list l = - try - eol lexbuf; - List.iter (function i -> fprintf ppf "%s@." i) l - with _ -> - remove_file !user_channel - and match_list lexbuf = - match identifier_or_eol Lexer.lexeme lexbuf with - | None -> - List.map (fun i -> i.instr_name) !instruction_list - | Some x -> - match matching_instructions x with - | [ {instr_name = ("set" | "show" as i_full)} ] -> - if x = i_full then begin - match identifier_or_eol Lexer.lexeme lexbuf with - | Some ident -> - begin match matching_variables ident with - | [v] -> if v.var_name = ident then [] else [v.var_name] - | l -> List.map (fun v -> v.var_name) l - end - | None -> - List.map (fun v -> v.var_name) !variable_list - end - else [i_full] - | [ {instr_name = "info"} ] -> - if x = "info" then begin - match identifier_or_eol Lexer.lexeme lexbuf with - | Some ident -> - begin match matching_infos ident with - | [i] -> if i.info_name = ident then [] else [i.info_name] - | l -> List.map (fun i -> i.info_name) l - end - | None -> - List.map (fun i -> i.info_name) !info_list - end - else ["info"] - | [ {instr_name = "help"} ] -> - if x = "help" then match_list lexbuf else ["help"] - | [ i ] -> - if x = i.instr_name then [] else [i.instr_name] - | l -> - List.map (fun i -> i.instr_name) l - in - print_list(match_list lexbuf) - -let instr_help ppf lexbuf = - let pr_instrs ppf = - List.iter (fun i -> fprintf ppf "%s@ " i.instr_name) in - match identifier_or_eol Lexer.lexeme lexbuf with - | Some x -> - let print_help nm hlp = - eol lexbuf; - fprintf ppf "%s : %s@." nm hlp in - begin match matching_instructions x with - | [] -> - eol lexbuf; - fprintf ppf "No matching command.@." - | [ {instr_name = "set"} ] -> - find_variable - (fun v _ _ -> - print_help ("set " ^ v.var_name) ("set " ^ v.var_help)) - (fun ppf -> - print_help "set" "set debugger variable."; - print_variable_list ppf) - ppf - lexbuf - | [ {instr_name = "show"} ] -> - find_variable - (fun v _ _ -> - print_help ("show " ^ v.var_name) ("show " ^ v.var_help)) - (fun v -> - print_help "show" "display debugger variable."; - print_variable_list ppf) - ppf - lexbuf - | [ {instr_name = "info"} ] -> - find_info - (fun i _ _ -> print_help ("info " ^ i.info_name) i.info_help) - (fun ppf -> - print_help "info" - "display infos about the program being debugged."; - print_info_list ppf) - ppf - lexbuf - | [i] -> - print_help i.instr_name i.instr_help - | l -> - eol lexbuf; - fprintf ppf "Ambiguous command \"%s\" : %a@." x pr_instrs l - end - | None -> - fprintf ppf "List of commands :%a@." pr_instrs !instruction_list - -(* Printing values *) - -let print_expr depth ev env ppf expr = - try - let (v, ty) = Eval.expression ev env expr in - print_named_value depth expr env v ppf ty - with - | Eval.Error msg -> - Eval.report_error ppf msg; - raise Toplevel - -let print_command depth ppf lexbuf = - let exprs = expression_list_eol Lexer.lexeme lexbuf in - ensure_loaded (); - let env = - try - Envaux.env_of_event !selected_event - with - | Envaux.Error msg -> - Envaux.report_error ppf msg; - raise Toplevel - in - List.iter (print_expr depth !selected_event env ppf) exprs - -let instr_print ppf lexbuf = print_command !max_printer_depth ppf lexbuf - -let instr_display ppf lexbuf = print_command 1 ppf lexbuf - -(* Loading of command files *) - -let extract_filename arg = - (* Allow enclosing filename in quotes *) - let l = String.length arg in - let pos1 = if l > 0 && arg.[0] = '"' then 1 else 0 in - let pos2 = if l > 0 && arg.[l-1] = '"' then l-1 else l in - String.sub arg pos1 (pos2 - pos1) - -let instr_source ppf lexbuf = - let file = extract_filename(argument_eol argument lexbuf) - and old_state = !interactif - and old_channel = !user_channel in - let io_chan = - try - io_channel_of_descr - (openfile (find_in_path !Config.load_path (expand_path file)) - [O_RDONLY] 0) - with - | Not_found -> error "Source file not found." - | (Unix_error _) as x -> Unix_tools.report_error x; raise Toplevel - in - try - interactif := false; - user_channel := io_chan; - line_loop ppf (Lexing.from_function read_user_input); - close_io io_chan; - interactif := old_state; - user_channel := old_channel - with - | x -> - stop_user_input (); - close_io io_chan; - interactif := old_state; - user_channel := old_channel; - raise x - -let instr_set = - find_variable - (fun {var_action = (funct, _)} ppf lexbuf -> funct lexbuf) - (function ppf -> error "Argument required.") - -let instr_show = - find_variable - (fun {var_action = (_, funct)} ppf lexbuf -> eol lexbuf; funct ppf) - (function ppf -> - List.iter - (function {var_name = nm; var_action = (_, funct)} -> - fprintf ppf "%s : " nm; - funct ppf) - !variable_list) - -let instr_info = - find_info - (fun i ppf lexbuf -> i.info_action lexbuf) - (function ppf -> - error "\"info\" must be followed by the name of an info command.") - -let instr_break ppf lexbuf = - let argument = break_argument_eol Lexer.lexeme lexbuf in - ensure_loaded (); - match argument with - | BA_none -> (* break *) - (match !selected_event with - | Some ev -> - new_breakpoint ev - | None -> - error "Can't add breakpoint at this point.") - | BA_pc pc -> (* break PC *) - add_breakpoint_at_pc pc - | BA_function expr -> (* break FUNCTION *) - let env = - try - Envaux.env_of_event !selected_event - with - | Envaux.Error msg -> - Envaux.report_error ppf msg; - raise Toplevel - in - begin try - let (v, ty) = Eval.expression !selected_event env expr in - match (Ctype.repr ty).desc with - | Tarrow _ -> - add_breakpoint_after_pc (Remote_value.closure_code v) - | _ -> - eprintf "Not a function.@."; - raise Toplevel - with - | Eval.Error msg -> - Eval.report_error ppf msg; - raise Toplevel - end - | BA_pos1 (mdle, line, column) -> (* break @ [MODULE] LINE [COL] *) - let module_name = convert_module mdle in - new_breakpoint - (try - let buffer = - try get_buffer module_name with - | Not_found -> - eprintf "No source file for %s.@." module_name; - raise Toplevel - in - match column with - | None -> - event_at_pos module_name (fst (pos_of_line buffer line)) - | Some col -> - event_near_pos module_name (point_of_coord buffer line col) - with - | Not_found -> (* event_at_pos / event_near pos *) - eprintf "Can't find any event there.@."; - raise Toplevel - | Out_of_range -> (* pos_of_line / point_of_coord *) - eprintf "Position out of range.@."; - raise Toplevel) - | BA_pos2 (mdle, position) -> (* break @ [MODULE] # POSITION *) - try - new_breakpoint (event_near_pos (convert_module mdle) position) - with - | Not_found -> - eprintf "Can't find any event there.@." - -let instr_delete ppf lexbuf = - match integer_list_eol Lexer.lexeme lexbuf with - | [] -> - if breakpoints_count () <> 0 && yes_or_no "Delete all breakpoints" - then remove_all_breakpoints () - | breakpoints -> - List.iter - (function x -> try remove_breakpoint x with | Not_found -> ()) - breakpoints - -let instr_frame ppf lexbuf = - let frame_number = - match opt_integer_eol Lexer.lexeme lexbuf with - | None -> !current_frame - | Some x -> x - in - ensure_loaded (); - try - select_frame frame_number; - show_current_frame ppf true - with - | Not_found -> - error ("No frame number " ^ string_of_int frame_number ^ ".") - -let instr_backtrace ppf lexbuf = - let number = - match opt_signed_integer_eol Lexer.lexeme lexbuf with - | None -> 0 - | Some x -> x in - ensure_loaded (); - match current_report() with - | None | Some {rep_type = Exited | Uncaught_exc} -> () - | Some _ -> - let frame_counter = ref 0 in - let print_frame first_frame last_frame = function - | None -> - fprintf ppf - "(Encountered a function with no debugging information)@."; - false - | Some event -> - if !frame_counter >= first_frame then - show_one_frame !frame_counter ppf event; - incr frame_counter; - if !frame_counter >= last_frame then begin - fprintf ppf "(More frames follow)@." - end; - !frame_counter < last_frame in - if number = 0 then - do_backtrace (print_frame 0 max_int) - else if number > 0 then - do_backtrace (print_frame 0 number) - else begin - let num_frames = stack_depth() in - if num_frames < 0 then begin - fprintf ppf - "(Encountered a function with no debugging information)"; - print_newline() - end else - do_backtrace (print_frame (num_frames + number) max_int) - end - -let instr_up ppf lexbuf = - let offset = - match opt_signed_integer_eol Lexer.lexeme lexbuf with - | None -> 1 - | Some x -> x - in - ensure_loaded (); - try - select_frame (!current_frame + offset); - show_current_frame ppf true - with - | Not_found -> error "No such frame." - -let instr_down ppf lexbuf = - let offset = - match opt_signed_integer_eol Lexer.lexeme lexbuf with - | None -> 1 - | Some x -> x - in - ensure_loaded (); - try - select_frame (!current_frame - offset); - show_current_frame ppf true - with - | Not_found -> error "No such frame." - -let instr_last ppf lexbuf = - let count = - match opt_signed_int64_eol Lexer.lexeme lexbuf with - | None -> _1 - | Some x -> x - in - reset_named_values(); - go_to (History.previous_time count); - show_current_event ppf - -let instr_list ppf lexbuf = - let (mo, beg, e) = list_arguments_eol Lexer.lexeme lexbuf in - let (curr_mod, point) = - try - selected_point () - with - | Not_found -> - ("", -1) - in - let mdle = convert_module mo in - let beginning = - match beg with - | None when (mo <> None) || (point = -1) -> - 1 - | None -> - let buffer = - try get_buffer mdle with - | Not_found -> error ("No source file for " ^ mdle ^ ".") - in - begin try - max 1 ((snd (line_of_pos buffer point)) - 10) - with Out_of_range -> - 1 - end - | Some x -> x - in - let en = - match e with - | None -> beginning + 20 - | Some x -> x - in - if mdle = curr_mod then - show_listing mdle beginning en point - (current_event_is_before ()) - else - show_listing mdle beginning en (-1) true - -(** Variables. **) -let raw_variable kill name = - (function lexbuf -> - let argument = argument_eol argument lexbuf in - if (not kill) || ask_kill_program () then name := argument), - function ppf -> fprintf ppf "%s@." !name - -let raw_line_variable kill name = - (function lexbuf -> - let argument = argument_eol line_argument lexbuf in - if (not kill) || ask_kill_program () then name := argument), - function ppf -> fprintf ppf "%s@." !name - -let integer_variable kill min msg name = - (function lexbuf -> - let argument = integer_eol Lexer.lexeme lexbuf in - if argument < min then print_endline msg - else if (not kill) || ask_kill_program () then name := argument), - function ppf -> fprintf ppf "%i@." !name - -let int64_variable kill min msg name = - (function lexbuf -> - let argument = int64_eol Lexer.lexeme lexbuf in - if argument < min then print_endline msg - else if (not kill) || ask_kill_program () then name := argument), - function ppf -> fprintf ppf "%Li@." !name - -let boolean_variable kill name = - (function lexbuf -> - let argument = - match identifier_eol Lexer.lexeme lexbuf with - | "on" -> true - | "of" | "off" -> false - | _ -> error "Syntax error." - in - if (not kill) || ask_kill_program () then name := argument), - function ppf -> fprintf ppf "%s@." (if !name then "on" else "off") - -let path_variable kill name = - (function lexbuf -> - let argument = argument_eol argument lexbuf in - if (not kill) || ask_kill_program () then - name := make_absolute (expand_path argument)), - function ppf -> fprintf ppf "%s@." !name - -let loading_mode_variable ppf = - (find_ident - "loading mode" - (matching_elements (ref loading_modes) fst) - (fun (_, mode) ppf lexbuf -> - eol lexbuf; set_launching_function mode) - (function ppf -> error "Syntax error.") - ppf), - function ppf -> - let rec find = function - | [] -> () - | (name, funct) :: l -> - if funct == !launching_func then fprintf ppf "%s" name else find l - in - find loading_modes; - fprintf ppf "@." - -(** Infos. **) - -let pr_modules ppf mods = - let pr_mods ppf = List.iter (function x -> fprintf ppf "%s@ " x) in - fprintf ppf "Used modules :@.%a@?" pr_mods mods - -let info_modules ppf lexbuf = - eol lexbuf; - ensure_loaded (); - pr_modules ppf !modules -(******** - print_endline "Opened modules :"; - if !opened_modules_names = [] then - print_endline "(no module opened)." - else - (List.iter (function x -> print_string x; print_space) !opened_modules_names; - print_newline ()) -*********) - -let info_checkpoints ppf lexbuf = - eol lexbuf; - if !checkpoints = [] then fprintf ppf "No checkpoint.@." - else - (if !debug_breakpoints then - (prerr_endline " Time Pid Version"; - List.iter - (function - {c_time = time; c_pid = pid; c_breakpoint_version = version} -> - Printf.printf "%19Ld %5d %d\n" time pid version) - !checkpoints) - else - (print_endline " Time Pid"; - List.iter - (function - {c_time = time; c_pid = pid} -> - Printf.printf "%19Ld %5d\n" time pid) - !checkpoints)) - -let info_one_breakpoint ppf (num, ev) = - fprintf ppf "%3d %10d %s@." num ev.ev_pos (Pos.get_desc ev); -;; - -let info_breakpoints ppf lexbuf = - eol lexbuf; - if !breakpoints = [] then fprintf ppf "No breakpoints.@." - else begin - fprintf ppf "Num Address Where@."; - List.iter (info_one_breakpoint ppf) (List.rev !breakpoints); - end -;; - -let info_events ppf lexbuf = - ensure_loaded (); - let mdle = convert_module (opt_identifier_eol Lexer.lexeme lexbuf) in - print_endline ("Module : " ^ mdle); - print_endline " Address Character Kind Repr."; - List.iter - (function ev -> - Printf.printf - "%10d %10d %10s %10s\n" - ev.ev_pos - ev.ev_char.Lexing.pos_cnum - ((match ev.ev_kind with - Event_before -> "before" - | Event_after _ -> "after" - | Event_pseudo -> "pseudo") - ^ - (match ev.ev_info with - Event_function -> "/fun" - | Event_return _ -> "/ret" - | Event_other -> "")) - (match ev.ev_repr with - Event_none -> "" - | Event_parent _ -> "(repr)" - | Event_child repr -> string_of_int !repr)) - (events_in_module mdle) - -(** User-defined printers **) - -let instr_load_printer ppf lexbuf = - let filename = extract_filename(argument_eol argument lexbuf) in - try - Loadprinter.loadfile ppf filename - with Loadprinter.Error e -> - Loadprinter.report_error ppf e; raise Toplevel - -let instr_install_printer ppf lexbuf = - let lid = longident_eol Lexer.lexeme lexbuf in - try - Loadprinter.install_printer ppf lid - with Loadprinter.Error e -> - Loadprinter.report_error ppf e; raise Toplevel - -let instr_remove_printer ppf lexbuf = - let lid = longident_eol Lexer.lexeme lexbuf in - try - Loadprinter.remove_printer lid - with Loadprinter.Error e -> - Loadprinter.report_error ppf e; raise Toplevel - -(** Initialization. **) -let init ppf = - instruction_list := [ - { instr_name = "cd"; instr_prio = false; - instr_action = instr_cd; instr_repeat = true; instr_help = -"set working directory to DIR for debugger and program being debugged." }; - { instr_name = "complete"; instr_prio = false; - instr_action = instr_complete; instr_repeat = false; instr_help = -"complete word at cursor according to context. Useful for Emacs." }; - { instr_name = "pwd"; instr_prio = false; - instr_action = instr_pwd; instr_repeat = true; instr_help = -"print working directory." }; - { instr_name = "directory"; instr_prio = false; - instr_action = instr_dir; instr_repeat = false; instr_help = -"add directory DIR to beginning of search path for source and\n\ -interface files.\n\ -Forget cached info on source file locations and line positions.\n\ -With no argument, reset the search path." }; - { instr_name = "kill"; instr_prio = false; - instr_action = instr_kill; instr_repeat = true; instr_help = -"kill the program being debugged." }; - { instr_name = "help"; instr_prio = false; - instr_action = instr_help; instr_repeat = true; instr_help = -"print list of commands." }; - { instr_name = "quit"; instr_prio = false; - instr_action = instr_quit; instr_repeat = false; instr_help = -"exit the debugger." }; - { instr_name = "shell"; instr_prio = false; - instr_action = instr_shell; instr_repeat = true; instr_help = -"Execute a given COMMAND thru the system shell." }; - (* Displacements *) - { instr_name = "run"; instr_prio = true; - instr_action = instr_run; instr_repeat = true; instr_help = -"run the program from current position." }; - { instr_name = "reverse"; instr_prio = false; - instr_action = instr_reverse; instr_repeat = true; instr_help = -"run the program backward from current position." }; - { instr_name = "step"; instr_prio = true; - instr_action = instr_step; instr_repeat = true; instr_help = -"step program until it reaches the next event.\n\ -Argument N means do this N times (or till program stops for another reason)." }; - { instr_name = "backstep"; instr_prio = true; - instr_action = instr_back; instr_repeat = true; instr_help = -"step program backward until it reaches the previous event.\n\ -Argument N means do this N times (or till program stops for another reason)." }; - { instr_name = "goto"; instr_prio = false; - instr_action = instr_goto; instr_repeat = true; instr_help = -"go to the given time." }; - { instr_name = "finish"; instr_prio = true; - instr_action = instr_finish; instr_repeat = true; instr_help = -"execute until topmost stack frame returns." }; - { instr_name = "next"; instr_prio = true; - instr_action = instr_next; instr_repeat = true; instr_help = -"step program until it reaches the next event.\n\ -Skip over function calls.\n\ -Argument N means do this N times (or till program stops for another reason)." }; - { instr_name = "start"; instr_prio = false; - instr_action = instr_start; instr_repeat = true; instr_help = -"execute backward until the current function is exited." }; - { instr_name = "previous"; instr_prio = false; - instr_action = instr_previous; instr_repeat = true; instr_help = -"step program until it reaches the previous event.\n\ -Skip over function calls.\n\ -Argument N means do this N times (or till program stops for another reason)." }; - { instr_name = "print"; instr_prio = true; - instr_action = instr_print; instr_repeat = true; instr_help = -"print value of expressions (deep printing)." }; - { instr_name = "display"; instr_prio = true; - instr_action = instr_display; instr_repeat = true; instr_help = -"print value of expressions (shallow printing)." }; - { instr_name = "source"; instr_prio = false; - instr_action = instr_source; instr_repeat = true; instr_help = -"read command from file FILE." }; - (* Breakpoints *) - { instr_name = "break"; instr_prio = false; - instr_action = instr_break; instr_repeat = false; instr_help = -"Set breakpoint at specified line or function.\n\ -Syntax: break function-name\n\ - break @ [module] linenum\n\ - break @ [module] # characternum" }; - { instr_name = "delete"; instr_prio = false; - instr_action = instr_delete; instr_repeat = false; instr_help = -"delete some breakpoints.\n\ -Arguments are breakpoint numbers with spaces in between.\n\ -To delete all breakpoints, give no argument." }; - { instr_name = "set"; instr_prio = false; - instr_action = instr_set; instr_repeat = false; instr_help = -"--unused--" }; - { instr_name = "show"; instr_prio = false; - instr_action = instr_show; instr_repeat = true; instr_help = -"--unused--" }; - { instr_name = "info"; instr_prio = false; - instr_action = instr_info; instr_repeat = true; instr_help = -"--unused--" }; - (* Frames *) - { instr_name = "frame"; instr_prio = false; - instr_action = instr_frame; instr_repeat = true; instr_help = -"select and print a stack frame.\n\ -With no argument, print the selected stack frame.\n\ -An argument specifies the frame to select." }; - { instr_name = "backtrace"; instr_prio = false; - instr_action = instr_backtrace; instr_repeat = true; instr_help = -"print backtrace of all stack frames, or innermost COUNT frames.\n\ -With a negative argument, print outermost -COUNT frames." }; - { instr_name = "bt"; instr_prio = false; - instr_action = instr_backtrace; instr_repeat = true; instr_help = -"print backtrace of all stack frames, or innermost COUNT frames.\n\ -With a negative argument, print outermost -COUNT frames." }; - { instr_name = "up"; instr_prio = false; - instr_action = instr_up; instr_repeat = true; instr_help = -"select and print stack frame that called this one.\n\ -An argument says how many frames up to go." }; - { instr_name = "down"; instr_prio = false; - instr_action = instr_down; instr_repeat = true; instr_help = -"select and print stack frame called by this one.\n\ -An argument says how many frames down to go." }; - { instr_name = "last"; instr_prio = true; - instr_action = instr_last; instr_repeat = true; instr_help = -"go back to previous time." }; - { instr_name = "list"; instr_prio = false; - instr_action = instr_list; instr_repeat = true; instr_help = -"list the source code." }; - (* User-defined printers *) - { instr_name = "load_printer"; instr_prio = false; - instr_action = instr_load_printer; instr_repeat = false; instr_help = -"load in the debugger a .cmo or .cma file containing printing functions." }; - { instr_name = "install_printer"; instr_prio = false; - instr_action = instr_install_printer; instr_repeat = false; instr_help = -"use the given function for printing values of its input type.\n\ -The code for the function must have previously been loaded in the debugger\n\ -using \"load_printer\"." }; - { instr_name = "remove_printer"; instr_prio = false; - instr_action = instr_remove_printer; instr_repeat = false; instr_help = -"stop using the given function for printing values of its input type." } -]; - variable_list := [ - (* variable name, (writing, reading), help reading, help writing *) - { var_name = "arguments"; - var_action = raw_line_variable true arguments; - var_help = -"arguments to give program being debugged when it is started." }; - { var_name = "program"; - var_action = path_variable true program_name; - var_help = -"name of program to be debugged." }; - { var_name = "loadingmode"; - var_action = loading_mode_variable ppf; - var_help = -"mode of loading.\n\ -It can be either : - direct : the program is directly called by the debugger.\n\ - runtime : the debugger execute `ocamlrun programname arguments'.\n\ - manual : the program is not launched by the debugger,\n\ - but manually by the user." }; - { var_name = "processcount"; - var_action = integer_variable false 1 "Must be >= 1." - checkpoint_max_count; - var_help = -"maximum number of process to keep." }; - { var_name = "checkpoints"; - var_action = boolean_variable false make_checkpoints; - var_help = -"whether to make checkpoints or not." }; - { var_name = "bigstep"; - var_action = int64_variable false _1 "Must be >= 1." - checkpoint_big_step; - var_help = -"step between checkpoints during long displacements." }; - { var_name = "smallstep"; - var_action = int64_variable false _1 "Must be >= 1." - checkpoint_small_step; - var_help = -"step between checkpoints during small displacements." }; - { var_name = "socket"; - var_action = raw_variable true socket_name; - var_help = -"name of the socket used by communications debugger-runtime." }; - { var_name = "history"; - var_action = integer_variable false 0 "" history_size; - var_help = -"history size." }; - { var_name = "print_depth"; - var_action = integer_variable false 1 "Must be at least 1" - max_printer_depth; - var_help = -"maximal depth for printing of values." }; - { var_name = "print_length"; - var_action = integer_variable false 1 "Must be at least 1" - max_printer_steps; - var_help = -"maximal number of value nodes printed." }]; - - info_list := - (* info name, function, help *) - [{ info_name = "modules"; - info_action = info_modules ppf; - info_help = "list opened modules." }; - { info_name = "checkpoints"; - info_action = info_checkpoints ppf; - info_help = "list checkpoints." }; - { info_name = "breakpoints"; - info_action = info_breakpoints ppf; - info_help = "list breakpoints." }; - { info_name = "events"; - info_action = info_events ppf; - info_help = "list events in MODULE (default is current module)." }] - -let _ = init std_formatter diff --git a/debugger/command_line.mli b/debugger/command_line.mli deleted file mode 100644 index dd2349d2c4..0000000000 --- a/debugger/command_line.mli +++ /dev/null @@ -1,22 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(************************ Reading and executing commands ***************) - -open Lexing;; -open Format;; - -val interprete_line : formatter -> string -> bool;; -val line_loop : formatter -> lexbuf -> unit;; diff --git a/debugger/debugcom.ml b/debugger/debugcom.ml deleted file mode 100644 index edec454727..0000000000 --- a/debugger/debugcom.ml +++ /dev/null @@ -1,278 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* Low-level communication with the debuggee *) - -open Int64ops -open Primitives - -(* The current connection with the debuggee *) - -let conn = ref Primitives.std_io - -let set_current_connection io_chan = - conn := io_chan - -(* Modify the program code *) - -let set_event pos = - output_char !conn.io_out 'e'; - output_binary_int !conn.io_out pos - -let set_breakpoint pos = - output_char !conn.io_out 'B'; - output_binary_int !conn.io_out pos - -let reset_instr pos = - output_char !conn.io_out 'i'; - output_binary_int !conn.io_out pos - -(* Basic commands for flow control *) - -type execution_summary = - Event - | Breakpoint - | Exited - | Trap_barrier - | Uncaught_exc - -type report = { - rep_type : execution_summary; - rep_event_count : int; - rep_stack_pointer : int; - rep_program_pointer : int -} - -type checkpoint_report = - Checkpoint_done of int - | Checkpoint_failed - -(* Run the debuggee for N events *) - -let do_go_smallint n = - output_char !conn.io_out 'g'; - output_binary_int !conn.io_out n; - flush !conn.io_out; - Input_handling.execute_with_other_controller - Input_handling.exit_main_loop - !conn - (function () -> - Input_handling.main_loop (); - let summary = - match input_char !conn.io_in with - 'e' -> Event - | 'b' -> Breakpoint - | 'x' -> Exited - | 's' -> Trap_barrier - | 'u' -> Uncaught_exc - | _ -> Misc.fatal_error "Debugcom.do_go" in - let event_counter = input_binary_int !conn.io_in in - let stack_pos = input_binary_int !conn.io_in in - let pc = input_binary_int !conn.io_in in - { rep_type = summary; - rep_event_count = event_counter; - rep_stack_pointer = stack_pos; - rep_program_pointer = pc }) - -let rec do_go n = - assert (n >= _0); - if n > max_small_int then( - ignore (do_go_smallint max_int); - do_go (n -- max_small_int) - )else( - do_go_smallint (Int64.to_int n) - ) -;; - -(* Perform a checkpoint *) - -let do_checkpoint () = - output_char !conn.io_out 'c'; - flush !conn.io_out; - let pid = input_binary_int !conn.io_in in - if pid = -1 then Checkpoint_failed else Checkpoint_done pid - -(* Kill the given process. *) -let stop chan = - try - output_char chan.io_out 's'; - flush chan.io_out - with - Sys_error _ | End_of_file -> () - -(* Ask a process to wait for its child which has been killed. *) -(* (so as to eliminate zombies). *) -let wait_child chan = - try - output_char chan.io_out 'w' - with - Sys_error _ | End_of_file -> () - -(* Move to initial frame (that of current function). *) -(* Return stack position and current pc *) - -let initial_frame () = - output_char !conn.io_out '0'; - flush !conn.io_out; - let stack_pos = input_binary_int !conn.io_in in - let pc = input_binary_int !conn.io_in in - (stack_pos, pc) - -let set_initial_frame () = - ignore(initial_frame ()) - -(* Move up one frame *) -(* Return stack position and current pc. - If there's no frame above, return (-1, 0). *) - -let up_frame stacksize = - output_char !conn.io_out 'U'; - output_binary_int !conn.io_out stacksize; - flush !conn.io_out; - let stack_pos = input_binary_int !conn.io_in in - let pc = if stack_pos = -1 then 0 else input_binary_int !conn.io_in in - (stack_pos, pc) - -(* Get and set the current frame position *) - -let get_frame () = - output_char !conn.io_out 'f'; - flush !conn.io_out; - let stack_pos = input_binary_int !conn.io_in in - let pc = input_binary_int !conn.io_in in - (stack_pos, pc) - -let set_frame stack_pos = - output_char !conn.io_out 'S'; - output_binary_int !conn.io_out stack_pos - -(* Set the trap barrier to given stack position. *) - -let set_trap_barrier pos = - output_char !conn.io_out 'b'; - output_binary_int !conn.io_out pos - -(* Handling of remote values *) - -let value_size = if 1 lsl 31 = 0 then 4 else 8 - -let input_remote_value ic = - let v = String.create value_size in - really_input ic v 0 value_size; v - -let output_remote_value ic v = - output ic v 0 value_size - -exception Marshalling_error - -module Remote_value = - struct - type t = Remote of string | Local of Obj.t - - let obj = function - | Local obj -> Obj.obj obj - | Remote v -> - output_char !conn.io_out 'M'; - output_remote_value !conn.io_out v; - flush !conn.io_out; - try - input_value !conn.io_in - with End_of_file | Failure _ -> - raise Marshalling_error - - let is_block = function - | Local obj -> Obj.is_block obj - | Remote v -> Obj.is_block (Array.unsafe_get (Obj.magic v : Obj.t array) 0) - - let tag = function - | Local obj -> Obj.tag obj - | Remote v -> - output_char !conn.io_out 'H'; - output_remote_value !conn.io_out v; - flush !conn.io_out; - let header = input_binary_int !conn.io_in in - header land 0xFF - - let size = function - | Local obj -> Obj.size obj - | Remote v -> - output_char !conn.io_out 'H'; - output_remote_value !conn.io_out v; - flush !conn.io_out; - let header = input_binary_int !conn.io_in in - if header land 0xFF = Obj.double_array_tag && Sys.word_size = 32 - then header lsr 11 - else header lsr 10 - - let field v n = - match v with - | Local obj -> Local(Obj.field obj n) - | Remote v -> - output_char !conn.io_out 'F'; - output_remote_value !conn.io_out v; - output_binary_int !conn.io_out n; - flush !conn.io_out; - if input_byte !conn.io_in = 0 then - Remote(input_remote_value !conn.io_in) - else begin - let buf = String.create 8 in - really_input !conn.io_in buf 0 8; - let floatbuf = float n (* force allocation of a new float *) in - String.unsafe_blit buf 0 (Obj.magic floatbuf) 0 8; - Local(Obj.repr floatbuf) - end - - let of_int n = - Local(Obj.repr n) - - let local pos = - output_char !conn.io_out 'L'; - output_binary_int !conn.io_out pos; - flush !conn.io_out; - Remote(input_remote_value !conn.io_in) - - let from_environment pos = - output_char !conn.io_out 'E'; - output_binary_int !conn.io_out pos; - flush !conn.io_out; - Remote(input_remote_value !conn.io_in) - - let global pos = - output_char !conn.io_out 'G'; - output_binary_int !conn.io_out pos; - flush !conn.io_out; - Remote(input_remote_value !conn.io_in) - - let accu () = - output_char !conn.io_out 'A'; - flush !conn.io_out; - Remote(input_remote_value !conn.io_in) - - let closure_code = function - | Local obj -> assert false - | Remote v -> - output_char !conn.io_out 'C'; - output_remote_value !conn.io_out v; - flush !conn.io_out; - input_binary_int !conn.io_in - - let same rv1 rv2 = - match (rv1, rv2) with - (Local obj1, Local obj2) -> obj1 == obj2 - | (Remote v1, Remote v2) -> v1 = v2 - (* string equality -> equality of remote pointers *) - | (_, _) -> false - - end diff --git a/debugger/debugcom.mli b/debugger/debugcom.mli deleted file mode 100644 index 447e45d9e2..0000000000 --- a/debugger/debugcom.mli +++ /dev/null @@ -1,102 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* Low-level communication with the debuggee *) - -type execution_summary = - Event - | Breakpoint - | Exited - | Trap_barrier - | Uncaught_exc - -type report = - { rep_type : execution_summary; - rep_event_count : int; - rep_stack_pointer : int; - rep_program_pointer : int } - -type checkpoint_report = - Checkpoint_done of int - | Checkpoint_failed - -(* Set the current connection with the debuggee *) -val set_current_connection : Primitives.io_channel -> unit - -(* Put an event at given pc *) -val set_event : int -> unit - -(* Put a breakpoint at given pc *) -val set_breakpoint : int -> unit - -(* Remove breakpoint or event at given pc *) -val reset_instr : int -> unit - -(* Create a new checkpoint (the current process forks). *) -val do_checkpoint : unit -> checkpoint_report - -(* Step N events. *) -val do_go : int64 -> report - -(* Tell given process to terminate *) -val stop : Primitives.io_channel -> unit - -(* Tell given process to wait for its children *) -val wait_child : Primitives.io_channel -> unit - -(* Move to initial frame (that of current function). *) -(* Return stack position and current pc *) -val initial_frame : unit -> int * int -val set_initial_frame : unit -> unit - -(* Get the current frame position *) -(* Return stack position and current pc *) -val get_frame : unit -> int * int - -(* Set the current frame *) -val set_frame : int -> unit - -(* Move up one frame *) -(* Return stack position and current pc. - If there's no frame above, return (-1, 0). *) -val up_frame : int -> int * int - -(* Set the trap barrier to given stack position. *) -val set_trap_barrier : int -> unit - -(* Handling of remote values *) - -exception Marshalling_error - -module Remote_value : - sig - type t - - val obj : t -> 'a - val is_block : t -> bool - val tag : t -> int - val size : t -> int - val field : t -> int -> t - val same : t -> t -> bool - - val of_int : int -> t - - val local : int -> t - val from_environment : int -> t - val global : int -> t - val accu : unit -> t - val closure_code : t -> int - - end diff --git a/debugger/debugger_config.ml b/debugger/debugger_config.ml deleted file mode 100644 index fa6fd7018f..0000000000 --- a/debugger/debugger_config.ml +++ /dev/null @@ -1,75 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(**************************** Configuration file ***********************) - -open Int64ops - -exception Toplevel - -(*** Miscellaneous parameters. ***) - -(*ISO 6429 color sequences -00 to restore default color -01 for brighter colors -04 for underlined text -05 for flashing text -30 for black foreground -31 for red foreground -32 for green foreground -33 for yellow (or brown) foreground -34 for blue foreground -35 for purple foreground -36 for cyan foreground -37 for white (or gray) foreground -40 for black background -41 for red background -42 for green background -43 for yellow (or brown) background -44 for blue background -45 for purple background -46 for cyan background -47 for white (or gray) background -let debugger_prompt = "\027[1;04m(ocd)\027[0m " -and event_mark_before = "\027[1;31m$\027[0m" -and event_mark_after = "\027[1;34m$\027[0m" -*) -let debugger_prompt = "(ocd) " -let event_mark_before = "<|b|>" -let event_mark_after = "<|a|>" - -(* Name of shell used to launch the debuggee *) -let shell = "/bin/sh" - -(* Name of the Objective Caml runtime. *) -let runtime_program = "ocamlrun" - -(* Time history size (for `last') *) -let history_size = ref 30 - -(*** Time travel parameters. ***) - -(* Step between checkpoints for long displacements.*) -let checkpoint_big_step = ref (~~ "10000") - -(* Idem for small ones. *) -let checkpoint_small_step = ref (~~ "1000") - -(* Maximum number of checkpoints. *) -let checkpoint_max_count = ref 15 - -(* Whether to keep checkpoints or not. *) -let make_checkpoints = ref true - diff --git a/debugger/debugger_config.mli b/debugger/debugger_config.mli deleted file mode 100644 index 44f4fe582a..0000000000 --- a/debugger/debugger_config.mli +++ /dev/null @@ -1,35 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(********************** Configuration file *****************************) - -exception Toplevel - -(*** Miscellaneous parameters. ***) - -val debugger_prompt : string -val event_mark_before : string -val event_mark_after : string -val shell : string -val runtime_program : string -val history_size : int ref - -(*** Time travel paramaters. ***) - -val checkpoint_big_step : int64 ref -val checkpoint_small_step : int64 ref -val checkpoint_max_count : int ref -val make_checkpoints : bool ref - diff --git a/debugger/envaux.ml b/debugger/envaux.ml deleted file mode 100644 index ba8d6dff59..0000000000 --- a/debugger/envaux.ml +++ /dev/null @@ -1,83 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -open Misc -open Types -open Env - -type error = - Module_not_found of Path.t - -exception Error of error - -let env_cache = - (Hashtbl.create 59 : (Env.summary, Env.t) Hashtbl.t) - -let reset_cache () = - Hashtbl.clear env_cache; - Env.reset_cache() - -let extract_sig env mty = - match Mtype.scrape env mty with - Tmty_signature sg -> sg - | _ -> fatal_error "Envaux.extract_sig" - -let rec env_from_summary sum = - try - Hashtbl.find env_cache sum - with Not_found -> - let env = - match sum with - Env_empty -> - Env.empty - | Env_value(s, id, desc) -> - Env.add_value id desc (env_from_summary s) - | Env_type(s, id, desc) -> - Env.add_type id desc (env_from_summary s) - | Env_exception(s, id, desc) -> - Env.add_exception id desc (env_from_summary s) - | Env_module(s, id, desc) -> - Env.add_module id desc (env_from_summary s) - | Env_modtype(s, id, desc) -> - Env.add_modtype id desc (env_from_summary s) - | Env_class(s, id, desc) -> - Env.add_class id desc (env_from_summary s) - | Env_cltype (s, id, desc) -> - Env.add_cltype id desc (env_from_summary s) - | Env_open(s, path) -> - let env = env_from_summary s in - let mty = - try - Env.find_module path env - with Not_found -> - raise (Error (Module_not_found path)) - in - Env.open_signature path (extract_sig env mty) env - in - Hashtbl.add env_cache sum env; - env - -let env_of_event = - function - None -> Env.empty - | Some ev -> env_from_summary ev.Instruct.ev_typenv - -(* Error report *) - -open Format - -let report_error ppf = function - | Module_not_found p -> - fprintf ppf "@[Cannot find module %a@].@." Printtyp.path p diff --git a/debugger/envaux.mli b/debugger/envaux.mli deleted file mode 100644 index 8b122cc347..0000000000 --- a/debugger/envaux.mli +++ /dev/null @@ -1,33 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -open Format - -(* Convert environment summaries to environments *) - -val env_of_event: Instruct.debug_event option -> Env.t - -(* Empty the environment caches. To be called when load_path changes. *) - -val reset_cache: unit -> unit - -(* Error report *) - -type error = - Module_not_found of Path.t - -exception Error of error - -val report_error: formatter -> error -> unit diff --git a/debugger/eval.ml b/debugger/eval.ml deleted file mode 100644 index a53589382a..0000000000 --- a/debugger/eval.ml +++ /dev/null @@ -1,207 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -open Debugger_config -open Misc -open Path -open Instruct -open Types -open Parser_aux - -type error = - Unbound_identifier of Ident.t - | Not_initialized_yet of Path.t - | Unbound_long_identifier of Longident.t - | Unknown_name of int - | Tuple_index of type_expr * int * int - | Array_index of int * int - | List_index of int * int - | String_index of string * int * int - | Wrong_item_type of type_expr * int - | Wrong_label of type_expr * string - | Not_a_record of type_expr - | No_result - -exception Error of error - -let abstract_type = - Btype.newgenty (Tconstr (Pident (Ident.create ""), [], ref Mnil)) - -let rec path event = function - Pident id -> - if Ident.global id then - Debugcom.Remote_value.global (Symtable.get_global_position id) - else - begin match event with - Some ev -> - begin try - let pos = Ident.find_same id ev.ev_compenv.ce_stack in - Debugcom.Remote_value.local (ev.ev_stacksize - pos) - with Not_found -> - try - let pos = Ident.find_same id ev.ev_compenv.ce_heap in - Debugcom.Remote_value.from_environment pos - with Not_found -> - raise(Error(Unbound_identifier id)) - end - | None -> - raise(Error(Unbound_identifier id)) - end - | Pdot(root, fieldname, pos) -> - let v = path event root in - if not (Debugcom.Remote_value.is_block v) then - raise(Error(Not_initialized_yet root)); - Debugcom.Remote_value.field v pos - | Papply(p1, p2) -> - fatal_error "Eval.path: Papply" - -let rec expression event env = function - E_ident lid -> - begin try - let (p, valdesc) = Env.lookup_value lid env in - (begin match valdesc.val_kind with - Val_ivar (_, cl_num) -> - let (p0, _) = - Env.lookup_value (Longident.Lident ("self-" ^ cl_num)) env - in - let v = path event p0 in - let i = path event p in - Debugcom.Remote_value.field v (Debugcom.Remote_value.obj i) - | _ -> - path event p - end, - Ctype.correct_levels valdesc.val_type) - with Not_found -> - raise(Error(Unbound_long_identifier lid)) - end - | E_result -> - begin match event with - Some {ev_kind = Event_after ty} when !Frames.current_frame = 0 -> - (Debugcom.Remote_value.accu(), ty) - | _ -> - raise(Error(No_result)) - end - | E_name n -> - begin try - Printval.find_named_value n - with Not_found -> - raise(Error(Unknown_name n)) - end - | E_item(arg, n) -> - let (v, ty) = expression event env arg in - begin match (Ctype.repr(Ctype.expand_head env ty)).desc with - Ttuple ty_list -> - if n < 1 || n > List.length ty_list - then raise(Error(Tuple_index(ty, List.length ty_list, n))) - else (Debugcom.Remote_value.field v (n-1), List.nth ty_list (n-1)) - | Tconstr(path, [ty_arg], _) when Path.same path Predef.path_array -> - let size = Debugcom.Remote_value.size v in - if n >= size - then raise(Error(Array_index(size, n))) - else (Debugcom.Remote_value.field v n, ty_arg) - | Tconstr(path, [ty_arg], _) when Path.same path Predef.path_list -> - let rec nth pos v = - if not (Debugcom.Remote_value.is_block v) then - raise(Error(List_index(pos, n))) - else if pos = n then - (Debugcom.Remote_value.field v 0, ty_arg) - else - nth (pos + 1) (Debugcom.Remote_value.field v 1) - in nth 0 v - | Tconstr(path, [], _) when Path.same path Predef.path_string -> - let s = (Debugcom.Remote_value.obj v : string) in - if n >= String.length s - then raise(Error(String_index(s, String.length s, n))) - else (Debugcom.Remote_value.of_int(Char.code s.[n]), - Predef.type_char) - | _ -> - raise(Error(Wrong_item_type(ty, n))) - end - | E_field(arg, lbl) -> - let (v, ty) = expression event env arg in - begin match (Ctype.repr(Ctype.expand_head env ty)).desc with - Tconstr(path, args, _) -> - let tydesc = Env.find_type path env in - begin match tydesc.type_kind with - Type_record(lbl_list, repr, priv) -> - let (pos, ty_res) = - find_label lbl env ty path tydesc 0 lbl_list in - (Debugcom.Remote_value.field v pos, ty_res) - | _ -> raise(Error(Not_a_record ty)) - end - | _ -> raise(Error(Not_a_record ty)) - end - -and find_label lbl env ty path tydesc pos = function - [] -> - raise(Error(Wrong_label(ty, lbl))) - | (name, mut, ty_arg) :: rem -> - if name = lbl then begin - let ty_res = - Btype.newgenty(Tconstr(path, tydesc.type_params, ref Mnil)) - in - (pos, - try Ctype.apply env [ty_res] ty_arg [ty] with Ctype.Cannot_apply -> - abstract_type) - end else - find_label lbl env ty path tydesc (pos + 1) rem - -(* Error report *) - -open Format - -let report_error ppf = function - | Unbound_identifier id -> - fprintf ppf "@[Unbound identifier %s@]@." (Ident.name id) - | Not_initialized_yet path -> - fprintf ppf - "@[The module path %a is not yet initialized.@ \ - Please run program forward@ \ - until its initialization code is executed.@]@." - Printtyp.path path - | Unbound_long_identifier lid -> - fprintf ppf "@[Unbound identifier %a@]@." Printtyp.longident lid - | Unknown_name n -> - fprintf ppf "@[Unknown value name $%i@]@." n - | Tuple_index(ty, len, pos) -> - Printtyp.reset_and_mark_loops ty; - fprintf ppf - "@[Cannot extract field number %i from a %i-components \ - tuple of type@ %a@]@." - pos len Printtyp.type_expr ty - | Array_index(len, pos) -> - fprintf ppf - "@[Cannot extract element number %i from array of length %i@]@." pos len - | List_index(len, pos) -> - fprintf ppf - "@[Cannot extract element number %i from list of length %i@]@." pos len - | String_index(s, len, pos) -> - fprintf ppf - "@[Cannot extract character number %i@ \ - from the following string of length %i:@ %S@]@." - pos len s - | Wrong_item_type(ty, pos) -> - fprintf ppf - "@[Cannot extract item number %i from a value of type@ %a@]@." - pos Printtyp.type_expr ty - | Wrong_label(ty, lbl) -> - fprintf ppf - "@[The record type@ %a@ has no label named %s@]@." - Printtyp.type_expr ty lbl - | Not_a_record ty -> - fprintf ppf - "@[The type@ %a@ is not a record type@]@." Printtyp.type_expr ty - | No_result -> - fprintf ppf "@[No result available at current program event@]@." diff --git a/debugger/eval.mli b/debugger/eval.mli deleted file mode 100644 index b2a2998f14..0000000000 --- a/debugger/eval.mli +++ /dev/null @@ -1,40 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -open Types -open Parser_aux -open Format - -val expression : - Instruct.debug_event option -> Env.t -> expression -> - Debugcom.Remote_value.t * type_expr - -type error = - | Unbound_identifier of Ident.t - | Not_initialized_yet of Path.t - | Unbound_long_identifier of Longident.t - | Unknown_name of int - | Tuple_index of type_expr * int * int - | Array_index of int * int - | List_index of int * int - | String_index of string * int * int - | Wrong_item_type of type_expr * int - | Wrong_label of type_expr * string - | Not_a_record of type_expr - | No_result - -exception Error of error - -val report_error: formatter -> error -> unit diff --git a/debugger/events.ml b/debugger/events.ml deleted file mode 100644 index 5fb501ed34..0000000000 --- a/debugger/events.ml +++ /dev/null @@ -1,65 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(********************************* Events ******************************) - -open Instruct -open Primitives -open Checkpoints - -(* Previous `pc'. *) -(* Save time if `update_current_event' is called *) -(* several times at the same point. *) -let old_pc = ref (None : int option) - -(*** Current events. ***) - -(* Event at current position *) -let current_event = - ref (None : debug_event option) - -(* Recompute the current event *) -let update_current_event () = - match current_pc () with - None -> - current_event := None; - old_pc := None - | (Some pc) as opt_pc when opt_pc <> !old_pc -> - current_event := begin try - Some (Symbols.event_at_pc pc) - with Not_found -> - None - end; - old_pc := opt_pc - | _ -> - () - -(* Current position in source. *) -(* Raise `Not_found' if not on an event (beginning or end of program). *) -let current_point () = - match !current_event with - None -> - raise Not_found - | Some {ev_char = point; ev_module = mdle} -> - (mdle, point.Lexing.pos_cnum) - -let current_event_is_before () = - match !current_event with - None -> - raise Not_found - | Some {ev_kind = Event_before} -> - true - | _ -> - false diff --git a/debugger/events.mli b/debugger/events.mli deleted file mode 100644 index 8c47399571..0000000000 --- a/debugger/events.mli +++ /dev/null @@ -1,31 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -open Instruct - -(** Current events. **) - -(* The event at current position. *) -val current_event : debug_event option ref - -(* Recompute the current event *) -val update_current_event : unit -> unit - -(* Current position in source. *) -(* Raise `Not_found' if not on an event (beginning or end of program). *) -val current_point : unit -> string * int - -val current_event_is_before : unit -> bool - diff --git a/debugger/exec.ml b/debugger/exec.ml deleted file mode 100644 index d97a8c4e7d..0000000000 --- a/debugger/exec.ml +++ /dev/null @@ -1,50 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* Handling of keyboard interrupts *) - -let interrupted = ref false - -let is_protected = ref false - -let break signum = - if !is_protected - then interrupted := true - else raise Sys.Break - -let _ = - Sys.set_signal Sys.sigint (Sys.Signal_handle break); - Sys.set_signal Sys.sigpipe (Sys.Signal_handle (fun _ -> raise End_of_file)) - -let protect f = - if !is_protected then - f () - else begin - is_protected := true; - if not !interrupted then - f (); - is_protected := false; - if !interrupted then begin interrupted := false; raise Sys.Break end - end - -let unprotect f = - if not !is_protected then - f () - else begin - is_protected := false; - if !interrupted then begin interrupted := false; raise Sys.Break end; - f (); - is_protected := true - end diff --git a/debugger/exec.mli b/debugger/exec.mli deleted file mode 100644 index 9d3b986048..0000000000 --- a/debugger/exec.mli +++ /dev/null @@ -1,19 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* Handling of keyboard interrupts *) - -val protect : (unit -> unit) -> unit -val unprotect : (unit -> unit) -> unit diff --git a/debugger/frames.ml b/debugger/frames.ml deleted file mode 100644 index cb76e013a6..0000000000 --- a/debugger/frames.ml +++ /dev/null @@ -1,129 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(***************************** Frames **********************************) - -open Instruct -open Primitives -open Debugcom -open Checkpoints -open Events -open Symbols - -(* Current frame number *) -let current_frame = ref 0 - -(* Event at selected position *) -let selected_event = ref (None : debug_event option) - -(* Selected position in source. *) -(* Raise `Not_found' if not on an event. *) -let selected_point () = - match !selected_event with - None -> - raise Not_found - | Some {ev_char = point; ev_module = mdle} -> - (mdle, point.Lexing.pos_cnum) - -let selected_event_is_before () = - match !selected_event with - None -> - raise Not_found - | Some {ev_kind = Event_before} -> - true - | _ -> - false - -(* Move up `frame_count' frames, assuming current frame pointer - corresponds to event `event'. Return event of final frame. *) - -let rec move_up frame_count event = - if frame_count <= 0 then event else begin - let (sp, pc) = up_frame event.ev_stacksize in - if sp < 0 then raise Not_found; - move_up (frame_count - 1) (any_event_at_pc pc) - end - -(* Select a frame. *) -(* Raise `Not_found' if no such frame. *) -(* --- Assume the current events have already been updated. *) -let select_frame frame_number = - if frame_number < 0 then raise Not_found; - let (initial_sp, _) = get_frame() in - try - match !current_event with - None -> - raise Not_found - | Some curr_event -> - match !selected_event with - Some sel_event when frame_number >= !current_frame -> - selected_event := - Some(move_up (frame_number - !current_frame) sel_event); - current_frame := frame_number - | _ -> - set_initial_frame(); - selected_event := Some(move_up frame_number curr_event); - current_frame := frame_number - with Not_found -> - set_frame initial_sp; - raise Not_found - -(* Select a frame. *) -(* Same as `select_frame' but raise no exception if the frame is not found. *) -(* --- Assume the currents events have already been updated. *) -let try_select_frame frame_number = - try - select_frame frame_number - with - Not_found -> - () - -(* Return to default frame (frame 0). *) -let reset_frame () = - set_initial_frame(); - selected_event := !current_event; - current_frame := 0 - -(* Perform a stack backtrace. - Call the given function with the events for each stack frame, - or None if we've encountered a stack frame with no debugging info - attached. Stop when the function returns false, or frame with no - debugging info reached, or top of stack reached. *) - -let do_backtrace action = - match !current_event with - None -> Misc.fatal_error "Frames.do_backtrace" - | Some curr_ev -> - let (initial_sp, _) = get_frame() in - set_initial_frame(); - let event = ref curr_ev in - begin try - while action (Some !event) do - let (sp, pc) = up_frame !event.ev_stacksize in - if sp < 0 then raise Exit; - event := any_event_at_pc pc - done - with Exit -> () - | Not_found -> ignore (action None) - end; - set_frame initial_sp - -(* Return the number of frames in the stack *) - -let stack_depth () = - let num_frames = ref 0 in - do_backtrace (function Some ev -> incr num_frames; true - | None -> num_frames := -1; false); - !num_frames diff --git a/debugger/frames.mli b/debugger/frames.mli deleted file mode 100644 index 0906171f2e..0000000000 --- a/debugger/frames.mli +++ /dev/null @@ -1,55 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(****************************** Frames *********************************) - -open Instruct -open Primitives - -(* Current frame number *) -val current_frame : int ref - -(* Event at selected position. *) -val selected_event : debug_event option ref - -(* Selected position in source. *) -(* Raise `Not_found' if not on an event. *) -val selected_point : unit -> string * int - -val selected_event_is_before : unit -> bool - -(* Select a frame. *) -(* Raise `Not_found' if no such frame. *) -(* --- Assume the currents events have already been updated. *) -val select_frame : int -> unit - -(* Select a frame. *) -(* Same as `select_frame' but raise no exception if the frame is not found. *) -(* --- Assume the currents events have already been updated. *) -val try_select_frame : int -> unit - -(* Return to default frame (frame 0). *) -val reset_frame : unit -> unit - -(* Perform a stack backtrace. - Call the given function with the events for each stack frame, - or None if we've encountered a stack frame with no debugging info - attached. Stop when the function returns false, or frame with no - debugging info reached, or top of stack reached. *) -val do_backtrace : (debug_event option -> bool) -> unit - -(* Return the number of frames in the stack, or (-1) if it can't be - determined because some frames have no debugging info. *) -val stack_depth : unit -> int diff --git a/debugger/history.ml b/debugger/history.ml deleted file mode 100644 index 31a6e7ad2a..0000000000 --- a/debugger/history.ml +++ /dev/null @@ -1,44 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -open Int64ops -open Checkpoints -open Misc -open Primitives -open Debugger_config - -let history = ref ([] : int64 list) - -let empty_history () = - history := [] - -let add_current_time () = - let time = current_time () in - if !history = [] then - history := [time] - else if time <> List.hd !history then - history := list_truncate !history_size (time::!history) - -let previous_time_1 () = - match !history with - _::((time::_) as hist) -> - history := hist; time - | _ -> - prerr_endline "No more information."; raise Toplevel - -let rec previous_time n = - if n = _1 - then previous_time_1() - else begin ignore(previous_time_1()); previous_time(pre64 n) end diff --git a/debugger/history.mli b/debugger/history.mli deleted file mode 100644 index 249629fdb9..0000000000 --- a/debugger/history.mli +++ /dev/null @@ -1,20 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -val empty_history : unit -> unit - -val add_current_time : unit -> unit - -val previous_time : int64 -> int64 diff --git a/debugger/input_handling.ml b/debugger/input_handling.ml deleted file mode 100644 index 5aac814b9a..0000000000 --- a/debugger/input_handling.ml +++ /dev/null @@ -1,148 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(**************************** Input control ****************************) - -open Unix -open Primitives - -(*** Actives files. ***) - -(* List of the actives files. *) -let active_files = - ref ([] : (file_descr * ((io_channel -> unit) * io_channel)) list) - -(* Add a file to the list of actives files. *) -let add_file file controller = - active_files := (file.io_fd, (controller, file))::!active_files - -(* Remove a file from the list of actives files. *) -let remove_file file = - active_files := assoc_remove !active_files file.io_fd - -(* Change the controller for the given file. *) -let change_controller file controller = - remove_file file; add_file file controller - -(* Return the controller currently attached to the given file. *) -let current_controller file = - fst (List.assoc file.io_fd !active_files) - -(* Execute a function with `controller' attached to `file'. *) -(* ### controller file funct *) -let execute_with_other_controller controller file funct = - let old_controller = current_controller file in - change_controller file controller; - try - let result = funct () in - change_controller file old_controller; - result - with - x -> - change_controller file old_controller; - raise x - -(*** The "Main Loop" ***) - -let continue_main_loop = - ref true - -let exit_main_loop _ = - continue_main_loop := false - -(* Handle active files until `continue_main_loop' is false. *) -let main_loop () = - let old_state = !continue_main_loop in - try - continue_main_loop := true; - while !continue_main_loop do - try - let (input, _, _) = - select (List.map fst !active_files) [] [] (-1.) - in - List.iter - (function fd -> - let (funct, iochan) = (List.assoc fd !active_files) in - funct iochan) - input - with - Unix_error (EINTR, _, _) -> () - done; - continue_main_loop := old_state - with - x -> - continue_main_loop := old_state; - raise x - -(*** Managing user inputs ***) - -(* Are we in interactive mode ? *) -let interactif = ref true - -let current_prompt = ref "" - -(* Where the user input come from. *) -let user_channel = ref std_io - -let read_user_input buffer length = - main_loop (); - input !user_channel.io_in buffer 0 length - -(* Stop reading user input. *) -let stop_user_input () = - remove_file !user_channel - -(* Resume reading user input. *) -let resume_user_input () = - if not (List.mem_assoc !user_channel.io_fd !active_files) then begin - if !interactif then begin - print_string !current_prompt; - flush Pervasives.stdout - end; - add_file !user_channel exit_main_loop - end - -(* Ask user a yes or no question. *) -let yes_or_no message = - if !interactif then - let old_prompt = !current_prompt in - try - current_prompt := message ^ " ? (y or n) "; - let answer = - let rec ask () = - resume_user_input (); - let line = - string_trim (Lexer.line (Lexing.from_function read_user_input)) - in - stop_user_input (); - match (if String.length line > 0 then line.[0] else ' ') with - 'y' -> true - | 'n' -> false - | _ -> - print_string "Please answer y or n."; - print_newline (); - ask () - in - ask () - in - current_prompt := old_prompt; - answer - with - x -> - current_prompt := old_prompt; - stop_user_input (); - raise x - else - false diff --git a/debugger/input_handling.mli b/debugger/input_handling.mli deleted file mode 100644 index 872b880816..0000000000 --- a/debugger/input_handling.mli +++ /dev/null @@ -1,63 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(***************************** Input control ***************************) - -open Primitives - -(*** Actives files. ***) - -(* Add a file to the list of active files. *) -val add_file : io_channel -> (io_channel -> unit) -> unit - -(* Remove a file from the list of actives files. *) -val remove_file : io_channel -> unit - -(* Return the controller currently attached to the given file. *) -val current_controller : io_channel -> (io_channel -> unit) - -(* Execute a function with `controller' attached to `file'. *) -(* ### controller file funct *) -val execute_with_other_controller : - (io_channel -> unit) -> io_channel -> (unit -> 'a) -> 'a - -(*** The "Main Loop" ***) - -(* Call this function for exiting the main loop. *) -val exit_main_loop : 'a -> unit - -(* Handle active files until `continue_main_loop' is false. *) -val main_loop : unit -> unit - -(*** Managing user inputs ***) - -(* Are we in interactive mode ? *) -val interactif : bool ref - -val current_prompt : string ref - -(* Where the user input come from. *) -val user_channel : io_channel ref - -val read_user_input : string -> int -> int - -(* Stop reading user input. *) -val stop_user_input : unit -> unit - -(* Resume reading user input. *) -val resume_user_input : unit -> unit - -(* Ask user a yes or no question. *) -val yes_or_no : string -> bool diff --git a/debugger/int64ops.ml b/debugger/int64ops.ml deleted file mode 100644 index b854a6c343..0000000000 --- a/debugger/int64ops.ml +++ /dev/null @@ -1,26 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Damien Doligez, projet Moscova, INRIA Rocqencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(****************** arithmetic operators for Int64 *********************) - -let ( ++ ) = Int64.add;; -let ( -- ) = Int64.sub;; -let suc64 = Int64.succ;; -let pre64 = Int64.pred;; -let _0 = Int64.zero;; -let _1 = Int64.one;; -let _minus1 = Int64.minus_one;; -let ( ~~ ) = Int64.of_string;; -let max_small_int = Int64.of_int max_int;; -let to_int = Int64.to_int;; diff --git a/debugger/int64ops.mli b/debugger/int64ops.mli deleted file mode 100644 index 98f7228d3d..0000000000 --- a/debugger/int64ops.mli +++ /dev/null @@ -1,26 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Damien Doligez, projet Moscova, INRIA Rocqencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(****************** arithmetic operators for Int64 *********************) - -val ( ++ ) : int64 -> int64 -> int64;; -val ( -- ) : int64 -> int64 -> int64;; -val suc64 : int64 -> int64;; -val pre64 : int64 -> int64;; -val _0 : int64;; -val _1 : int64;; -val _minus1 : int64;; -val ( ~~ ) : string -> int64;; -val max_small_int : int64;; -val to_int : int64 -> int;; diff --git a/debugger/lexer.mll b/debugger/lexer.mll deleted file mode 100644 index 17293f62c4..0000000000 --- a/debugger/lexer.mll +++ /dev/null @@ -1,98 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -{ - -open Primitives -open Parser - -} - -rule line = (* Read a whole line *) - parse - ([ ^ '\n' '\r' ]* as s) ('\n' | '\r' | "\r\n") - { s } - | [ ^ '\n' '\r' ]* - { Lexing.lexeme lexbuf } - | eof - { raise Exit } - -and argument = (* Read a raw argument *) - parse - [ ^ ' ' '\t' ]+ - { ARGUMENT (Lexing.lexeme lexbuf) } - | [' ' '\t']+ - { argument lexbuf } - | eof - { EOL } - | _ - { raise Parsing.Parse_error } - -and line_argument = - parse - _ * - { ARGUMENT (Lexing.lexeme lexbuf) } - | eof - { EOL } - -and lexeme = (* Read a lexeme *) - parse - [' ' '\t'] + - { lexeme lexbuf } - | ['a'-'z' '\223'-'\246' '\248'-'\255' '_'] - (['A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255' - '\'' '0'-'9' ]) * - { LIDENT(Lexing.lexeme lexbuf) } - | ['A'-'Z' '\192'-'\214' '\216'-'\222' ] - (['A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255' - '\'' '0'-'9' ]) * - { UIDENT(Lexing.lexeme lexbuf) } - | '"' [^ '"']* "\"" - { let s = Lexing.lexeme lexbuf in - LIDENT(String.sub s 1 (String.length s - 2)) } - | ['0'-'9']+ - | '0' ['x' 'X'] ['0'-'9' 'A'-'F' 'a'-'f']+ - | '0' ['o' 'O'] ['0'-'7']+ - | '0' ['b' 'B'] ['0'-'1']+ - { INTEGER (Int64.of_string (Lexing.lexeme lexbuf)) } - | '*' - { STAR } - | "-" - { MINUS } - | "." - { DOT } - | "#" - { SHARP } - | "@" - { AT } - | "$" - { DOLLAR } - | "!" - { BANG } - | "(" - { LPAREN } - | ")" - { RPAREN } - | "[" - { LBRACKET } - | "]" - { RBRACKET } - | ['!' '?' '~' '=' '<' '>' '|' '&' '$' '@' '^' '+' '-' '*' '/' '%'] - ['!' '$' '%' '&' '*' '+' '-' '.' '/' ':' '<' '=' '>' '?' '@' '^' '|' '~'] * - { OPERATOR (Lexing.lexeme lexbuf) } - | eof - { EOL } - | _ - { raise Parsing.Parse_error } diff --git a/debugger/loadprinter.ml b/debugger/loadprinter.ml deleted file mode 100644 index ef86b7146e..0000000000 --- a/debugger/loadprinter.ml +++ /dev/null @@ -1,172 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1997 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* Loading and installation of user-defined printer functions *) - -open Misc -open Debugger_config -open Longident -open Path -open Types - -(* Error report *) - -type error = - | Load_failure of Dynlink.error - | Unbound_identifier of Longident.t - | Unavailable_module of string * Longident.t - | Wrong_type of Longident.t - | No_active_printer of Longident.t - -exception Error of error - -(* Symtable has global state, and normally holds the symbol table - for the debuggee. We need to switch it temporarily to the - symbol table for the debugger. *) - -let debugger_symtable = ref (None: Symtable.global_map option) - -let use_debugger_symtable fn arg = - let old_symtable = Symtable.current_state() in - begin match !debugger_symtable with - | None -> - Dynlink.init(); - Dynlink.allow_unsafe_modules true; - debugger_symtable := Some(Symtable.current_state()) - | Some st -> - Symtable.restore_state st - end; - try - let result = fn arg in - debugger_symtable := Some(Symtable.current_state()); - Symtable.restore_state old_symtable; - result - with exn -> - Symtable.restore_state old_symtable; - raise exn - -(* Load a .cmo or .cma file *) - -open Format - -let rec loadfiles ppf name = - try - let filename = find_in_path !Config.load_path name in - use_debugger_symtable Dynlink.loadfile filename; - let d = Filename.dirname name in - if d <> Filename.current_dir_name then begin - if not (List.mem d !Config.load_path) then - Config.load_path := d :: !Config.load_path; - end; - fprintf ppf "File %s loaded@." filename; - true - with - | Dynlink.Error (Dynlink.Unavailable_unit unit) -> - loadfiles ppf (String.uncapitalize unit ^ ".cmo") - && - loadfiles ppf name - | Not_found -> - fprintf ppf "Cannot find file %s@." name; - false - | Dynlink.Error e -> - raise(Error(Load_failure e)) - -let loadfile ppf name = - ignore(loadfiles ppf name) - -(* Return the value referred to by a path (as in toplevel/topdirs) *) -(* Note: evaluation proceeds in the debugger memory space, not in - the debuggee. *) - -let rec eval_path = function - Pident id -> Symtable.get_global_value id - | Pdot(p, s, pos) -> Obj.field (eval_path p) pos - | Papply(p1, p2) -> fatal_error "Loadprinter.eval_path" - -(* Install, remove a printer (as in toplevel/topdirs) *) - -let match_printer_type desc typename = - let (printer_type, _) = - try - Env.lookup_type (Ldot(Lident "Topdirs", typename)) Env.empty - with Not_found -> - raise (Error(Unbound_identifier(Ldot(Lident "Topdirs", typename)))) in - Ctype.init_def(Ident.current_time()); - Ctype.begin_def(); - let ty_arg = Ctype.newvar() in - Ctype.unify Env.empty - (Ctype.newconstr printer_type [ty_arg]) - (Ctype.instance desc.val_type); - Ctype.end_def(); - Ctype.generalize ty_arg; - ty_arg - -let find_printer_type lid = - try - let (path, desc) = Env.lookup_value lid Env.empty in - let (ty_arg, is_old_style) = - try - (match_printer_type desc "printer_type_new", false) - with Ctype.Unify _ -> - (match_printer_type desc "printer_type_old", true) in - (ty_arg, path, is_old_style) - with - | Not_found -> raise(Error(Unbound_identifier lid)) - | Ctype.Unify _ -> raise(Error(Wrong_type lid)) - -let install_printer ppf lid = - let (ty_arg, path, is_old_style) = find_printer_type lid in - let v = - try - use_debugger_symtable eval_path path - with Symtable.Error(Symtable.Undefined_global s) -> - raise(Error(Unavailable_module(s, lid))) in - let print_function = - if is_old_style then - (fun formatter repr -> (Obj.obj v) (Obj.obj repr)) - else - (fun formatter repr -> (Obj.obj v) formatter (Obj.obj repr)) in - Printval.install_printer path ty_arg ppf print_function - -let remove_printer lid = - let (ty_arg, path, is_old_style) = find_printer_type lid in - try - Printval.remove_printer path - with Not_found -> - raise(Error(No_active_printer lid)) - -(* Error report *) - -open Format - -let report_error ppf = function - | Load_failure e -> - fprintf ppf "@[Error during code loading: %s@]@." - (Dynlink.error_message e) - | Unbound_identifier lid -> - fprintf ppf "@[Unbound identifier %a@]@." - Printtyp.longident lid - | Unavailable_module(md, lid) -> - fprintf ppf - "@[The debugger does not contain the code for@ %a.@ \ - Please load an implementation of %s first.@]@." - Printtyp.longident lid md - | Wrong_type lid -> - fprintf ppf "@[%a has the wrong type for a printing function.@]@." - Printtyp.longident lid - | No_active_printer lid -> - fprintf ppf "@[%a is not currently active as a printing function.@]@." - Printtyp.longident lid - - diff --git a/debugger/loadprinter.mli b/debugger/loadprinter.mli deleted file mode 100644 index bdaf77a285..0000000000 --- a/debugger/loadprinter.mli +++ /dev/null @@ -1,34 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1997 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* Loading and installation of user-defined printer functions *) - -open Format - -val loadfile : formatter -> string -> unit -val install_printer : formatter -> Longident.t -> unit -val remove_printer : Longident.t -> unit - -(* Error report *) - -type error = - | Load_failure of Dynlink.error - | Unbound_identifier of Longident.t - | Unavailable_module of string * Longident.t - | Wrong_type of Longident.t - | No_active_printer of Longident.t - -exception Error of error - -val report_error: formatter -> error -> unit diff --git a/debugger/main.ml b/debugger/main.ml deleted file mode 100644 index 0bb2dda19c..0000000000 --- a/debugger/main.ml +++ /dev/null @@ -1,132 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -open Primitives -open Misc -open Input_handling -open Command_line -open Debugger_config -open Checkpoints -open Time_travel -open Parameters -open Program_management -open Frames -open Show_information -open Format - -let line_buffer = Lexing.from_function read_user_input - -let rec loop ppf = - line_loop ppf line_buffer; - if !loaded && (not (yes_or_no "The program is running. Quit anyway")) then - loop ppf - -let rec protect ppf loop = - try - loop ppf - with - | End_of_file -> - protect ppf (function ppf -> - forget_process - !current_checkpoint.c_fd - !current_checkpoint.c_pid; - pp_print_flush ppf (); - stop_user_input (); - loop ppf) - | Toplevel -> - protect ppf (function ppf -> - pp_print_flush ppf (); - stop_user_input (); - loop ppf) - | Sys.Break -> - protect ppf (function ppf -> - fprintf ppf "Interrupted.@."; - Exec.protect (function () -> - stop_user_input (); - if !loaded then begin - try_select_frame 0; - show_current_event ppf; - end); - loop ppf) - | Current_checkpoint_lost -> - protect ppf (function ppf -> - fprintf ppf "Trying to recover...@."; - stop_user_input (); - recover (); - try_select_frame 0; - show_current_event ppf; - loop ppf) - | x -> - kill_program (); - raise x - -let toplevel_loop () = protect Format.std_formatter loop - -(* Parsing of command-line arguments *) - -exception Found_program_name - -let anonymous s = - program_name := Unix_tools.make_absolute s; raise Found_program_name -let add_include d = - default_load_path := - Misc.expand_directory Config.standard_library d :: !default_load_path -let set_socket s = - socket_name := s -let set_checkpoints n = - checkpoint_max_count := n -let set_directory dir = - Sys.chdir dir -let set_emacs () = - emacs := true - -let speclist = - ["-I", Arg.String add_include, - " Add to the list of include directories"; - "-s", Arg.String set_socket, - " Set the name of the communication socket"; - "-c", Arg.Int set_checkpoints, - " Set max number of checkpoints kept"; - "-cd", Arg.String set_directory, - " Change working directory"; - "-emacs", Arg.Unit set_emacs, - "For running the debugger under emacs"] - -let main () = - try - socket_name := "/tmp/camldebug" ^ (string_of_int (Unix.getpid ())); - begin try - Arg.parse speclist anonymous ""; - Arg.usage speclist - "No program name specified\n\ - Usage: ocamldebug [options] [arguments]\n\ - Options are:"; - exit 2 - with Found_program_name -> - for j = !Arg.current + 1 to Array.length Sys.argv - 1 do - arguments := !arguments ^ " " ^ (Filename.quote Sys.argv.(j)) - done - end; - current_prompt := debugger_prompt; - printf "\tObjective Caml Debugger version %s@.@." Config.version; - Config.load_path := !default_load_path; - toplevel_loop (); (* Toplevel. *) - kill_program (); - exit 0 - with Toplevel -> - exit 2 - -let _ = - Printexc.catch (Unix.handle_unix_error main) () diff --git a/debugger/parameters.ml b/debugger/parameters.ml deleted file mode 100644 index 67078b2fc3..0000000000 --- a/debugger/parameters.ml +++ /dev/null @@ -1,35 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* Miscellaneous parameters *) - -open Primitives -open Config -open Misc - -let program_loaded = ref false -let program_name = ref "" -let socket_name = ref "" -let arguments = ref "" - -let default_load_path = - ref [ Filename.current_dir_name; Config.standard_library ] - -let add_path dir = - load_path := dir :: except dir !load_path; - Envaux.reset_cache() - -(* Used by emacs ? *) -let emacs = ref false diff --git a/debugger/parameters.mli b/debugger/parameters.mli deleted file mode 100644 index c80d39d124..0000000000 --- a/debugger/parameters.mli +++ /dev/null @@ -1,26 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* Miscellaneous parameters *) - -val program_name : string ref -val socket_name : string ref -val arguments : string ref -val default_load_path : string list ref - -val add_path : string -> unit - -(* Used by emacs ? *) -val emacs : bool ref diff --git a/debugger/parser.mly b/debugger/parser.mly deleted file mode 100644 index 6c7b2ddb26..0000000000 --- a/debugger/parser.mly +++ /dev/null @@ -1,239 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Jerome Vouillon, projet Cristal, INRIA Rocquencourt */ -/* Objective Caml port by John Malecki and Xavier Leroy */ -/* */ -/* Copyright 1996 Institut National de Recherche en Informatique et */ -/* en Automatique. All rights reserved. This file is distributed */ -/* under the terms of the Q Public License version 1.0. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -%{ - -open Int64ops -open Primitives -open Input_handling -open Longident -open Parser_aux - -%} - -%token ARGUMENT -%token LIDENT -%token UIDENT -%token OPERATOR -%token INTEGER -%token STAR /* * */ -%token MINUS /* - */ -%token DOT /* . */ -%token SHARP /* # */ -%token AT /* @ */ -%token DOLLAR /* $ */ -%token BANG /* ! */ -%token LPAREN /* ( */ -%token RPAREN /* ) */ -%token LBRACKET /* [ */ -%token RBRACKET /* ] */ -%token EOL - -%right DOT -%right BANG - -%start argument_list_eol -%type argument_list_eol - -%start argument_eol -%type argument_eol - -%start integer_list_eol -%type integer_list_eol - -%start integer_eol -%type integer_eol - -%start int64_eol -%type int64_eol - -%start integer -%type integer - -%start opt_integer_eol -%type opt_integer_eol - -%start opt_signed_integer_eol -%type opt_signed_integer_eol - -%start opt_signed_int64_eol -%type opt_signed_int64_eol - -%start identifier -%type identifier - -%start identifier_eol -%type identifier_eol - -%start identifier_or_eol -%type identifier_or_eol - -%start opt_identifier -%type opt_identifier - -%start opt_identifier_eol -%type opt_identifier_eol - -%start expression_list_eol -%type expression_list_eol - -%start break_argument_eol -%type break_argument_eol - -%start list_arguments_eol -%type list_arguments_eol - -%start end_of_line -%type end_of_line - -%start longident_eol -%type longident_eol - -%% - -/* Raw arguments */ - -argument_list_eol : - ARGUMENT argument_list_eol - { $1::$2 } - | end_of_line - { [] }; - -argument_eol : - ARGUMENT end_of_line - { $1 }; - -/* Integer */ - -integer_list_eol : - INTEGER integer_list_eol - { (to_int $1) :: $2 } - | end_of_line - { [] }; - -integer_eol : - INTEGER end_of_line - { to_int $1 }; - -int64_eol : - INTEGER end_of_line - { $1 }; - -integer : - INTEGER - { to_int $1 }; - -opt_integer_eol : - INTEGER end_of_line - { Some (to_int $1) } - | end_of_line - { None }; - -opt_int64_eol : - INTEGER end_of_line - { Some $1 } - | end_of_line - { None }; - -opt_signed_integer_eol : - MINUS integer_eol - { Some (- $2) } - | opt_integer_eol - { $1 }; - -opt_signed_int64_eol : - MINUS int64_eol - { Some (Int64.neg $2) } - | opt_int64_eol - { $1 }; - -/* Identifiers and long identifiers */ - -longident : - LIDENT { Lident $1 } - | module_path DOT LIDENT { Ldot($1, $3) } - | OPERATOR { Lident $1 } -; - -module_path : - UIDENT { Lident $1 } - | module_path DOT UIDENT { Ldot($1, $3) } -; - -longident_eol : - longident end_of_line { $1 }; - -identifier : - LIDENT { $1 } - | UIDENT { $1 }; - -identifier_eol : - identifier end_of_line { $1 }; - -identifier_or_eol : - identifier { Some $1 } - | end_of_line { None }; - -opt_identifier : - identifier { Some $1 } - | { None }; - -opt_identifier_eol : - opt_identifier end_of_line { $1 }; - -/* Expressions */ - -expression: - longident { E_ident $1 } - | STAR { E_result } - | DOLLAR INTEGER { E_name (to_int $2) } - | expression DOT INTEGER { E_item($1, (to_int $3)) } - | expression DOT LBRACKET INTEGER RBRACKET { E_item($1, (to_int $4)) } - | expression DOT LPAREN INTEGER RPAREN { E_item($1, (to_int $4)) } - | expression DOT LIDENT { E_field($1, $3) } - | BANG expression { E_field($2, "contents") } - | LPAREN expression RPAREN { $2 } -; - -/* Lists of expressions */ - -expression_list_eol : - expression expression_list_eol { $1::$2 } - | end_of_line { [] } -; - -/* Arguments for breakpoint */ - -break_argument_eol : - end_of_line { BA_none } - | integer_eol { BA_pc $1 } - | expression end_of_line { BA_function $1 } - | AT opt_identifier INTEGER opt_integer_eol { BA_pos1 ($2, (to_int $3), $4)} - | AT opt_identifier SHARP integer_eol { BA_pos2 ($2, $4) } -; - -/* Arguments for list */ - -list_arguments_eol : - opt_identifier integer opt_integer_eol - { ($1, Some $2, $3) } - | opt_identifier_eol - { ($1, None, None) }; - -/* End of line */ - -end_of_line : - EOL { stop_user_input () } -; diff --git a/debugger/parser_aux.mli b/debugger/parser_aux.mli deleted file mode 100644 index 7ea63fb8c2..0000000000 --- a/debugger/parser_aux.mli +++ /dev/null @@ -1,34 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(*open Globals*) - -open Primitives - -type expression = - E_ident of Longident.t (* x or Mod.x *) - | E_name of int (* $xxx *) - | E_item of expression * int (* x.1 x.[2] x.(3) *) - | E_field of expression * string (* x.lbl !x *) - | E_result - -type break_arg = - BA_none (* break *) - | BA_pc of int (* break PC *) - | BA_function of expression (* break FUNCTION *) - | BA_pos1 of string option * int * int option - (* break @ [MODULE] LINE [POS] *) - | BA_pos2 of string option * int (* break @ [MODULE] # OFFSET *) - diff --git a/debugger/pattern_matching.ml b/debugger/pattern_matching.ml deleted file mode 100644 index a04dcae5b0..0000000000 --- a/debugger/pattern_matching.ml +++ /dev/null @@ -1,251 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(************************ Simple pattern matching **********************) - -open Debugger_config -(*open Primitives*) -open Misc -(*open Const*) -(*open Globals*) -(*open Builtins*) -open Typedtree -(*open Modules*) -(*open Symtable*) -(*open Value*) -open Parser_aux - -(* -let rec find_constr tag = function - [] -> - fatal_error "find_constr: unknown constructor for this type" - | constr::rest -> - match constr.info.cs_tag with - ConstrRegular(t, _) -> - if t == tag then constr else find_constr tag rest - | ConstrExtensible _ -> - fatal_error "find_constr: extensible" - -let find_exception tag = - let (qualid, stamp) = get_exn_of_num tag in - let rec select_exn = function - [] -> - raise Not_found - | constr :: rest -> - match constr.info.cs_tag with - ConstrExtensible(_,st) -> - if st == stamp then constr else select_exn rest - | ConstrRegular(_,_) -> - fatal_error "find_exception: regular" in - select_exn(hashtbl__find_all (find_module qualid.qual).mod_constrs qualid.id) -*) - -let error_matching () = - prerr_endline "Pattern matching failed"; - raise Toplevel - -(* -let same_name {qualid = name1} = - function - GRname name2 -> - (name2 = "") || (name1.id = name2) - | GRmodname name2 -> - name1 = name2 - -let check_same_constr constr constr2 = - try - if not (same_name constr constr2) then - error_matching () - with - Desc_not_found -> - prerr_endline "Undefined constructor."; - raise Toplevel -*) - -let rec pattern_matching pattern obj ty = - match pattern with - P_dummy -> - [] - | P_variable var -> - [var, obj, ty] - | _ -> - match (Ctype.repr ty).desc with - Tvar | Tarrow _ -> - error_matching () - | Ttuple(ty_list) -> - (match pattern with - P_tuple pattern_list -> - pattern_matching_list pattern_list obj ty_list - | P_nth (n, patt) -> - if n >= List.length ty_list then - (prerr_endline "Out of range."; raise Toplevel); - pattern_matching patt (Debugcom.get_field obj n) (List.nth ty_list n) - | _ -> - error_matching ()) - | Tconstr(cstr, [ty_arg],_) when same_type_constr cstr constr_type_list -> - (match pattern with - P_list pattern_list -> - let (last, list) = - it_list - (fun (current, list) pattern -> - if value_tag current = 0 then error_matching (); - (Debugcom.get_field current 1, - (pattern, Debugcom.get_field current 0)::list)) - (obj, []) - pattern_list - in - if value_tag last <> 0 then error_matching (); - flat_map - (function (x, y) -> pattern_matching x y ty_arg) - (rev list) - | P_nth (n, patt) -> - let rec find k current = - if value_tag current = 0 then - (prerr_endline "Out of range."; raise Toplevel); - if k = 0 then - pattern_matching patt (Debugcom.get_field current 0) ty_arg - else - find (k - 1) (Debugcom.get_field current 1) - in - find n obj - | P_concat (pattern1, pattern2) -> - if value_tag obj == 0 then error_matching (); - (pattern_matching pattern1 (Debugcom.get_field obj 0) ty_arg) - @ (pattern_matching pattern2 (Debugcom.get_field obj 1) ty) - | _ -> - error_matching ()) - | Tconstr(cstr, [ty_arg]) when same_type_constr cstr constr_type_vect -> - (match pattern with - P_nth (n, patt) -> - if n >= value_size obj then - (prerr_endline "Out of range."; raise Toplevel); - pattern_matching patt (Debugcom.get_field obj n) ty_arg - | _ -> - error_matching ()) - | Tconstr(cstr, ty_list) -> - (match cstr.info.ty_abbr with - Tabbrev(params, body) -> - pattern_matching pattern obj (expand_abbrev params body ty_list) - | _ -> - match_concrete_type pattern obj cstr ty ty_list) - -and match_concrete_type pattern obj cstr ty ty_list = - let typ_descr = - type_descr_of_type_constr cstr in - match typ_descr.info.ty_desc with - Abstract_type -> - error_matching () - | Variant_type constr_list -> - let tag = value_tag obj in - (try - let constr = - if same_type_constr cstr constr_type_exn then - find_exception tag - else - find_constr tag constr_list - in - let (ty_res, ty_arg) = - type_pair_instance (constr.info.cs_res, constr.info.cs_arg) - in - filter (ty_res, ty); - match constr.info.cs_kind with - Constr_constant -> - error_matching () - | Constr_regular -> - (match pattern with - P_constr (constr2, patt) -> - check_same_constr constr constr2; - pattern_matching patt (Debugcom.get_field obj 0) ty_arg - | _ -> - error_matching ()) - | Constr_superfluous n -> - (match pattern with - P_constr (constr2, patt) -> - check_same_constr constr constr2; - (match patt with - P_tuple pattern_list -> - pattern_matching_list - pattern_list - obj - (filter_product n ty_arg) - | P_nth (n2, patt) -> - let ty_list = filter_product n ty_arg in - if n2 >= n then - (prerr_endline "Out of range."; - raise Toplevel); - pattern_matching - patt - (Debugcom.get_field obj n2) - (List.nth ty_list n2) - | P_variable var -> - [var, - obj, - {typ_desc = Tproduct (filter_product n ty_arg); - typ_level = generic}] - | P_dummy -> - [] - | _ -> - error_matching ()) - | _ -> - error_matching ()) - with - Not_found -> - error_matching () - | Unify -> - fatal_error "pattern_matching: types should match") - | Record_type label_list -> - let match_field (label, patt) = - let lbl = - try - primitives__find - (function l -> same_name l label) - label_list - with Not_found -> - prerr_endline "Label not found."; - raise Toplevel - in - let (ty_res, ty_arg) = - type_pair_instance (lbl.info.lbl_res, lbl.info.lbl_arg) - in - (try - filter (ty_res, ty) - with Unify -> - fatal_error "pattern_matching: types should match"); - pattern_matching patt (Debugcom.get_field obj lbl.info.lbl_pos) ty_arg - in - (match pattern with - P_record pattern_label_list -> - flat_map match_field pattern_label_list - | _ -> - error_matching ()) - | Abbrev_type(_,_) -> - fatal_error "pattern_matching: abbrev type" - -and pattern_matching_list pattern_list obj ty_list = - let val_list = - try - pair__combine (pattern_list, ty_list) - with - Invalid_argument _ -> error_matching () - in - flat_map - (function (x, y, z) -> pattern_matching x y z) - (rev - (snd - (it_list - (fun (num, list) (pattern, typ) -> - (num + 1, (pattern, Debugcom.get_field obj num, typ)::list)) - (0, []) - val_list))) diff --git a/debugger/pattern_matching.mli b/debugger/pattern_matching.mli deleted file mode 100644 index 3490edef69..0000000000 --- a/debugger/pattern_matching.mli +++ /dev/null @@ -1,21 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(************************ Simple pattern matching **********************) - -open Parser_aux - -val pattern_matching : - pattern -> Debugcom.remote_value -> Typedtree.type_expr -> (string * Debugcom.remote_value * Typedtree.type_expr) list;; diff --git a/debugger/pos.ml b/debugger/pos.ml deleted file mode 100644 index 235de121d0..0000000000 --- a/debugger/pos.ml +++ /dev/null @@ -1,37 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Damien Doligez, projet Moscova, INRIA Rocquencourt *) -(* *) -(* Copyright 2003 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -open Instruct;; -open Lexing;; -open Primitives;; -open Source;; - -let get_desc ev = - if ev.ev_char.pos_fname <> "" - then Printf.sprintf "file %s, line %d, character %d" - ev.ev_char.pos_fname ev.ev_char.pos_lnum - (ev.ev_char.pos_cnum - ev.ev_char.pos_bol + 1) - else begin - let filename = source_of_module ev.ev_module in - try - let (start, line) = line_of_pos (get_buffer ev.ev_module) - ev.ev_char.pos_cnum - in - Printf.sprintf "file %s, line %d, character %d" - filename line (ev.ev_char.pos_cnum - start + 1) - with Not_found | Out_of_range -> - Printf.sprintf "file %s, character %d" - filename (ev.ev_char.pos_cnum + 1) - end -;; diff --git a/debugger/pos.mli b/debugger/pos.mli deleted file mode 100644 index e7632e4274..0000000000 --- a/debugger/pos.mli +++ /dev/null @@ -1,15 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Damien Doligez, projet Moscova, INRIA Rocquencourt *) -(* *) -(* Copyright 2003 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -val get_desc : Instruct.debug_event -> string;; diff --git a/debugger/primitives.ml b/debugger/primitives.ml deleted file mode 100644 index 1ad27e8a68..0000000000 --- a/debugger/primitives.ml +++ /dev/null @@ -1,194 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(*********************** Basic functions and types *********************) - -(*** Miscellaneous ***) -exception Out_of_range - -let nothing _ = () - -(*** Operations on lists. ***) - -(* Remove an element from a list *) -let except e l = - let rec except_e = function - [] -> [] - | elem::l -> if e = elem then l else elem::except_e l - in except_e l - -(* Position of an element in a list. Head of list has position 0. *) -let index a l = - let rec index_rec i = function - [] -> raise Not_found - | b::l -> if a = b then i else index_rec (i + 1) l - in index_rec 0 l - -(* Remove an element from an association list *) -let assoc_remove lst elem = - let rec remove = - function - [] -> [] - | ((a, _) as c::t) -> - if a = elem then t - else c::(remove t) - in remove lst - -(* Nth element of a list. *) -let rec list_nth p0 p1 = - match (p0,p1) with - ([], _) -> - invalid_arg "list_nth" - | ((a::_), 0) -> - a - | ((_::l), n) -> - list_nth l (n - 1) - -(* Return the `n' first elements of `l' *) -(* ### n l -> l' *) -let rec list_truncate = - fun - p0 p1 -> match (p0,p1) with (0, _) -> [] - | (_, []) -> [] - | (n, (a::l)) -> a::(list_truncate (n - 1) l) - -(* Separe the `n' first elements of `l' and the others *) -(* ### n list -> (first, last) *) -let rec list_truncate2 = - fun - p0 p1 -> match (p0,p1) with (0, l) -> - ([], l) - | (_, []) -> - ([], []) - | (n, (a::l)) -> - let (first, last) = (list_truncate2 (n - 1) l) in - (a::first, last) - -(* Replace x by y in list l *) -(* ### x y l -> l' *) -let list_replace x y = - let rec repl = - function - [] -> [] - | a::l -> - if a == x then y::l - else a::(repl l) - in repl - -(* Filter `list' according to `predicate'. *) -(* ### predicate list -> list' *) -let filter p = - let rec filter2 = - function - [] -> - [] - | a::l -> - if p a then - a::(filter2 l) - else - filter2 l - in filter2 - -(* Find the first element `element' of `list' *) -(* so that `predicate element' holds. *) -(* ### predicate list -> element *) -let find p = - let rec find2 = - function - [] -> - raise Not_found - | a::l -> - if p a then a - else find2 l - in find2 - -(*** Operations on strings. ***) - -(* Return the position of the first occurence of char `c' in string `s' *) -(* Raise `Not_found' if `s' does not contain `c'. *) -(* ### c s -> pos *) -let string_pos s c = - let i = ref 0 and l = String.length s in - while !i < l && String.get s !i != c do i := !i + 1 done; - if !i = l then raise Not_found; - !i - -(* Remove blanks (spaces and tabs) at beginning and end of a string. *) -let is_space = function - | ' ' | '\t' -> true | _ -> false - -let string_trim s = - let l = String.length s and i = ref 0 in - while - !i < l && is_space (String.get s !i) - do - incr i - done; - let j = ref (l - 1) in - while - !j >= !i && is_space (String.get s !j) - do - decr j - done; - String.sub s !i (!j - !i + 1) - -(* isprefix s1 s2 returns true if s1 is a prefix of s2. *) - -let isprefix s1 s2 = - let l1 = String.length s1 and l2 = String.length s2 in - (l1 = l2 && s1 = s2) || (l1 < l2 && s1 = String.sub s2 0 l1) - -(* Split a string at the given delimiter char *) - -let split_string sep str = - let rec split i j = - if j >= String.length str then - if i >= j then [] else [String.sub str i (j-i)] - else if str.[j] = sep then - if i >= j - then skip_sep (j+1) - else String.sub str i (j-i) :: skip_sep (j+1) - else - split i (j+1) - and skip_sep j = - if j < String.length str && str.[j] = sep - then skip_sep (j+1) - else split j j - in split 0 0 - -(*** I/O channels ***) - -type io_channel = { - io_in : in_channel; - io_out : out_channel; - io_fd : Unix.file_descr - } - -let io_channel_of_descr fd = { - io_in = Unix.in_channel_of_descr fd; - io_out = Unix.out_channel_of_descr fd; - io_fd = fd - } - -let close_io io_channel = - close_out_noerr io_channel.io_out; - close_in_noerr io_channel.io_in; -;; - -let std_io = { - io_in = stdin; - io_out = stdout; - io_fd = Unix.stdin - } diff --git a/debugger/primitives.mli b/debugger/primitives.mli deleted file mode 100644 index 40effea556..0000000000 --- a/debugger/primitives.mli +++ /dev/null @@ -1,86 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(********************* Basic functions and types ***********************) - -(*** Miscellaneous ***) -val nothing : 'a -> unit - -(*** Types and exceptions. ***) -exception Out_of_range - -(*** Operations on lists. ***) - -(* Remove an element from a list *) -val except : 'a -> 'a list -> 'a list - -(* Position of an element in a list. Head of list has position 0. *) -val index : 'a -> 'a list -> int - -(* Remove on element from an association list. *) -val assoc_remove : ('a * 'b) list -> 'a -> ('a * 'b) list - -(* Nth element of a list. *) -val list_nth : 'a list -> int -> 'a - -(* Return the `n' first elements of `l'. *) -(* ### n l -> l' *) -val list_truncate : int -> 'a list -> 'a list - -(* Separe the `n' first elements of `l' and the others. *) -(* ### n list -> (first, last) *) -val list_truncate2 : int -> 'a list -> 'a list * 'a list - -(* Replace x by y in list l *) -(* ### x y l -> l' *) -val list_replace : 'a -> 'a -> 'a list -> 'a list - -(* Filter `list' according to `predicate'. *) -(* ### predicate list -> list' *) -val filter : ('a -> bool) -> 'a list -> 'a list - -(* Find the first element `element' of `list' *) -(* so that `predicate element' holds. *) -(* Raise `Not_found' if no such element. *) -(* ### predicate list -> element *) -val find : ('a -> bool) -> 'a list -> 'a - -(*** Operations on strings. ***) - -(* Return the position of the first occurence of char `c' in string `s' *) -(* Raise `Not_found' if `s' does not contain `c'. *) -(* ### c s -> pos *) -val string_pos : string -> char -> int - -(* Remove blanks (spaces and tabs) at beginning and end of a string. *) -val string_trim : string -> string - -(* isprefix s1 s2 returns true if s1 is a prefix of s2. *) -val isprefix : string -> string -> bool - -(* Split a string at the given delimiter char *) -val split_string : char -> string -> string list - -(*** I/O channels ***) - -type io_channel = { - io_in : in_channel; - io_out : out_channel; - io_fd : Unix.file_descr - } - -val io_channel_of_descr : Unix.file_descr -> io_channel -val close_io : io_channel -> unit -val std_io : io_channel diff --git a/debugger/printval.ml b/debugger/printval.ml deleted file mode 100644 index 4fa3055b04..0000000000 --- a/debugger/printval.ml +++ /dev/null @@ -1,111 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* To print values *) - -open Misc -open Obj -open Format -open Parser_aux -open Path -open Types - -(* To name printed and ellipsed values *) - -let named_values = - (Hashtbl.create 29 : (int, Debugcom.Remote_value.t * type_expr) Hashtbl.t) -let next_name = ref 1 - -let reset_named_values () = - Hashtbl.clear named_values; - next_name := 1 - -let name_value v ty = - let name = !next_name in - incr next_name; - Hashtbl.add named_values name (v, ty); - name - -let find_named_value name = - Hashtbl.find named_values name - -let check_depth ppf depth obj ty = - if depth <= 0 then begin - let n = name_value obj ty in - Some (Outcometree.Oval_stuff ("$" ^ string_of_int n)) - end else None - -module EvalPath = - struct - type value = Debugcom.Remote_value.t - exception Error - let rec eval_path = function - Pident id -> - begin try - Debugcom.Remote_value.global (Symtable.get_global_position id) - with Symtable.Error _ -> - raise Error - end - | Pdot(root, fieldname, pos) -> - let v = eval_path root in - if not (Debugcom.Remote_value.is_block v) - then raise Error - else Debugcom.Remote_value.field v pos - | Papply(p1, p2) -> - raise Error - let same_value = Debugcom.Remote_value.same - end - -module Printer = Genprintval.Make(Debugcom.Remote_value)(EvalPath) - -let install_printer path ty ppf fn = - Printer.install_printer path ty - (fun ppf remote_val -> - try - fn ppf (Obj.repr (Debugcom.Remote_value.obj remote_val)) - with - Debugcom.Marshalling_error -> - fprintf ppf "") - -let remove_printer = Printer.remove_printer - -let max_printer_depth = ref 20 -let max_printer_steps = ref 300 - -let print_exception ppf obj = - let t = Printer.outval_of_untyped_exception obj in - !Oprint.out_value ppf t - -let print_value max_depth env obj (ppf : Format.formatter) ty = - let t = - Printer.outval_of_value !max_printer_steps max_depth - (check_depth ppf) env obj ty in - !Oprint.out_value ppf t - -let print_named_value max_depth exp env obj ppf ty = - let print_value_name ppf = function - | E_ident lid -> - Printtyp.longident ppf lid - | E_name n -> - fprintf ppf "$%i" n - | _ -> - let n = name_value obj ty in - fprintf ppf "$%i" n in - Printtyp.reset_and_mark_loops ty; - fprintf ppf "@[<2>%a :@ %a@ =@ %a@]@." - print_value_name exp - Printtyp.type_expr ty - (print_value max_depth env obj) ty - diff --git a/debugger/printval.mli b/debugger/printval.mli deleted file mode 100644 index d100a4333b..0000000000 --- a/debugger/printval.mli +++ /dev/null @@ -1,33 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -open Format - -val max_printer_depth : int ref -val max_printer_steps : int ref - -val print_exception: formatter -> Debugcom.Remote_value.t -> unit -val print_named_value : - int -> Parser_aux.expression -> Env.t -> - Debugcom.Remote_value.t -> formatter -> Types.type_expr -> - unit - -val reset_named_values : unit -> unit -val find_named_value : int -> Debugcom.Remote_value.t * Types.type_expr - -val install_printer : - Path.t -> Types.type_expr -> formatter -> - (formatter -> Obj.t -> unit) -> unit -val remove_printer : Path.t -> unit diff --git a/debugger/program_loading.ml b/debugger/program_loading.ml deleted file mode 100644 index edcf3b1ed7..0000000000 --- a/debugger/program_loading.ml +++ /dev/null @@ -1,114 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* Program loading *) - -open Unix -open Misc -open Debugger_config -open Parameters -open Input_handling - -(*** Debugging. ***) - -let debug_loading = ref false - -(*** Load a program. ***) - -(* Function used for launching the program. *) -let launching_func = ref (function () -> ()) - -let load_program () = - !launching_func (); - main_loop () - -(*** Launching functions. ***) - -(* A generic function for launching the program *) -let generic_exec cmdline = function () -> - if !debug_loading then - prerr_endline "Launching program..."; - let child = - try - fork () - with x -> - Unix_tools.report_error x; - raise Toplevel in - match child with - 0 -> - begin try - match fork () with - 0 -> (* Try to detach the process from the controlling terminal, - so that it does not receive SIGINT on ctrl-C. *) - begin try ignore(setsid()) with Invalid_argument _ -> () end; - execv shell [| shell; "-c"; cmdline() |] - | _ -> exit 0 - with x -> - Unix_tools.report_error x; - exit 1 - end - | _ -> - match wait () with - (_, WEXITED 0) -> () - | _ -> raise Toplevel - -(* Execute the program by calling the runtime explicitely *) -let exec_with_runtime = - generic_exec - (function () -> - Printf.sprintf "CAML_DEBUG_SOCKET=%s %s %s %s" - !socket_name - runtime_program - !program_name - !arguments) - -(* Excute the program directly *) -let exec_direct = - generic_exec - (function () -> - Printf.sprintf "CAML_DEBUG_SOCKET=%s %s %s" - !socket_name - !program_name - !arguments) - -(* Ask the user. *) -let exec_manual = - function () -> - print_newline (); - print_string "Waiting for connection..."; - print_string ("(the socket is " ^ !socket_name ^ ")"); - print_newline () - -(*** Selection of the launching function. ***) - -type launching_function = (unit -> unit) - -let loading_modes = - ["direct", exec_direct; - "runtime", exec_with_runtime; - "manual", exec_manual] - -let set_launching_function func = - launching_func := func - -(* Initialization *) - -let _ = - set_launching_function exec_direct - -(*** Connection. ***) - -let connection = ref Primitives.std_io -let connection_opened = ref false diff --git a/debugger/program_loading.mli b/debugger/program_loading.mli deleted file mode 100644 index d1210d1ab0..0000000000 --- a/debugger/program_loading.mli +++ /dev/null @@ -1,34 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(*** Debugging. ***) - -val debug_loading : bool ref - -(*** Load program ***) - -(* Function used for launching the program. *) -val launching_func : (unit -> unit) ref - -val load_program : unit -> unit - -type launching_function = (unit -> unit) - -val loading_modes : (string * launching_function) list -val set_launching_function : launching_function -> unit - -(** Connection **) -val connection : Primitives.io_channel ref -val connection_opened : bool ref diff --git a/debugger/program_management.ml b/debugger/program_management.ml deleted file mode 100644 index ec5877fc26..0000000000 --- a/debugger/program_management.ml +++ /dev/null @@ -1,157 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* Manage the loading of the program *) - -open Int64ops -open Unix -open Unix_tools -open Debugger_config -open Misc -open Instruct -open Primitives -open Parameters -open Input_handling -open Debugcom -open Program_loading -open Time_travel - -(*** Connection opening and control. ***) - -(* Name of the file if the socket is in the unix domain.*) -let file_name = ref (None : string option) - -(* Default connection handler. *) -let buffer = String.create 1024 -let control_connection pid fd = - if (read fd.io_fd buffer 0 1024) = 0 then - forget_process fd pid - else begin - prerr_string "Garbage data from process "; - prerr_int pid; - prerr_endline "" - end - -(* Accept a connection from another process. *) -let accept_connection continue fd = - let (sock, _) = accept fd.io_fd in - let io_chan = io_channel_of_descr sock in - let pid = input_binary_int io_chan.io_in in - if pid = -1 then begin - let pid' = input_binary_int io_chan.io_in in - new_checkpoint pid' io_chan; - Input_handling.add_file io_chan (control_connection pid'); - continue () - end - else begin - if set_file_descriptor pid io_chan then - Input_handling.add_file io_chan (control_connection pid) - end - -(* Initialize the socket. *) -let open_connection address continue = - try - let (sock_domain, sock_address) = convert_address address in - file_name := - (match sock_address with - ADDR_UNIX file -> - Some file - | _ -> - None); - let sock = socket sock_domain SOCK_STREAM 0 in - (try - bind sock sock_address; - listen sock 3; - connection := io_channel_of_descr sock; - Input_handling.add_file !connection (accept_connection continue); - connection_opened := true - with x -> close sock; raise x) - with - Failure _ -> raise Toplevel - | (Unix_error _) as err -> report_error err; raise Toplevel - -(* Close the socket. *) -let close_connection () = - if !connection_opened then begin - connection_opened := false; - Input_handling.remove_file !connection; - close_io !connection; - match !file_name with - Some file -> - unlink file - | None -> - () - end - -(*** Kill program. ***) -let loaded = ref false - -let kill_program () = - Breakpoints.remove_all_breakpoints (); - History.empty_history (); - kill_all_checkpoints (); - loaded := false; - close_connection () - -let ask_kill_program () = - if not !loaded then - true - else - let answer = yes_or_no "A program is being debugged already. Kill it" in - if answer then - kill_program (); - answer - -(*** Program loading and initializations. ***) - -let initialize_loading () = - if !debug_loading then - prerr_endline "Loading debugging informations..."; - begin try access !program_name [F_OK] - with Unix_error _ -> - prerr_endline "Program not found."; - raise Toplevel; - end; - Symbols.read_symbols !program_name; - if !debug_loading then - prerr_endline "Opening a socket..."; - open_connection !socket_name - (function () -> - go_to _0; - Symbols.set_all_events(); - exit_main_loop ()) - -(* Ensure the program is already loaded. *) -let ensure_loaded () = - if not !loaded then begin - print_string "Loading program... "; - flush Pervasives.stdout; - if !program_name = "" then begin - prerr_endline "No program specified."; - raise Toplevel - end; - try - initialize_loading(); - !launching_func (); - if !debug_loading then - prerr_endline "Waiting for connection..."; - main_loop (); - loaded := true; - prerr_endline "done." - with - x -> - kill_program(); - raise x - end diff --git a/debugger/program_management.mli b/debugger/program_management.mli deleted file mode 100644 index 8e2f28e54e..0000000000 --- a/debugger/program_management.mli +++ /dev/null @@ -1,27 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(*** Program loading and initializations. ***) - -val loaded : bool ref -val ensure_loaded : unit -> unit - -(*** Kill program. ***) -val kill_program : unit -> unit - -(* Ask wether to kill the program or not. *) -(* If yes, kill it. *) -(* Return true iff the program has been killed. *) -val ask_kill_program : unit -> bool diff --git a/debugger/show_information.ml b/debugger/show_information.ml deleted file mode 100644 index 7492ddc2e1..0000000000 --- a/debugger/show_information.ml +++ /dev/null @@ -1,94 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -open Instruct -open Format -open Primitives -open Debugcom -open Checkpoints -open Events -open Symbols -open Frames -open Show_source -open Breakpoints - -(* Display information about the current event. *) -let show_current_event ppf = - fprintf ppf "Time : %Li" (current_time ()); - (match current_pc () with - | Some pc -> - fprintf ppf " - pc : %i" pc - | _ -> ()); - update_current_event (); - reset_frame (); - match current_report () with - | None -> - fprintf ppf "@.Beginning of program.@."; - show_no_point () - | Some {rep_type = (Event | Breakpoint); rep_program_pointer = pc} -> - let (mdle, point) = current_point () in - fprintf ppf " - module %s@." mdle; - (match breakpoints_at_pc pc with - | [] -> - () - | [breakpoint] -> - fprintf ppf "Breakpoint : %i@." breakpoint - | breakpoints -> - fprintf ppf "Breakpoints : %a@." - (fun ppf l -> - List.iter - (function x -> fprintf ppf "%i " x) l) - (List.sort compare breakpoints)); - show_point mdle point (current_event_is_before ()) true - | Some {rep_type = Exited} -> - fprintf ppf "@.Program exit.@."; - show_no_point () - | Some {rep_type = Uncaught_exc} -> - fprintf ppf - "@.Program end.@.\ - @[Uncaught exception:@ %a@]@." - Printval.print_exception (Debugcom.Remote_value.accu ()); - show_no_point () - | Some {rep_type = Trap_barrier} -> - (* Trap_barrier not visible outside *) - (* of module `time_travel'. *) - Misc.fatal_error "Show_information.show_current_event" - -(* Display short information about one frame. *) - -let show_one_frame framenum ppf event = - fprintf ppf "#%i Pc : %i %s char %i@." - framenum event.ev_pos event.ev_module event.ev_char.Lexing.pos_cnum - -(* Display information about the current frame. *) -(* --- `select frame' must have succeded before calling this function. *) -let show_current_frame ppf selected = - match !selected_event with - | None -> - fprintf ppf "@.No frame selected.@." - | Some sel_ev -> - show_one_frame !current_frame ppf sel_ev; - begin match breakpoints_at_pc sel_ev.ev_pos with - | [] -> () - | [breakpoint] -> - fprintf ppf "Breakpoint : %i@." breakpoint - | breakpoints -> - fprintf ppf "Breakpoints : %a@." - (fun ppf l -> - List.iter (function x -> fprintf ppf "%i " x) l) - (List.sort compare breakpoints); - end; - show_point sel_ev.ev_module sel_ev.ev_char.Lexing.pos_cnum - (selected_event_is_before ()) selected diff --git a/debugger/show_information.mli b/debugger/show_information.mli deleted file mode 100644 index 3069f93321..0000000000 --- a/debugger/show_information.mli +++ /dev/null @@ -1,26 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -open Format;; - -(* Display information about the current event. *) -val show_current_event : formatter -> unit;; - -(* Display information about the current frame. *) -(* --- `select frame' must have succeded before calling this function. *) -val show_current_frame : formatter -> bool -> unit;; - -(* Display short information about one frame. *) -val show_one_frame : int -> formatter -> Instruct.debug_event -> unit diff --git a/debugger/show_source.ml b/debugger/show_source.ml deleted file mode 100644 index dd798cd5c8..0000000000 --- a/debugger/show_source.ml +++ /dev/null @@ -1,79 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -open Debugger_config -open Parameters -open Misc -open Primitives -open Source -open Printf - -(* Print a line; return the beginning of the next line *) -let print_line buffer line_number start point before = - let next = next_linefeed buffer start - and content = buffer_content buffer - in - printf "%i " line_number; - if point <= next && point >= start then - (print_string (String.sub content start (point - start)); - print_string (if before then event_mark_before else event_mark_after); - print_string (String.sub content point (next - point))) - else - print_string (String.sub content start (next - start)); - print_newline (); - next - -(* Tell Emacs we are nowhere in the source. *) -let show_no_point () = - if !emacs then printf "\026\026H\n" - -(* Print the line containing the point *) -let show_point mdle point before selected = - if !emacs && selected then - begin try - let source = source_of_module mdle in - printf "\026\026M%s:%i" source point; - printf "%s\n" (if before then ":before" else ":after") - with - Not_found -> (* get_buffer *) - prerr_endline ("No source file for " ^ mdle ^ "."); - show_no_point () - end - else - begin try - let buffer = get_buffer mdle in - let (start, line_number) = line_of_pos buffer point in - ignore(print_line buffer line_number start point before) - with - Out_of_range -> (* line_of_pos *) - prerr_endline "Position out of range." - | Not_found -> (* get_buffer *) - prerr_endline ("No source file for " ^ mdle ^ ".") - end - -(* Display part of the source. *) -let show_listing mdle start stop point before = - try - let buffer = get_buffer mdle in - let rec aff (line_start, line_number) = - if line_number <= stop then - aff (print_line buffer line_number line_start point before + 1, line_number + 1) - in - aff (pos_of_line buffer start) - with - Out_of_range -> (* pos_of_line *) - prerr_endline "Position out of range." - | Not_found -> (* get_buffer *) - prerr_endline ("No source file for " ^ mdle ^ ".") diff --git a/debugger/show_source.mli b/debugger/show_source.mli deleted file mode 100644 index 29f2f8c67e..0000000000 --- a/debugger/show_source.mli +++ /dev/null @@ -1,23 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* Print the line containing the point *) -val show_point : string -> int -> bool -> bool -> unit;; - -(* Tell Emacs we are nowhere in the source. *) -val show_no_point : unit -> unit;; - -(* Display part of the source. *) -val show_listing : string -> int -> int -> int -> bool -> unit;; diff --git a/debugger/source.ml b/debugger/source.ml deleted file mode 100644 index f937c782a0..0000000000 --- a/debugger/source.ml +++ /dev/null @@ -1,153 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(************************ Source management ****************************) - -open Misc -open Primitives - -(*** Conversion function. ***) - -let source_of_module mdle = - find_in_path_uncap !Config.load_path (mdle ^ ".ml") - -(*** Buffer cache ***) - -(* Buffer and cache (to associate lines and positions in the buffer). *) -type buffer = string * (int * int) list ref - -let buffer_max_count = ref 10 - -let cache_size = 30 - -let buffer_list = - ref ([] : (string * buffer) list) - -let flush_buffer_list () = - buffer_list := [] - -let get_buffer mdle = - try List.assoc mdle !buffer_list with - Not_found -> - let inchan = open_in_bin (source_of_module mdle) in - let (content, _) as buffer = - (String.create (in_channel_length inchan), ref []) - in - unsafe_really_input inchan content 0 (in_channel_length inchan); - buffer_list := - (list_truncate !buffer_max_count ((mdle, buffer)::!buffer_list)); - buffer - -let buffer_content = - (fst : buffer -> string) - -let buffer_length x = - String.length (buffer_content x) - -(*** Position conversions. ***) - -type position = int * int - -(* Insert a new pair (position, line) in the cache of the given buffer. *) -let insert_pos buffer ((position, line) as pair) = - let rec new_list = - function - [] -> - [(position, line)] - | ((pos, lin) as a::l) as l' -> - if lin < line then - pair::l' - else if lin = line then - l' - else - a::(new_list l) - in - let buffer_cache = snd buffer in - buffer_cache := new_list !buffer_cache - -(* Position of the next linefeed after `pos'. *) -(* Position just after the buffer end if no linefeed found. *) -(* Raise `Out_of_range' if already there. *) -let next_linefeed (buffer, _) pos = - let len = String.length buffer in - if pos >= len then - raise Out_of_range - else - let rec search p = - if p = len || String.get buffer p = '\n' then - p - else - search (succ p) - in - search pos - -(* Go to next line. *) -let next_line buffer (pos, line) = - (next_linefeed buffer pos + 1, line + 1) - -(* Convert a position in the buffer to a line number. *) -let line_of_pos buffer position = - let rec find = - function - | [] -> - if position < 0 then - raise Out_of_range - else - (0, 1) - | ((pos, line) as pair)::l -> - if pos > position then - find l - else - pair - and find_line previous = - let (pos, line) as next = next_line buffer previous in - if pos <= position then - find_line next - else - previous - in - let result = find_line (find !(snd buffer)) in - insert_pos buffer result; - result - -(* Convert a line number to a position. *) -let pos_of_line buffer line = - let rec find = - function - [] -> - if line <= 0 then - raise Out_of_range - else - (0, 1) - | ((pos, lin) as pair)::l -> - if lin > line then - find l - else - pair - and find_pos previous = - let (_, lin) as next = next_line buffer previous in - if lin <= line then - find_pos next - else - previous - in - let result = find_pos (find !(snd buffer)) in - insert_pos buffer result; - result - -(* Convert a coordinate (line / column) into a position. *) -(* --- The first line and column are line 1 and column 1. *) -let point_of_coord buffer line column = - fst (pos_of_line buffer line) + (pred column) diff --git a/debugger/source.mli b/debugger/source.mli deleted file mode 100644 index cfd5fe0705..0000000000 --- a/debugger/source.mli +++ /dev/null @@ -1,58 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(************************ Source management ****************************) - -(*** Conversion function. ***) - -val source_of_module: string -> string - -(*** buffer cache ***) - -type buffer - -val buffer_max_count : int ref - -val flush_buffer_list : unit -> unit - -val get_buffer : string -> buffer - -val buffer_content : buffer -> string -val buffer_length : buffer -> int - -(*** Position conversions. ***) - -(* Pair (position, line) where `position' is the position in character of *) -(* the beginning of the line (first character is 0) and `line' is its *) -(* number (first line number is 1). *) -type position = int * int - -(* Position of the next linefeed after `pos'. *) -(* Position just after the buffer end if no linefeed found. *) -(* Raise `Out_of_range' if already there. *) -val next_linefeed : buffer -> int -> int - -(* Go to next line. *) -val next_line : buffer -> position -> position - -(* Convert a position in the buffer to a line number. *) -val line_of_pos : buffer -> int -> position - -(* Convert a line number to a position. *) -val pos_of_line : buffer -> int -> position - -(* Convert a coordinate (line / column) into a position. *) -(* --- The first line and column are line 1 and column 1. *) -val point_of_coord : buffer -> int -> int -> int diff --git a/debugger/symbols.ml b/debugger/symbols.ml deleted file mode 100644 index 031bec6402..0000000000 --- a/debugger/symbols.ml +++ /dev/null @@ -1,169 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* Handling of symbol tables (globals and events) *) - -open Instruct -open Debugger_config (* Toplevel *) - -let modules = - ref ([] : string list) - -let events = - ref ([] : debug_event list) -let events_by_pc = - (Hashtbl.create 257 : (int, debug_event) Hashtbl.t) -let events_by_module = - (Hashtbl.create 17 : (string, debug_event array) Hashtbl.t) -let all_events_by_module = - (Hashtbl.create 17 : (string, debug_event list) Hashtbl.t) - -let relocate_event orig ev = - ev.ev_pos <- orig + ev.ev_pos; - match ev.ev_repr with - Event_parent repr -> repr := ev.ev_pos - | _ -> () - -let read_symbols' bytecode_file = - let ic = open_in_bin bytecode_file in - begin try - Bytesections.read_toc ic; - ignore(Bytesections.seek_section ic "SYMB"); - with Bytesections.Bad_magic_number | Not_found -> - prerr_string bytecode_file; prerr_endline " is not a bytecode file."; - raise Toplevel - end; - Symtable.restore_state (input_value ic); - begin try - ignore (Bytesections.seek_section ic "DBUG") - with Not_found -> - prerr_string bytecode_file; prerr_endline " has no debugging info."; - raise Toplevel - end; - let num_eventlists = input_binary_int ic in - let eventlists = ref [] in - for i = 1 to num_eventlists do - let orig = input_binary_int ic in - let evl = (input_value ic : debug_event list) in - (* Relocate events in event list *) - List.iter (relocate_event orig) evl; - eventlists := evl :: !eventlists - done; - close_in_noerr ic; - !eventlists - -let read_symbols bytecode_file = - let all_events = read_symbols' bytecode_file in - - modules := []; events := []; - Hashtbl.clear events_by_pc; Hashtbl.clear events_by_module; - Hashtbl.clear all_events_by_module; - - List.iter - (fun evl -> - List.iter - (fun ev -> - events := ev :: !events; - Hashtbl.add events_by_pc ev.ev_pos ev) - evl) - all_events; - - List.iter - (function - [] -> () - | ev :: _ as evl -> - let md = ev.ev_module in - let cmp ev1 ev2 = compare ev1.ev_char.Lexing.pos_cnum - ev2.ev_char.Lexing.pos_cnum - in - let sorted_evl = List.sort cmp evl in - modules := md :: !modules; - Hashtbl.add all_events_by_module md sorted_evl; - let real_evl = - Primitives.filter - (function - {ev_kind = Event_pseudo} -> false - | _ -> true) - sorted_evl - in - Hashtbl.add events_by_module md (Array.of_list real_evl)) - all_events - -let any_event_at_pc pc = - Hashtbl.find events_by_pc pc - -let event_at_pc pc = - let ev = any_event_at_pc pc in - match ev.ev_kind with - Event_pseudo -> raise Not_found - | _ -> ev - -let set_event_at_pc pc = - try ignore(event_at_pc pc); Debugcom.set_event pc - with Not_found -> () - -(* List all events in module *) -let events_in_module mdle = - try - Hashtbl.find all_events_by_module mdle - with Not_found -> - [] - -(* Binary search of event at or just after char *) -let find_event ev char = - let rec bsearch lo hi = - if lo >= hi then begin - if ev.(hi).ev_char.Lexing.pos_cnum < char then raise Not_found; - hi - end else begin - let pivot = (lo + hi) / 2 in - let e = ev.(pivot) in - if char <= e.ev_char.Lexing.pos_cnum then bsearch lo pivot - else bsearch (pivot + 1) hi - end - in - bsearch 0 (Array.length ev - 1) - -(* Return first event after the given position. *) -(* Raise [Not_found] if module is unknown or no event is found. *) -let event_at_pos md char = - let ev = Hashtbl.find events_by_module md in - ev.(find_event ev char) - -(* Return event closest to given position *) -(* Raise [Not_found] if module is unknown or no event is found. *) -let event_near_pos md char = - let ev = Hashtbl.find events_by_module md in - try - let pos = find_event ev char in - (* Desired event is either ev.(pos) or ev.(pos - 1), - whichever is closest *) - if pos > 0 && char - ev.(pos - 1).ev_char.Lexing.pos_cnum - <= ev.(pos).ev_char.Lexing.pos_cnum - char - then ev.(pos - 1) - else ev.(pos) - with Not_found -> - let pos = Array.length ev - 1 in - if pos < 0 then raise Not_found; - ev.(pos) - -(* Flip "event" bit on all instructions *) -let set_all_events () = - Hashtbl.iter - (fun pc ev -> - match ev.ev_kind with - Event_pseudo -> () - | _ -> Debugcom.set_event ev.ev_pos) - events_by_pc diff --git a/debugger/symbols.mli b/debugger/symbols.mli deleted file mode 100644 index 0cb1e2e573..0000000000 --- a/debugger/symbols.mli +++ /dev/null @@ -1,44 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* Modules used by the program. *) -val modules : string list ref - -(* Read debugging info from executable file *) -val read_symbols : string -> unit - -(* Flip "event" bit on all instructions *) -val set_all_events : unit -> unit - -(* Return event at given PC, or raise Not_found *) -(* Can also return pseudo-event at beginning of functions *) -val any_event_at_pc : int -> Instruct.debug_event - -(* Return event at given PC, or raise Not_found *) -val event_at_pc : int -> Instruct.debug_event -(* Set event at given PC *) -val set_event_at_pc : int -> unit - -(* List the events in `module'. *) -val events_in_module : string -> Instruct.debug_event list - -(* First event after the given position. *) -(* --- Raise `Not_found' if no such event. *) -val event_at_pos : string -> int -> Instruct.debug_event - -(* Closest event from given position. *) -(* --- Raise `Not_found' if no such event. *) -val event_near_pos : string -> int -> Instruct.debug_event - diff --git a/debugger/time_travel.ml b/debugger/time_travel.ml deleted file mode 100644 index eb98f1059c..0000000000 --- a/debugger/time_travel.ml +++ /dev/null @@ -1,642 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(**************************** Time travel ******************************) - -open Int64ops -open Instruct -open Events -open Debugcom -open Primitives -open Checkpoints -open Breakpoints -open Trap_barrier -open Input_handling -open Debugger_config -open Program_loading - -exception Current_checkpoint_lost - -let remove_1st key list = - let rec remove = - function - [] -> [] - | a::l -> if a == key then l else a::(remove l) - in - remove list - -(*** Debugging. ***) - -let debug_time_travel = ref false - -(*** Internal utilities. ***) - -(* Insert a checkpoint in the checkpoint list. - * Raise `Exit' if there is already a checkpoint at the same time. - *) -let insert_checkpoint ({c_time = time} as checkpoint) = - let rec traverse = - function - [] -> [checkpoint] - | (({c_time = t} as a)::l) as l' -> - if t > time then - a::(traverse l) - else if t = time then - raise Exit - else - checkpoint::l' - in - checkpoints := traverse !checkpoints - -(* Remove a checkpoint from the checkpoint list. - * --- No error if not found. - *) -let remove_checkpoint checkpoint = - checkpoints := remove_1st checkpoint !checkpoints - -(* Wait for the process used by `checkpoint' to connect. - * --- Usually not called (the process is already connected). - *) -let wait_for_connection checkpoint = - try - Exec.unprotect - (function () -> - let old_controller = Input_handling.current_controller !connection in - execute_with_other_controller - (function - fd -> - old_controller fd; - if checkpoint.c_valid = true then - exit_main_loop ()) - !connection - main_loop) - with - Sys.Break -> - checkpoint.c_parent <- root; - remove_checkpoint checkpoint; - checkpoint.c_pid <- -1; - raise Sys.Break - -(* Select a checkpoint as current. *) -let set_current_checkpoint checkpoint = - if !debug_time_travel then - prerr_endline ("Select : " ^ (string_of_int checkpoint.c_pid)); - if not checkpoint.c_valid then - wait_for_connection checkpoint; - current_checkpoint := checkpoint; - set_current_connection checkpoint.c_fd - -(* Kill `checkpoint'. *) -let kill_checkpoint checkpoint = - if !debug_time_travel then - prerr_endline ("Kill : " ^ (string_of_int checkpoint.c_pid)); - if checkpoint.c_pid > 0 then (* Ghosts don't have to be killed ! *) - (if not checkpoint.c_valid then - wait_for_connection checkpoint; - stop checkpoint.c_fd; - if checkpoint.c_parent.c_pid > 0 then - wait_child checkpoint.c_parent.c_fd; - checkpoint.c_parent <- root; - close_io checkpoint.c_fd; - remove_file checkpoint.c_fd; - remove_checkpoint checkpoint); - checkpoint.c_pid <- -1 (* Don't exist anymore *) - -(*** Cleaning the checkpoint list. ***) - -(* Separe checkpoints before (<=) and after (>) `t'. *) -(* ### t checkpoints -> (after, before) *) -let cut t = - let rec cut_t = - function - [] -> ([], []) - | ({c_time = t'} as a::l) as l' -> - if t' <= t then - ([], l') - else - let (b, e) = cut_t l in - (a::b, e) - in - cut_t - -(* Partition the checkpoints list. *) -let cut2 t0 t l = - let rec cut2_t0 t = - function - [] -> [] - | l -> - let (after, before) = cut (t0 -- t -- _1) l in - let l = cut2_t0 (t ++ t) before in - after::l - in - let (after, before) = cut (t0 -- _1) l in - after::(cut2_t0 t before) - -(* Separe first elements and last element of a list of checkpoint. *) -let chk_merge2 cont = - let rec chk_merge2_cont = - function - [] -> cont - | [a] -> - let (accepted, rejected) = cont in - (a::accepted, rejected) - | a::l -> - let (accepted, rejected) = chk_merge2_cont l in - (accepted, a::rejected) - in chk_merge2_cont - -(* Separe the checkpoint list. *) -(* ### list -> accepted * rejected *) -let rec chk_merge = - function - [] -> ([], []) - | l::tail -> - chk_merge2 (chk_merge tail) l - -let new_checkpoint_list checkpoint_count accepted rejected = - if List.length accepted >= checkpoint_count then - let (k, l) = list_truncate2 checkpoint_count accepted in - (k, l @ rejected) - else - let (k, l) = - list_truncate2 (checkpoint_count - List.length accepted) rejected - in - (List.merge (fun {c_time = t1} {c_time = t2} -> compare t2 t1) accepted k, - l) - -(* Clean the checkpoint list. *) -(* Reference time is `time'. *) -let clean_checkpoints time checkpoint_count = - let (after, before) = cut time !checkpoints in - let (accepted, rejected) = - chk_merge (cut2 time !checkpoint_small_step before) - in - let (kept, lost) = - new_checkpoint_list checkpoint_count accepted after - in - List.iter kill_checkpoint (lost @ rejected); - checkpoints := kept - -(*** Internal functions for moving. ***) - -(* Find the first checkpoint before (or at) `time'. - * Ask for reloading the program if necessary. - *) -let find_checkpoint_before time = - let rec find = - function - [] -> - print_string "Can't go that far in the past !"; print_newline (); - if yes_or_no "Reload program" then begin - load_program (); - find !checkpoints - end - else - raise Toplevel - | { c_time = t } as a::l -> - if t > time then - find l - else - a - in find !checkpoints - -(* Make a copy of the current checkpoint and clean the checkpoint list. *) -(* --- The new checkpoint in not put in the list. *) -let duplicate_current_checkpoint () = - let checkpoint = !current_checkpoint in - if not checkpoint.c_valid then - wait_for_connection checkpoint; - let new_checkpoint = (* Ghost *) - {c_time = checkpoint.c_time; - c_pid = 0; - c_fd = checkpoint.c_fd; - c_valid = false; - c_report = checkpoint.c_report; - c_state = C_stopped; - c_parent = checkpoint; - c_breakpoint_version = checkpoint.c_breakpoint_version; - c_breakpoints = checkpoint.c_breakpoints; - c_trap_barrier = checkpoint.c_trap_barrier} - in - checkpoints := list_replace checkpoint new_checkpoint !checkpoints; - set_current_checkpoint checkpoint; - clean_checkpoints (checkpoint.c_time ++ _1) (!checkpoint_max_count - 1); - if new_checkpoint.c_pid = 0 then (* The ghost has not been killed *) - (match do_checkpoint () with (* Duplicate checkpoint *) - Checkpoint_done pid -> - (new_checkpoint.c_pid <- pid; - if !debug_time_travel then - prerr_endline ("Waiting for connection : " ^ (string_of_int pid))) - | Checkpoint_failed -> - prerr_endline - "A fork failed. Reducing maximum number of checkpoints."; - checkpoint_max_count := List.length !checkpoints - 1; - remove_checkpoint new_checkpoint) - -(* Was the movement interrupted ? *) -(* --- An exception could have been used instead, *) -(* --- but it is not clear where it should be caught. *) -(* --- For instance, it should not be caught in `step' *) -(* --- (as `step' is used in `next_1'). *) -(* --- On the other side, other modules does not need to know *) -(* --- about this exception. *) -let interrupted = ref false - -(* Informations about last breakpoint encountered *) -let last_breakpoint = ref None - -(* Ensure we stop on an event. *) -let rec stop_on_event report = - match report with - {rep_type = Breakpoint; rep_program_pointer = pc; - rep_stack_pointer = sp} -> - last_breakpoint := Some (pc, sp); - update_current_event (); - begin match !current_event with - None -> find_event () - | Some _ -> () - end - | {rep_type = Trap_barrier; rep_stack_pointer = trap_frame} -> - (* No event at current position. *) - find_event () - | _ -> - () - -and find_event () = - if !debug_time_travel then begin - print_string "Searching next event..."; - print_newline () - end; - let report = do_go _1 in - !current_checkpoint.c_report <- Some report; - stop_on_event report - -(* Internal function for running debugged program. - * Requires `duration > 0'. - *) -let internal_step duration = - match current_report () with - Some {rep_type = Exited | Uncaught_exc} -> () - | _ -> - Exec.protect - (function () -> - if !make_checkpoints then - duplicate_current_checkpoint () - else - remove_checkpoint !current_checkpoint; - update_breakpoints (); - update_trap_barrier (); - !current_checkpoint.c_state <- C_running duration; - let report = do_go duration in - !current_checkpoint.c_report <- Some report; - !current_checkpoint.c_state <- C_stopped; - if report.rep_type = Event then begin - !current_checkpoint.c_time <- - !current_checkpoint.c_time ++ duration; - interrupted := false; - last_breakpoint := None - end - else begin - !current_checkpoint.c_time <- - !current_checkpoint.c_time ++ duration - -- (Int64.of_int report.rep_event_count) ++ _1; - interrupted := true; - last_breakpoint := None; - stop_on_event report - end; - (try - insert_checkpoint !current_checkpoint - with - Exit -> - kill_checkpoint !current_checkpoint; - set_current_checkpoint - (find_checkpoint_before (current_time ())))); - if !debug_time_travel then begin - print_string "Checkpoints : pid(time)"; print_newline (); - List.iter - (function {c_time = time; c_pid = pid; c_valid = valid} -> - Printf.printf "%d(%Ld)%s " pid time - (if valid then "" else "(invalid)")) - !checkpoints; - print_newline () - end - -(*** Miscellaneous functions (exported). ***) - -(* Create a checkpoint at time 0 (new program). *) -let new_checkpoint pid fd = - let new_checkpoint = - {c_time = _0; - c_pid = pid; - c_fd = fd; - c_valid = true; - c_report = None; - c_state = C_stopped; - c_parent = root; - c_breakpoint_version = 0; - c_breakpoints = []; - c_trap_barrier = 0} - in - insert_checkpoint new_checkpoint - -(* Set the file descriptor of a checkpoint *) -(* (a new process has connected with the debugger). *) -(* --- Return `true' on success (close the connection otherwise). *) -let set_file_descriptor pid fd = - let rec find = - function - [] -> - prerr_endline "Unexpected connection"; - close_io fd; - false - | ({c_pid = pid'} as checkpoint)::l -> - if pid <> pid' then - find l - else - (checkpoint.c_fd <- fd; - checkpoint.c_valid <- true; - true) - in - if !debug_time_travel then - prerr_endline ("New connection : " ^(string_of_int pid)); - find (!current_checkpoint::!checkpoints) - -(* Kill all the checkpoints. *) -let kill_all_checkpoints () = - List.iter kill_checkpoint (!current_checkpoint::!checkpoints) - -(* Kill a checkpoint without killing the process. *) -(* (used when connection with the process is lost). *) -(* --- Assume that the checkpoint is valid. *) -let forget_process fd pid = - let checkpoint = - find (function c -> c.c_pid = pid) (!current_checkpoint::!checkpoints) - in - Printf.eprintf "Lost connection with process %d" pid; - if checkpoint = !current_checkpoint then begin - Printf.eprintf " (active process)\n"; - match !current_checkpoint.c_state with - C_stopped -> - Printf.eprintf "at time %Ld" !current_checkpoint.c_time - | C_running duration -> - Printf.eprintf "between time %Ld and time %Ld" - !current_checkpoint.c_time - (!current_checkpoint.c_time ++ duration) - end; - Printf.eprintf "\n"; flush stderr; - Input_handling.remove_file fd; - close_io checkpoint.c_fd; - remove_file checkpoint.c_fd; - remove_checkpoint checkpoint; - checkpoint.c_pid <- -1; (* Don't exist anymore *) - if checkpoint.c_parent.c_pid > 0 then - wait_child checkpoint.c_parent.c_fd; - if checkpoint = !current_checkpoint then - raise Current_checkpoint_lost - -(* Try to recover when the current checkpoint is lost. *) -let recover () = - set_current_checkpoint - (find_checkpoint_before (current_time ())) - -(*** Simple movements. ***) - -(* Forward stepping. Requires `duration >= 0'. *) -let rec step_forward duration = - if duration > !checkpoint_small_step then begin - let first_step = - if duration > !checkpoint_big_step then - !checkpoint_big_step - else - !checkpoint_small_step - in - internal_step first_step; - if not !interrupted then - step_forward (duration -- first_step) - end - else if duration != _0 then - internal_step duration - -(* Go to time `time' from current checkpoint (internal). *) -let internal_go_to time = - let duration = time -- (current_time ()) in - if duration > _0 then - execute_without_breakpoints (function () -> step_forward duration) - -(* Move to a given time. *) -let go_to time = - let checkpoint = find_checkpoint_before time in - set_current_checkpoint checkpoint; - internal_go_to time - -(* Return the time of the last breakpoint *) -(* between current time and `max_time'. *) -let rec find_last_breakpoint max_time = - let rec find break = - let time = current_time () in - step_forward (max_time -- time); - match !last_breakpoint, !temporary_breakpoint_position with - (Some _, _) when current_time () < max_time -> - find !last_breakpoint - | (Some (pc, _), Some pc') when pc = pc' -> - (max_time, !last_breakpoint) - | _ -> - (time, break) - in - find - (match current_pc_sp () with - (Some (pc, _)) as state when breakpoint_at_pc pc -> state - | _ -> None) - - -(* Run from `time_max' back to `time'. *) -(* --- Assume 0 <= time < time_max *) -let rec back_to time time_max = - let - {c_time = t} as checkpoint = find_checkpoint_before (pre64 time_max) - in - go_to (max time t); - let (new_time, break) = find_last_breakpoint time_max in - if break <> None || (new_time <= time) then begin - go_to new_time; - interrupted := break <> None; - last_breakpoint := break - end else - back_to time new_time - -(* Backward stepping. *) -(* --- Assume duration > 1 *) -let step_backward duration = - let time = current_time () in - if time > _0 then - back_to (max _0 (time -- duration)) time - -(* Run the program from current time. *) -(* Stop at the first breakpoint, or at the end of the program. *) -let rec run () = - internal_step !checkpoint_big_step; - if not !interrupted then - run () - -(* Run backward the program form current time. *) -(* Stop at the first breakpoint, or at the beginning of the program. *) -let back_run () = - if current_time () > _0 then - back_to _0 (current_time ()) - -(* Step in any direction. *) -(* Stop at the first brakpoint, or after `duration' steps. *) -let step duration = - if duration >= _0 then - step_forward duration - else - step_backward (_0 -- duration) - -(*** Next, finish. ***) - -(* Finish current function. *) -let finish () = - update_current_event (); - match !current_event with - None -> - prerr_endline "`finish' not meaningful in outermost frame."; - raise Toplevel - | Some curr_event -> - set_initial_frame(); - let (frame, pc) = up_frame curr_event.ev_stacksize in - if frame < 0 then begin - prerr_endline "`finish' not meaningful in outermost frame."; - raise Toplevel - end; - begin - try ignore(Symbols.any_event_at_pc pc) - with Not_found -> - prerr_endline "Calling function has no debugging information."; - raise Toplevel - end; - exec_with_trap_barrier - frame - (fun () -> - exec_with_temporary_breakpoint - pc - (fun () -> - while - run (); - match !last_breakpoint with - Some (pc', frame') when pc = pc' -> - interrupted := false; - frame <> frame' - | _ -> - false - do - () - done)) - -let next_1 () = - update_current_event (); - match !current_event with - None -> (* Beginning of the program. *) - step _1 - | Some event1 -> - let (frame1, pc1) = initial_frame() in - step _1; - if not !interrupted then begin - update_current_event (); - match !current_event with - None -> () - | Some event2 -> - let (frame2, pc2) = initial_frame() in - (* Call `finish' if we've entered a function. *) - if frame1 >= 0 && frame2 >= 0 && - frame2 - event2.ev_stacksize > frame1 - event1.ev_stacksize - then finish() - end - -(* Same as `step' (forward) but skip over function calls. *) -let rec next = - function - 0 -> () - | n -> - next_1 (); - if not !interrupted then - next (n - 1) - -(* Run backward until just before current function. *) -let start () = - update_current_event (); - match !current_event with - None -> - prerr_endline "`start not meaningful in outermost frame."; - raise Toplevel - | Some curr_event -> - let (frame, _) = initial_frame() in - let (frame', pc) = up_frame curr_event.ev_stacksize in - if frame' < 0 then begin - prerr_endline "`start not meaningful in outermost frame."; - raise Toplevel - end; - let nargs = - match - try Symbols.any_event_at_pc pc with Not_found -> - prerr_endline "Calling function has no debugging information."; - raise Toplevel - with - {ev_info = Event_return nargs} -> nargs - | _ -> Misc.fatal_error "Time_travel.start" - in - let offset = if nargs < 4 then 1 else 2 in - let pc = pc - 4 * offset in - while - exec_with_temporary_breakpoint pc back_run; - match !last_breakpoint with - Some (pc', frame') when pc = pc' -> - step _minus1; - (not !interrupted) - && - (frame' - nargs > frame - curr_event.ev_stacksize) - | _ -> - false - do - () - done - -let previous_1 () = - update_current_event (); - match !current_event with - None -> (* End of the program. *) - step _minus1 - | Some event1 -> - let (frame1, pc1) = initial_frame() in - step _minus1; - if not !interrupted then begin - update_current_event (); - match !current_event with - None -> () - | Some event2 -> - let (frame2, pc2) = initial_frame() in - (* Call `start' if we've entered a function. *) - if frame1 >= 0 && frame2 >= 0 && - frame2 - event2.ev_stacksize > frame1 - event1.ev_stacksize - then start() - end - -(* Same as `step' (backward) but skip over function calls. *) -let rec previous = - function - 0 -> () - | n -> - previous_1 (); - if not !interrupted then - previous (n - 1) diff --git a/debugger/time_travel.mli b/debugger/time_travel.mli deleted file mode 100644 index 81d01a6678..0000000000 --- a/debugger/time_travel.mli +++ /dev/null @@ -1,36 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(**************************** Time travel ******************************) - -open Primitives - -exception Current_checkpoint_lost - -val new_checkpoint : int -> io_channel -> unit -val set_file_descriptor : int -> io_channel -> bool -val kill_all_checkpoints : unit -> unit -val forget_process : io_channel -> int -> unit -val recover : unit -> unit - -val go_to : int64 -> unit - -val run : unit -> unit -val back_run : unit -> unit -val step : int64 -> unit -val finish : unit -> unit -val next : int -> unit -val start : unit -> unit -val previous : int -> unit diff --git a/debugger/trap_barrier.ml b/debugger/trap_barrier.ml deleted file mode 100644 index dba9c929f7..0000000000 --- a/debugger/trap_barrier.ml +++ /dev/null @@ -1,47 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(************************** Trap barrier *******************************) - -open Debugcom -open Checkpoints - -let current_trap_barrier = ref 0 - -let install_trap_barrier pos = - current_trap_barrier := pos - -let remove_trap_barrier () = - current_trap_barrier := 0 - -(* Ensure the trap barrier state is up to date in current checkpoint. *) -let update_trap_barrier () = - if !current_checkpoint.c_trap_barrier <> !current_trap_barrier then - Exec.protect - (function () -> - set_trap_barrier !current_trap_barrier; - !current_checkpoint.c_trap_barrier <- !current_trap_barrier) - -(* Execute `funct' with a trap barrier. *) -(* --- Used by `finish'. *) -let exec_with_trap_barrier trap_barrier funct = - try - install_trap_barrier trap_barrier; - funct (); - remove_trap_barrier () - with - x -> - remove_trap_barrier (); - raise x diff --git a/debugger/trap_barrier.mli b/debugger/trap_barrier.mli deleted file mode 100644 index 28bba5a3eb..0000000000 --- a/debugger/trap_barrier.mli +++ /dev/null @@ -1,27 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(************************* Trap barrier ********************************) - -val install_trap_barrier : int -> unit - -val remove_trap_barrier : unit -> unit - -(* Ensure the trap barrier state is up to date in current checkpoint. *) -val update_trap_barrier : unit -> unit - -(* Execute `funct' with a trap barrier. *) -(* --- Used by `finish'. *) -val exec_with_trap_barrier : int -> (unit -> unit) -> unit diff --git a/debugger/unix_tools.ml b/debugger/unix_tools.ml deleted file mode 100644 index 5061bb1ddf..0000000000 --- a/debugger/unix_tools.ml +++ /dev/null @@ -1,141 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(****************** Tools for Unix *************************************) - -open Misc -open Unix -open Primitives - -(*** Convert a socket name into a socket address. ***) -let convert_address address = - try - let n = string_pos address ':' in - let host = String.sub address 0 n - and port = String.sub address (n + 1) (String.length address - n - 1) - in - (PF_INET, - ADDR_INET - ((try inet_addr_of_string host with Failure _ -> - try (gethostbyname host).h_addr_list.(0) with Not_found -> - prerr_endline ("Unknown host : " ^ host); - failwith "Can't convert address"), - (try int_of_string port with Failure _ -> - prerr_endline "The port number should be an integer"; - failwith "Can't convert address"))) - with Not_found -> - (PF_UNIX, ADDR_UNIX address) - -(*** Report a unix error. ***) -let report_error = function - | Unix_error (err, fun_name, arg) -> - prerr_string "Unix error : '"; - prerr_string fun_name; - prerr_string "' failed"; - if String.length arg > 0 then - (prerr_string " on '"; - prerr_string arg; - prerr_string "'"); - prerr_string " : "; - prerr_endline (error_message err) - | _ -> fatal_error "report_error: not a Unix error" - -(* Find program `name' in `PATH'. *) -(* Return the full path if found. *) -(* Raise `Not_found' otherwise. *) -let search_in_path name = - let check name = - try access name [X_OK]; name with Unix_error _ -> raise Not_found - in - if not (Filename.is_implicit name) then - check name - else - let path = Sys.getenv "PATH" in - let length = String.length path in - let rec traverse pointer = - if (pointer >= length) || (path.[pointer] = ':') then - pointer - else - traverse (pointer + 1) - in - let rec find pos = - let pos2 = traverse pos in - let directory = (String.sub path pos (pos2 - pos)) in - let fullname = - if directory = "" then name else directory ^ "/" ^ name - in - try check fullname with - | Not_found -> - if pos2 < length then find (pos2 + 1) - else raise Not_found - in - find 0 - -(* Expand a path. *) -(* ### path -> path' *) -let rec expand_path ch = - let rec subst_variable ch = - try - let pos = string_pos ch '$' in - if (pos + 1 < String.length ch) && (ch.[pos + 1] = '$') then - (String.sub ch 0 (pos + 1)) - ^ (subst_variable - (String.sub ch (pos + 2) (String.length ch - pos - 2))) - else - (String.sub ch 0 pos) - ^ (subst2 (String.sub ch (pos + 1) (String.length ch - pos - 1))) - with Not_found -> - ch - and subst2 ch = - let suiv = - let i = ref 0 in - while !i < String.length ch && - (let c = ch.[!i] in (c >= 'a' && c <= 'z') - || (c >= 'A' && c <= 'Z') - || (c >= '0' && c <= '9') - || c = '_') - do incr i done; - !i - in (Sys.getenv (String.sub ch 0 suiv)) - ^ (subst_variable (String.sub ch suiv (String.length ch - suiv))) - in - let ch = subst_variable ch in - let concat_root nom ch2 = - try Filename.concat (getpwnam nom).pw_dir ch2 - with Not_found -> - "~" ^ nom - in - if ch.[0] = '~' then - try - match string_pos ch '/' with - 1 -> - (let tail = String.sub ch 2 (String.length ch - 2) - in - try Filename.concat (Sys.getenv "HOME") tail - with Not_found -> - concat_root (Sys.getenv "LOGNAME") tail) - | n -> concat_root - (String.sub ch 1 (n - 1)) - (String.sub ch (n + 1) (String.length ch - n - 1)) - with - Not_found -> - expand_path (ch ^ "/") - else ch - -let make_absolute name = - if Filename.is_relative name - then Filename.concat (getcwd ()) name - else name -;; diff --git a/debugger/unix_tools.mli b/debugger/unix_tools.mli deleted file mode 100644 index b5e4ee6ca4..0000000000 --- a/debugger/unix_tools.mli +++ /dev/null @@ -1,34 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(**************************** Tools for Unix ***************************) - -open Unix - -(* Convert a socket name into a socket address. *) -val convert_address : string -> socket_domain * sockaddr - -(* Report an unix error. *) -val report_error : exn -> unit - -(* Find program `name' in `PATH'. *) -(* Return the full path if found. *) -(* Raise `Not_found' otherwise. *) -val search_in_path : string -> string - -(* Path expansion. *) -val expand_path : string -> string - -val make_absolute : string -> string diff --git a/driver/compile.ml b/driver/compile.ml deleted file mode 100644 index 52cf87d4a4..0000000000 --- a/driver/compile.ml +++ /dev/null @@ -1,121 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* The batch compiler *) - -open Misc -open Config -open Format -open Typedtree - -(* Initialize the search path. - The current directory is always searched first, - then the directories specified with the -I option (in command-line order), - then the standard library directory (unless the -nostdlib option is given). - *) - -let init_path () = - let dirs = - if !Clflags.use_threads then "+threads" :: !Clflags.include_dirs - else if !Clflags.use_vmthreads then "+vmthreads" :: !Clflags.include_dirs - else !Clflags.include_dirs in - let exp_dirs = - List.map (expand_directory Config.standard_library) dirs in - load_path := "" :: List.rev_append exp_dirs (Clflags.std_include_dir ()); - Env.reset_cache() - -(* Return the initial environment in which compilation proceeds. *) - -(* Note: do not do init_path() in initial_env, this breaks - toplevel initialization (PR#1775) *) -let initial_env () = - Ident.reinit(); - try - if !Clflags.nopervasives - then Env.initial - else Env.open_pers_signature "Pervasives" Env.initial - with Not_found -> - fatal_error "cannot open pervasives.cmi" - -(* Compile a .mli file *) - -let interface ppf sourcefile = - init_path(); - let prefixname = chop_extension_if_any sourcefile in - let modulename = String.capitalize(Filename.basename prefixname) in - let inputfile = Pparse.preprocess sourcefile in - try - let ast = - Pparse.file ppf inputfile Parse.interface ast_intf_magic_number in - if !Clflags.dump_parsetree then fprintf ppf "%a@." Printast.interface ast; - let sg = Typemod.transl_signature (initial_env()) ast in - if !Clflags.print_types then - fprintf std_formatter "%a@." Printtyp.signature - (Typemod.simplify_signature sg); - Warnings.check_fatal (); - if not !Clflags.print_types then - Env.save_signature sg modulename (prefixname ^ ".cmi"); - Pparse.remove_preprocessed inputfile - with e -> - Pparse.remove_preprocessed_if_ast inputfile; - raise e - -(* Compile a .ml file *) - -let print_if ppf flag printer arg = - if !flag then fprintf ppf "%a@." printer arg; - arg - -let (++) x f = f x - -let implementation ppf sourcefile = - init_path(); - let prefixname = chop_extension_if_any sourcefile in - let modulename = String.capitalize(Filename.basename prefixname) in - let inputfile = Pparse.preprocess sourcefile in - let env = initial_env() in - if !Clflags.print_types then begin - try ignore( - Pparse.file ppf inputfile Parse.implementation ast_impl_magic_number - ++ print_if ppf Clflags.dump_parsetree Printast.implementation - ++ Typemod.type_implementation sourcefile prefixname modulename env) - with x -> - Pparse.remove_preprocessed_if_ast inputfile; - raise x - end else begin - let objfile = prefixname ^ ".cmo" in - let oc = open_out_bin objfile in - try - Pparse.file ppf inputfile Parse.implementation ast_impl_magic_number - ++ print_if ppf Clflags.dump_parsetree Printast.implementation - ++ Typemod.type_implementation sourcefile prefixname modulename env - ++ Translmod.transl_implementation modulename - ++ print_if ppf Clflags.dump_rawlambda Printlambda.lambda - ++ Simplif.simplify_lambda - ++ print_if ppf Clflags.dump_lambda Printlambda.lambda - ++ Bytegen.compile_implementation modulename - ++ print_if ppf Clflags.dump_instr Printinstr.instrlist - ++ Emitcode.to_file oc modulename; - Warnings.check_fatal (); - Pparse.remove_preprocessed inputfile; - close_out oc; - with x -> - close_out oc; - remove_file objfile; - Pparse.remove_preprocessed_if_ast inputfile; - raise x - end - -let c_file name = - if Ccomp.compile_file name <> 0 then exit 2 diff --git a/driver/compile.mli b/driver/compile.mli deleted file mode 100644 index 2271d103e3..0000000000 --- a/driver/compile.mli +++ /dev/null @@ -1,24 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* Compile a .ml or .mli file *) - -open Format - -val interface: formatter -> string -> unit -val implementation: formatter -> string -> unit -val c_file: string -> unit - -val initial_env: unit -> Env.t -val init_path: unit -> unit diff --git a/driver/errors.ml b/driver/errors.ml deleted file mode 100644 index 03cd5690cf..0000000000 --- a/driver/errors.ml +++ /dev/null @@ -1,69 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* WARNING: if you change something in this file, you must look at - opterrors.ml to see if you need to make the same changes there. -*) - -open Format - -(* Report an error *) - -let report_error ppf exn = - let report ppf = function - | Lexer.Error(err, loc) -> - Location.print ppf loc; - Lexer.report_error ppf err - | Syntaxerr.Error err -> - Syntaxerr.report_error ppf err - | Pparse.Error -> - fprintf ppf "Preprocessor error" - | Env.Error err -> - Env.report_error ppf err - | Ctype.Tags(l, l') -> fprintf ppf - "In this program,@ variant constructors@ `%s and `%s@ \ - have the same hash value.@ Change one of them." l l' - | Typecore.Error(loc, err) -> - Location.print ppf loc; Typecore.report_error ppf err - | Typetexp.Error(loc, err) -> - Location.print ppf loc; Typetexp.report_error ppf err - | Typedecl.Error(loc, err) -> - Location.print ppf loc; Typedecl.report_error ppf err - | Typeclass.Error(loc, err) -> - Location.print ppf loc; Typeclass.report_error ppf err - | Includemod.Error err -> - Includemod.report_error ppf err - | Typemod.Error(loc, err) -> - Location.print ppf loc; Typemod.report_error ppf err - | Translcore.Error(loc, err) -> - Location.print ppf loc; Translcore.report_error ppf err - | Translclass.Error(loc, err) -> - Location.print ppf loc; Translclass.report_error ppf err - | Translmod.Error(loc, err) -> - Location.print ppf loc; Translmod.report_error ppf err - | Symtable.Error code -> - Symtable.report_error ppf code - | Bytelink.Error code -> - Bytelink.report_error ppf code - | Bytelibrarian.Error code -> - Bytelibrarian.report_error ppf code - | Bytepackager.Error code -> - Bytepackager.report_error ppf code - | Sys_error msg -> - fprintf ppf "I/O error: %s" msg - | Warnings.Errors (n) -> - fprintf ppf "@.Error: %d error-enabled warnings occurred." n - | x -> fprintf ppf "@]"; raise x in - - fprintf ppf "@[%a@]@." report exn diff --git a/driver/errors.mli b/driver/errors.mli deleted file mode 100644 index ac203a53ef..0000000000 --- a/driver/errors.mli +++ /dev/null @@ -1,18 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* Error report *) -open Format - -val report_error: formatter -> exn -> unit diff --git a/driver/main.ml b/driver/main.ml deleted file mode 100644 index 7bbbf05666..0000000000 --- a/driver/main.ml +++ /dev/null @@ -1,156 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -open Config -open Clflags - -let process_interface_file ppf name = - Compile.interface ppf name - -let process_implementation_file ppf name = - Compile.implementation ppf name; - objfiles := (Misc.chop_extension_if_any name ^ ".cmo") :: !objfiles - -let process_file ppf name = - if Filename.check_suffix name ".ml" - || Filename.check_suffix name ".mlt" then begin - Compile.implementation ppf name; - objfiles := (Misc.chop_extension_if_any name ^ ".cmo") :: !objfiles - end - else if Filename.check_suffix name !Config.interface_suffix then - Compile.interface ppf name - else if Filename.check_suffix name ".cmo" - || Filename.check_suffix name ".cma" then - objfiles := name :: !objfiles - else if Filename.check_suffix name ext_obj - || Filename.check_suffix name ext_lib then - ccobjs := name :: !ccobjs - else if Filename.check_suffix name ext_dll then - dllibs := name :: !dllibs - else if Filename.check_suffix name ".c" then begin - Compile.c_file name; - match Sys.os_type with - | "MacOS" -> ccobjs := (name ^ ".o") :: (name ^ ".x") :: !ccobjs - | _ -> - ccobjs := (Filename.chop_suffix (Filename.basename name) ".c" ^ ext_obj) - :: !ccobjs - end - else - raise(Arg.Bad("don't know what to do with " ^ name)) - -let print_version_and_library () = - print_string "The Objective Caml compiler, version "; - print_string Config.version; print_newline(); - print_string "Standard library directory: "; - print_string Config.standard_library; print_newline(); - exit 0 - -let print_version_string () = - print_string Config.version; print_newline(); exit 0 - -let print_standard_library () = - print_string Config.standard_library; print_newline(); exit 0 - -let usage = "Usage: ocamlc \nOptions are:" - -(* Error messages to standard error formatter *) -let anonymous = process_file Format.err_formatter;; -let impl = process_implementation_file Format.err_formatter;; -let intf = process_interface_file Format.err_formatter;; - -module Options = Main_args.Make_options (struct - let set r () = r := true - let unset r () = r := false - let _a = set make_archive - let _c = set compile_only - let _cc s = c_compiler := s; c_linker := s - let _cclib s = ccobjs := Misc.rev_split_words s @ !ccobjs - let _ccopt s = ccopts := s :: !ccopts - let _custom = set custom_runtime - let _dllib s = dllibs := Misc.rev_split_words s @ !dllibs - let _dllpath s = dllpaths := !dllpaths @ [s] - let _dtypes = set save_types - let _g = set debug - let _i () = print_types := true; compile_only := true - let _I s = include_dirs := s :: !include_dirs - let _impl = impl - let _intf = intf - let _intf_suffix s = Config.interface_suffix := s - let _labels = unset classic - let _linkall = set link_everything - let _make_runtime () = - custom_runtime := true; make_runtime := true; link_everything := true - let _noassert = set noassert - let _nolabels = set classic - let _noautolink = set no_auto_link - let _nostdlib = set no_std_include - let _o s = output_name := Some s - let _output_obj () = output_c_object := true; custom_runtime := true - let _pack = set make_package - let _pp s = preprocessor := Some s - let _principal = set principal - let _rectypes = set recursive_types - let _thread = set use_threads - let _vmthread = set use_vmthreads - let _unsafe = set fast - let _use_prims s = use_prims := s - let _use_runtime s = use_runtime := s - let _v = print_version_and_library - let _version = print_version_string - let _w = (Warnings.parse_options false) - let _warn_error = (Warnings.parse_options true) - let _where = print_standard_library - let _verbose = set verbose - let _nopervasives = set nopervasives - let _dparsetree = set dump_parsetree - let _drawlambda = set dump_rawlambda - let _dlambda = set dump_lambda - let _dinstr = set dump_instr - let anonymous = anonymous -end) - -let extract_output = function - | Some s -> s - | None -> - prerr_endline - "Please specify the name of the output file, using option -o"; - exit 2 - -let default_output = function - | Some s -> s - | None -> Config.default_executable_name - -let main () = - try - Arg.parse Options.list anonymous usage; - if !make_archive then begin - Compile.init_path(); - Bytelibrarian.create_archive (List.rev !objfiles) - (extract_output !output_name) - end - else if !make_package then begin - Compile.init_path(); - Bytepackager.package_files (List.rev !objfiles) - (extract_output !output_name) - end - else if not !compile_only && !objfiles <> [] then begin - Compile.init_path(); - Bytelink.link (List.rev !objfiles) (default_output !output_name) - end; - exit 0 - with x -> - Errors.report_error Format.err_formatter x; - exit 2 - -let _ = main () diff --git a/driver/main.mli b/driver/main.mli deleted file mode 100644 index d175a3ca26..0000000000 --- a/driver/main.mli +++ /dev/null @@ -1,17 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Damien Doligez, projet Moscova, INRIA Rocquencourt *) -(* *) -(* Copyright 2000 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* - this "empty" file is here to speed up garbage collection in ocamlc.opt -*) diff --git a/driver/main_args.ml b/driver/main_args.ml deleted file mode 100644 index a94b0e8a87..0000000000 --- a/driver/main_args.ml +++ /dev/null @@ -1,156 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Damien Doligez, projet Para, INRIA Rocquencourt *) -(* *) -(* Copyright 1998 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -module Make_options (F : - sig - val _a : unit -> unit - val _c : unit -> unit - val _cc : string -> unit - val _cclib : string -> unit - val _ccopt : string -> unit - val _custom : unit -> unit - val _dllib : string -> unit - val _dllpath : string -> unit - val _dtypes : unit -> unit - val _g : unit -> unit - val _i : unit -> unit - val _I : string -> unit - val _impl : string -> unit - val _intf : string -> unit - val _intf_suffix : string -> unit - val _labels : unit -> unit - val _linkall : unit -> unit - val _make_runtime : unit -> unit - val _noassert : unit -> unit - val _noautolink : unit -> unit - val _nolabels : unit -> unit - val _nostdlib : unit -> unit - val _o : string -> unit - val _output_obj : unit -> unit - val _pack : unit -> unit - val _pp : string -> unit - val _principal : unit -> unit - val _rectypes : unit -> unit - val _thread : unit -> unit - val _vmthread : unit -> unit - val _unsafe : unit -> unit - val _use_prims : string -> unit - val _use_runtime : string -> unit - val _v : unit -> unit - val _version : unit -> unit - val _verbose : unit -> unit - val _w : string -> unit - val _warn_error : string -> unit - val _where : unit -> unit - - val _nopervasives : unit -> unit - val _dparsetree : unit -> unit - val _drawlambda : unit -> unit - val _dlambda : unit -> unit - val _dinstr : unit -> unit - val anonymous : string -> unit - end) = -struct - let list = [ - "-a", Arg.Unit F._a, " Build a library"; - "-c", Arg.Unit F._c, " Compile only (do not link)"; - "-cc", Arg.String F._cc, - " Use as the C compiler and linker"; - "-cclib", Arg.String F._cclib, " Pass option to the C linker"; - "-ccopt", Arg.String F._ccopt, - " Pass option to the C compiler and linker"; - "-custom", Arg.Unit F._custom, " Link in custom mode"; - "-dllib", Arg.String F._dllib, - " Use the dynamically-loaded library "; - "-dllpath", Arg.String F._dllpath, - " Add to the run-time search path for shared libraries"; - "-dtypes", Arg.Unit F._dtypes, " Save type information in .annot"; - "-g", Arg.Unit F._g, " Save debugging information"; - "-i", Arg.Unit F._i, " Print inferred interface"; - "-I", Arg.String F._I, - " Add to the list of include directories"; - "-impl", Arg.String F._impl, " Compile as a .ml file"; - "-intf", Arg.String F._intf, " Compile as a .mli file"; - "-intf-suffix", Arg.String F._intf_suffix, - " Suffix for interface files (default: .mli)"; - "-intf_suffix", Arg.String F._intf_suffix, - " (deprecated) same as -intf-suffix"; - "-labels", Arg.Unit F._labels, " Use commuting label mode"; - "-linkall", Arg.Unit F._linkall, " Link all modules, even unused ones"; - "-make-runtime", Arg.Unit F._make_runtime, - " Build a runtime system with given C objects and libraries"; - "-make_runtime", Arg.Unit F._make_runtime, - " (deprecated) same as -make-runtime"; - "-modern", Arg.Unit F._labels, " (deprecated) same as -labels"; - "-noassert", Arg.Unit F._noassert, " Don't compile assertion checks"; - "-noautolink", Arg.Unit F._noautolink, - " Don't automatically link C libraries specified in .cma files"; - "-nolabels", Arg.Unit F._nolabels, " Ignore non-optional labels in types"; - "-nostdlib", Arg.Unit F._nostdlib, - " do not add default directory to the list of include directories"; - "-o", Arg.String F._o, " Set output file name to "; - "-output-obj", Arg.Unit F._output_obj, - " Output a C object file instead of an executable"; - "-pack", Arg.Unit F._pack, - " Package the given .cmo files into one .cmo"; - "-pp", Arg.String F._pp, - " Pipe sources through preprocessor "; - "-principal", Arg.Unit F._principal, - " Check principality of type inference"; - "-rectypes", Arg.Unit F._rectypes, " Allow arbitrary recursive types"; - "-thread", Arg.Unit F._thread, " Generate code that supports the system threads library"; - "-unsafe", Arg.Unit F._unsafe, - " No bounds checking on array and string access"; - "-use-runtime", Arg.String F._use_runtime, - " Generate bytecode for the given runtime system"; - "-use_runtime", Arg.String F._use_runtime, - " (deprecated) same as -use-runtime"; - "-v", Arg.Unit F._v, - " Print compiler version and location of standard library and exit"; - "-version", Arg.Unit F._version, " Print compiler version and exit"; - "-verbose", Arg.Unit F._verbose, " Print calls to external commands"; - "-vmthread", Arg.Unit F._vmthread, " Generate code that supports the threads library with VM-level scheduling"; - "-w", Arg.String F._w, - " Enable or disable warnings according to :\n\ - \032 A/a enable/disable all warnings\n\ - \032 C/c enable/disable suspicious comment\n\ - \032 D/d enable/disable deprecated features\n\ - \032 E/e enable/disable fragile match\n\ - \032 F/f enable/disable partially applied function\n\ - \032 L/l enable/disable labels omitted in application\n\ - \032 M/m enable/disable overriden method\n\ - \032 P/p enable/disable partial match\n\ - \032 S/s enable/disable non-unit statement\n\ - \032 U/u enable/disable unused match case\n\ - \032 V/v enable/disable hidden instance variable\n\ - \032 X/x enable/disable all other warnings\n\ - \032 default setting is \"Ale\"\n\ - \032 (all warnings but labels and fragile match enabled)"; - "-warn-error" , Arg.String F._warn_error, - " Treat the warnings enabled by as errors.\n\ - \032 See option -w for the list of flags.\n\ - \032 Default setting is \"a\" (warnings are not errors)"; - "-where", Arg.Unit F._where, - " Print location of standard library and exit"; - "-nopervasives", Arg.Unit F._nopervasives, " (undocumented)"; - "-dparsetree", Arg.Unit F._dparsetree, " (undocumented)"; - "-drawlambda", Arg.Unit F._drawlambda, " (undocumented)"; - "-dlambda", Arg.Unit F._dlambda, " (undocumented)"; - "-dinstr", Arg.Unit F._dinstr, " (undocumented)"; - "-use-prims", Arg.String F._use_prims, " (undocumented)"; - - "-", Arg.String F.anonymous, - " Treat as a file name (even if it starts with `-')"; - ] -end;; diff --git a/driver/main_args.mli b/driver/main_args.mli deleted file mode 100644 index 1233b51443..0000000000 --- a/driver/main_args.mli +++ /dev/null @@ -1,66 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Damien Doligez, projet Para, INRIA Rocquencourt *) -(* *) -(* Copyright 1998 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -module Make_options (F : - sig - val _a : unit -> unit - val _c : unit -> unit - val _cc : string -> unit - val _cclib : string -> unit - val _ccopt : string -> unit - val _custom : unit -> unit - val _dllib : string -> unit - val _dllpath : string -> unit - val _dtypes : unit -> unit - val _g : unit -> unit - val _i : unit -> unit - val _I : string -> unit - val _impl : string -> unit - val _intf : string -> unit - val _intf_suffix : string -> unit - val _labels : unit -> unit - val _linkall : unit -> unit - val _make_runtime : unit -> unit - val _noassert : unit -> unit - val _noautolink : unit -> unit - val _nolabels : unit -> unit - val _nostdlib : unit -> unit - val _o : string -> unit - val _output_obj : unit -> unit - val _pack : unit -> unit - val _pp : string -> unit - val _principal : unit -> unit - val _rectypes : unit -> unit - val _thread : unit -> unit - val _vmthread : unit -> unit - val _unsafe : unit -> unit - val _use_prims : string -> unit - val _use_runtime : string -> unit - val _v : unit -> unit - val _version : unit -> unit - val _verbose : unit -> unit - val _w : string -> unit - val _warn_error : string -> unit - val _where : unit -> unit - - val _nopervasives : unit -> unit - val _dparsetree : unit -> unit - val _drawlambda : unit -> unit - val _dlambda : unit -> unit - val _dinstr : unit -> unit - val anonymous : string -> unit - end) : - sig - val list : (string * Arg.spec * string) list - end diff --git a/driver/ocamlcomp.sh.in b/driver/ocamlcomp.sh.in deleted file mode 100644 index 2aeb2de20b..0000000000 --- a/driver/ocamlcomp.sh.in +++ /dev/null @@ -1,5 +0,0 @@ -#!/bin/sh - -topdir=`dirname $0` - -exec @compiler@ -nostdlib -I $topdir/stdlib "$@" diff --git a/driver/optcompile.ml b/driver/optcompile.ml deleted file mode 100644 index 0e52920f39..0000000000 --- a/driver/optcompile.ml +++ /dev/null @@ -1,110 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* The batch compiler *) - -open Misc -open Config -open Format -open Typedtree - -(* Initialize the search path. - The current directory is always searched first, - then the directories specified with the -I option (in command-line order), - then the standard library directory. *) - -let init_path () = - let dirs = - if !Clflags.use_threads - then "+threads" :: !Clflags.include_dirs - else !Clflags.include_dirs in - let exp_dirs = - List.map (expand_directory Config.standard_library) dirs in - load_path := "" :: List.rev_append exp_dirs (Clflags.std_include_dir ()); - Env.reset_cache() - -(* Return the initial environment in which compilation proceeds. *) - -let initial_env () = - Ident.reinit(); - try - if !Clflags.nopervasives - then Env.initial - else Env.open_pers_signature "Pervasives" Env.initial - with Not_found -> - fatal_error "cannot open Pervasives.cmi" - -(* Compile a .mli file *) - -let interface ppf sourcefile = - init_path(); - let prefixname = Misc.chop_extension_if_any sourcefile in - let modulename = String.capitalize(Filename.basename prefixname) in - let inputfile = Pparse.preprocess sourcefile in - try - let ast = - Pparse.file ppf inputfile Parse.interface ast_intf_magic_number in - if !Clflags.dump_parsetree then fprintf ppf "%a@." Printast.interface ast; - let sg = Typemod.transl_signature (initial_env()) ast in - if !Clflags.print_types then - fprintf std_formatter "%a@." Printtyp.signature - (Typemod.simplify_signature sg); - Warnings.check_fatal (); - if not !Clflags.print_types then - Env.save_signature sg modulename (prefixname ^ ".cmi"); - Pparse.remove_preprocessed inputfile - with e -> - Pparse.remove_preprocessed_if_ast inputfile; - raise e - -(* Compile a .ml file *) - -let print_if ppf flag printer arg = - if !flag then fprintf ppf "%a@." printer arg; - arg - -let (++) x f = f x -let (+++) (x, y) f = (x, f y) - -let implementation ppf sourcefile = - init_path(); - let prefixname = Misc.chop_extension_if_any sourcefile in - let modulename = String.capitalize(Filename.basename prefixname) in - let inputfile = Pparse.preprocess sourcefile in - let env = initial_env() in - Compilenv.reset modulename; - try - if !Clflags.print_types then ignore( - Pparse.file ppf inputfile Parse.implementation ast_impl_magic_number - ++ print_if ppf Clflags.dump_parsetree Printast.implementation - ++ Typemod.type_implementation sourcefile prefixname modulename env) - else begin - Pparse.file ppf inputfile Parse.implementation ast_impl_magic_number - ++ print_if ppf Clflags.dump_parsetree Printast.implementation - ++ Typemod.type_implementation sourcefile prefixname modulename env - ++ Translmod.transl_store_implementation modulename - +++ print_if ppf Clflags.dump_rawlambda Printlambda.lambda - +++ Simplif.simplify_lambda - +++ print_if ppf Clflags.dump_lambda Printlambda.lambda - ++ Asmgen.compile_implementation prefixname ppf; - Compilenv.save_unit_info (prefixname ^ ".cmx"); - end; - Warnings.check_fatal (); - Pparse.remove_preprocessed inputfile - with x -> - Pparse.remove_preprocessed_if_ast inputfile; - raise x - -let c_file name = - if Ccomp.compile_file name <> 0 then exit 2 diff --git a/driver/optcompile.mli b/driver/optcompile.mli deleted file mode 100644 index 2271d103e3..0000000000 --- a/driver/optcompile.mli +++ /dev/null @@ -1,24 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* Compile a .ml or .mli file *) - -open Format - -val interface: formatter -> string -> unit -val implementation: formatter -> string -> unit -val c_file: string -> unit - -val initial_env: unit -> Env.t -val init_path: unit -> unit diff --git a/driver/opterrors.ml b/driver/opterrors.ml deleted file mode 100644 index a59e6f265e..0000000000 --- a/driver/opterrors.ml +++ /dev/null @@ -1,71 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* WARNING: if you change something in this file, you must look at - errors.ml to see if you need to make the same changes there. -*) - -open Format - -(* Report an error *) - -let report_error ppf exn = - let report ppf = function - | Lexer.Error(err, l) -> - Location.print ppf l; - Lexer.report_error ppf err - | Syntaxerr.Error err -> - Syntaxerr.report_error ppf err - | Pparse.Error -> - fprintf ppf "Preprocessor error" - | Env.Error err -> - Env.report_error ppf err - | Ctype.Tags(l, l') -> fprintf ppf - "In this program,@ variant constructors@ `%s and `%s@ \ - have the same hash value.@ Change one of them." l l' - | Typecore.Error(loc, err) -> - Location.print ppf loc; Typecore.report_error ppf err - | Typetexp.Error(loc, err) -> - Location.print ppf loc; Typetexp.report_error ppf err - | Typedecl.Error(loc, err) -> - Location.print ppf loc; Typedecl.report_error ppf err - | Typeclass.Error(loc, err) -> - Location.print ppf loc; Typeclass.report_error ppf err - | Includemod.Error err -> - Includemod.report_error ppf err - | Typemod.Error(loc, err) -> - Location.print ppf loc; Typemod.report_error ppf err - | Translcore.Error(loc, err) -> - Location.print ppf loc; Translcore.report_error ppf err - | Translclass.Error(loc, err) -> - Location.print ppf loc; Translclass.report_error ppf err - | Translmod.Error(loc, err) -> - Location.print ppf loc; Translmod.report_error ppf err - | Compilenv.Error code -> - Compilenv.report_error ppf code - | Asmgen.Error code -> - Asmgen.report_error ppf code - | Asmlink.Error code -> - Asmlink.report_error ppf code - | Asmlibrarian.Error code -> - Asmlibrarian.report_error ppf code - | Asmpackager.Error code -> - Asmpackager.report_error ppf code - | Sys_error msg -> - fprintf ppf "I/O error: %s" msg - | Warnings.Errors (n) -> - fprintf ppf "@.Error: %d error-enabled warnings occurred." n - | x -> fprintf ppf "@]"; raise x in - - fprintf ppf "@[%a@]@." report exn diff --git a/driver/opterrors.mli b/driver/opterrors.mli deleted file mode 100644 index d09dc733b6..0000000000 --- a/driver/opterrors.mli +++ /dev/null @@ -1,17 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* Error report *) - -val report_error: Format.formatter -> exn -> unit diff --git a/driver/optmain.ml b/driver/optmain.ml deleted file mode 100644 index 6483bff95d..0000000000 --- a/driver/optmain.ml +++ /dev/null @@ -1,204 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -open Config -open Clflags - -let process_interface_file ppf name = - Optcompile.interface ppf name - -let process_implementation_file ppf name = - Optcompile.implementation ppf name; - objfiles := (Misc.chop_extension_if_any name ^ ".cmx") :: !objfiles - -let process_file ppf name = - if Filename.check_suffix name ".ml" - || Filename.check_suffix name ".mlt" then begin - Optcompile.implementation ppf name; - objfiles := (Misc.chop_extension_if_any name ^ ".cmx") :: !objfiles - end - else if Filename.check_suffix name !Config.interface_suffix then - Optcompile.interface ppf name - else if Filename.check_suffix name ".cmx" - || Filename.check_suffix name ".cmxa" then - objfiles := name :: !objfiles - else if Filename.check_suffix name ext_obj - || Filename.check_suffix name ext_lib then - ccobjs := name :: !ccobjs - else if Filename.check_suffix name ".c" then begin - Optcompile.c_file name; - ccobjs := (Filename.chop_suffix (Filename.basename name) ".c" ^ ext_obj) - :: !ccobjs - end - else - raise(Arg.Bad("don't know what to do with " ^ name)) - -let print_version_and_library () = - print_string "The Objective Caml native-code compiler, version "; - print_string Config.version; print_newline(); - print_string "Standard library directory: "; - print_string Config.standard_library; print_newline(); - exit 0 - -let print_version_string () = - print_string Config.version; print_newline(); exit 0 - -let print_standard_library () = - print_string Config.standard_library; print_newline(); exit 0 - -let extract_output = function - | Some s -> s - | None -> - prerr_endline - "Please specify the name of the output file, using option -o"; - exit 2 - -let default_output = function - | Some s -> s - | None -> Config.default_executable_name - -let usage = "Usage: ocamlopt \nOptions are:" - -let main () = - native_code := true; - c_compiler := Config.native_c_compiler; - c_linker := Config.native_c_linker; - let ppf = Format.err_formatter in - try - Arg.parse (Arch.command_line_options @ [ - "-a", Arg.Set make_archive, " Build a library"; - "-c", Arg.Set compile_only, " Compile only (do not link)"; - "-cc", Arg.String(fun s -> c_compiler := s; c_linker := s), - " Use as the C compiler and linker"; - "-cclib", Arg.String(fun s -> - ccobjs := Misc.rev_split_words s @ !ccobjs), - " Pass option to the C linker"; - "-ccopt", Arg.String(fun s -> ccopts := s :: !ccopts), - " Pass option to the C compiler and linker"; - "-compact", Arg.Clear optimize_for_speed, - " Optimize code size rather than speed"; - "-dtypes", Arg.Set save_types, - " Save type information in .annot"; - "-i", Arg.Unit (fun () -> print_types := true; compile_only := true), - " Print inferred interface"; - "-I", Arg.String(fun dir -> include_dirs := dir :: !include_dirs), - " Add to the list of include directories"; - "-impl", Arg.String (process_implementation_file ppf), - " Compile as a .ml file"; - "-inline", Arg.Int(fun n -> inline_threshold := n * 8), - " Set aggressiveness of inlining to "; - "-intf", Arg.String (process_interface_file ppf), - " Compile as a .mli file"; - "-intf-suffix", Arg.String (fun s -> Config.interface_suffix := s), - " Suffix for interface files (default: .mli)"; - "-intf_suffix", Arg.String (fun s -> Config.interface_suffix := s), - " (deprecated) same as -intf-suffix"; - "-labels", Arg.Clear classic, " Use commuting label mode"; - "-linkall", Arg.Set link_everything, - " Link all modules, even unused ones"; - "-noassert", Arg.Set noassert, " Don't compile assertion checks"; - "-noautolink", Arg.Set no_auto_link, - " Don't automatically link C libraries specified in .cma files"; - "-nolabels", Arg.Set classic, " Ignore non-optional labels in types"; - "-nostdlib", Arg.Set no_std_include, - " do not add standard directory to the list of include directories"; - "-o", Arg.String(fun s -> output_name := Some s), - " Set output file name to "; - "-output-obj", Arg.Unit(fun () -> output_c_object := true), - " Output a C object file instead of an executable"; - "-p", Arg.Set gprofile, - " Compile and link with profiling support for \"gprof\"\n\ - \t(not supported on all platforms)"; - "-pack", Arg.Set make_package, - " Package the given .cmx files into one .cmx"; - "-pp", Arg.String(fun s -> preprocessor := Some s), - " Pipe sources through preprocessor "; - "-principal", Arg.Set principal, - " Check principality of type inference"; - "-rectypes", Arg.Set recursive_types, - " Allow arbitrary recursive types"; - "-S", Arg.Set keep_asm_file, " Keep intermediate assembly file"; - "-thread", Arg.Set use_threads, " Generate code that supports the system threads library"; - "-unsafe", Arg.Set fast, - " No bounds checking on array and string access"; - "-v", Arg.Unit print_version_and_library, - " Print compiler version and standard library location and exit"; - "-version", Arg.Unit print_version_string, - " Print compiler version and exit"; - "-verbose", Arg.Set verbose, " Print calls to external commands"; - "-w", Arg.String (Warnings.parse_options false), - " Enable or disable warnings according to :\n\ - \032 A/a enable/disable all warnings\n\ - \032 C/c enable/disable suspicious comment\n\ - \032 D/d enable/disable deprecated features\n\ - \032 E/e enable/disable fragile match\n\ - \032 F/f enable/disable partially applied function\n\ - \032 L/l enable/disable labels omitted in application\n\ - \032 M/m enable/disable overriden methods\n\ - \032 P/p enable/disable partial match\n\ - \032 S/s enable/disable non-unit statement\n\ - \032 U/u enable/disable unused match case\n\ - \032 V/v enable/disable hidden instance variables\n\ - \032 X/x enable/disable all other warnings\n\ - \032 default setting is \"Ale\"\n\ - \032 (all warnings but labels and fragile match enabled)"; - "-warn-error" , Arg.String (Warnings.parse_options true), - " Treat the warnings enabled by as errors.\n\ - \032 See option -w for the list of flags.\n\ - \032 Default setting is \"a\" (warnings are not errors)"; - "-where", Arg.Unit print_standard_library, - " Print location of standard library and exit"; - - "-nopervasives", Arg.Set nopervasives, " (undocumented)"; - "-dparsetree", Arg.Set dump_parsetree, " (undocumented)"; - "-drawlambda", Arg.Set dump_rawlambda, " (undocumented)"; - "-dlambda", Arg.Set dump_lambda, " (undocumented)"; - "-dcmm", Arg.Set dump_cmm, " (undocumented)"; - "-dsel", Arg.Set dump_selection, " (undocumented)"; - "-dcombine", Arg.Set dump_combine, " (undocumented)"; - "-dlive", Arg.Unit(fun () -> dump_live := true; - Printmach.print_live := true), - " (undocumented)"; - "-dspill", Arg.Set dump_spill, " (undocumented)"; - "-dsplit", Arg.Set dump_split, " (undocumented)"; - "-dinterf", Arg.Set dump_interf, " (undocumented)"; - "-dprefer", Arg.Set dump_prefer, " (undocumented)"; - "-dalloc", Arg.Set dump_regalloc, " (undocumented)"; - "-dreload", Arg.Set dump_reload, " (undocumented)"; - "-dscheduling", Arg.Set dump_scheduling, " (undocumented)"; - "-dlinear", Arg.Set dump_linear, " (undocumented)"; - "-dstartup", Arg.Set keep_startup_file, " (undocumented)"; - "-", Arg.String (process_file ppf), - " Treat as a file name (even if it starts with `-')" - ]) (process_file ppf) usage; - if !make_archive then begin - Optcompile.init_path(); - Asmlibrarian.create_archive (List.rev !objfiles) - (extract_output !output_name) - end - else if !make_package then begin - Optcompile.init_path(); - Asmpackager.package_files ppf (List.rev !objfiles) - (extract_output !output_name) - end - else if not !compile_only && !objfiles <> [] then begin - Optcompile.init_path(); - Asmlink.link ppf (List.rev !objfiles) (default_output !output_name) - end; - exit 0 - with x -> - Opterrors.report_error ppf x; - exit 2 - -let _ = main () diff --git a/driver/optmain.mli b/driver/optmain.mli deleted file mode 100644 index 628d2d398b..0000000000 --- a/driver/optmain.mli +++ /dev/null @@ -1,17 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Damien Doligez, projet Moscova, INRIA Rocquencourt *) -(* *) -(* Copyright 2000 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* - this "empty" file is here to speed up garbage collection in ocamlopt.opt -*) diff --git a/driver/pparse.ml b/driver/pparse.ml deleted file mode 100644 index da65a5525b..0000000000 --- a/driver/pparse.ml +++ /dev/null @@ -1,81 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -open Format - -exception Error - -(* Optionally preprocess a source file *) - -let preprocess sourcefile = - match !Clflags.preprocessor with - None -> sourcefile - | Some pp -> - let tmpfile = Filename.temp_file "camlpp" "" in - let comm = Printf.sprintf "%s %s > %s" pp sourcefile tmpfile in - if Ccomp.command comm <> 0 then begin - Misc.remove_file tmpfile; - raise Error; - end; - tmpfile - -let remove_preprocessed inputfile = - match !Clflags.preprocessor with - None -> () - | Some _ -> Misc.remove_file inputfile - -let remove_preprocessed_if_ast inputfile = - match !Clflags.preprocessor with - None -> () - | Some _ -> - if inputfile <> !Location.input_name then Misc.remove_file inputfile - -(* Parse a file or get a dumped syntax tree in it *) - -exception Outdated_version - -let file ppf inputfile parse_fun ast_magic = - let ic = open_in_bin inputfile in - let is_ast_file = - try - let buffer = String.create (String.length ast_magic) in - really_input ic buffer 0 (String.length ast_magic); - if buffer = ast_magic then true - else if String.sub buffer 0 9 = String.sub ast_magic 0 9 then - raise Outdated_version - else false - with - Outdated_version -> - Misc.fatal_error "Ocaml and preprocessor have incompatible versions" - | _ -> false - in - let ast = - try - if is_ast_file then begin - if !Clflags.fast then - fprintf ppf "@[Warning: %s@]@." - "option -unsafe used with a preprocessor returning a syntax tree"; - Location.input_name := input_value ic; - input_value ic - end else begin - seek_in ic 0; - Location.input_name := inputfile; - let lexbuf = Lexing.from_channel ic in - Location.init lexbuf inputfile; - parse_fun lexbuf - end - with x -> close_in ic; raise x - in - close_in ic; - ast diff --git a/driver/pparse.mli b/driver/pparse.mli deleted file mode 100644 index 0ed0391360..0000000000 --- a/driver/pparse.mli +++ /dev/null @@ -1,22 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -open Format - -exception Error - -val preprocess : string -> string -val remove_preprocessed : string -> unit -val remove_preprocessed_if_ast : string -> unit -val file : formatter -> string -> (Lexing.lexbuf -> 'a) -> string -> 'a diff --git a/emacs/.cvsignore b/emacs/.cvsignore deleted file mode 100644 index e7e261fca6..0000000000 --- a/emacs/.cvsignore +++ /dev/null @@ -1,2 +0,0 @@ -ocamltags - diff --git a/emacs/Makefile b/emacs/Makefile deleted file mode 100644 index d6c57f79ea..0000000000 --- a/emacs/Makefile +++ /dev/null @@ -1,64 +0,0 @@ -# $Id$ - -include ../config/Makefile - -# Files to install -FILES= caml-font.el caml-hilit.el caml.el camldebug.el \ - inf-caml.el caml-compat.el caml-help.el caml-types.el \ - caml-xemacs.el caml-emacs.el - -# Where to install. If empty, automatically determined. -#EMACSDIR= - -# Name of Emacs executable -EMACS=emacs - -# Where to install ocamltags script -SCRIPTDIR = $(BINDIR) - -# Command for byte-compiling the files -COMPILECMD=(progn \ - (setq load-path (cons "." load-path)) \ - (byte-compile-file "caml-xemacs.el") \ - (byte-compile-file "caml-emacs.el") \ - (byte-compile-file "caml.el") \ - (byte-compile-file "inf-caml.el") \ - (byte-compile-file "caml-help.el") \ - (byte-compile-file "caml-types.el") \ - (byte-compile-file "camldebug.el")) - -install: - @if test "$(EMACSDIR)" = ""; then \ - set xxx `($(EMACS) --batch --eval "(mapcar 'print load-path)") \ - 2>/dev/null | \ - sed -n -e '/\/site-lisp/s/"//gp'`; \ - if test "$$2" = ""; then \ - echo "Cannot determine Emacs site-lisp directory"; \ - exit 2; \ - fi; \ - $(MAKE) EMACSDIR="$$2" simple-install; \ - else \ - $(MAKE) simple-install; \ - fi - -# install the .el files, but do not compile them. -install-el: - $(MAKE) NOCOMPILE=true install - -simple-install: - @echo "Installing in $(EMACSDIR)..." - if test -d $(EMACSDIR); then : ; else mkdir -p $(EMACSDIR); fi - cp $(FILES) $(EMACSDIR) - if [ -z "$(NOCOMPILE)" ]; then \ - cd $(EMACSDIR); $(EMACS) --batch --eval '$(COMPILECMD)'; \ - fi - -ocamltags: ocamltags.in - sed -e 's:@EMACS@:$(EMACS):' ocamltags.in >ocamltags - chmod a+x ocamltags - -install-ocamltags: ocamltags - cp ocamltags $(SCRIPTDIR)/ocamltags - -clean: - rm -f ocamltags *~ #*# diff --git a/emacs/README b/emacs/README deleted file mode 100644 index f6bf63e842..0000000000 --- a/emacs/README +++ /dev/null @@ -1,198 +0,0 @@ - O'Caml emacs mode, snapshot of $Date$ - -The files in this archive define a caml-mode for emacs, for editing -Objective Caml and Objective Label programs, as well as an -inferior-caml-mode, to run a toplevel. - -Caml-mode supports indentation, compilation and error retrieving, -sending phrases to the toplevel. Moreover support for hilit, -font-lock and imenu was added. - -This package is based on the original caml-mode for caml-light by -Xavier Leroy, extended with indentation by Ian Zimmerman. For details -see README.itz, which is the README from Ian Zimmerman's package. - -To use it, just put the .el files in your path, and add the following -three lines in your .emacs. - - (setq auto-mode-alist - (cons '("\\.ml[iylp]?$" . caml-mode) auto-mode-alist)) - (autoload 'caml-mode "caml" "Major mode for editing Caml code." t) - (autoload 'run-caml "inf-caml" "Run an inferior Caml process." t) - -I added camldebug.el from the original distribution, since there will -soon be a debugger for Objective Caml, but I do not know enough about -it. - -To install the mode itself, edit the Makefile and do - - % make install - -To install ocamltags, do - - % make install-ocamltags - -To use highlighting capabilities, add ONE of the following two lines -to your .emacs. The second one works better on recent versions of -emacs. - - (if window-system (require 'caml-hilit)) - (if window-system (require 'caml-font)) - -caml.el and inf-caml.el can be used collectively, but it might be a -good idea to copy caml-hilit.el or caml-font.el to you own directory, -and edit it to your taste and colors. - -Main key bindings: - -TAB indent current line -M-C-q indent phrase -M-C-h mark phrase -C-c C-a switch between interface and implementation -C-c C-c compile (usually make) -C-x` goto next error (also mouse button 2 in the compilation log) - -Once you have started caml by M-x run-caml: - -M-C-x send phrase to inferior caml process -C-c C-r send region to inferior caml process -C-c C-s show inferior caml process -C-c` goto error in expression sent by M-C-x - -For other bindings, see C-h b. - -Changes log: ------------ - -Version 3.05: -------------- -* improved interaction with inferior caml mode - -* access help from the source - -* fixes in indentation code - -Version 3.03: -------------- -* process ;; properly - -Version 3.00: -------------- -* adapt to new label syntax - -* intelligent indentation of parenthesis - -Version 2.02: -------------- -* improved ocamltags - -* added support for multibyte characters in emacs 20 - -Version 2.01+: --------------- -* corrected a bug in caml-font.el - -* corrected abbreviations and added ocamltags script - -Version 2.01: ------------- -* code for interactive errors added by ITZ - -Version 2.00: ------------- -* changed the algorithm to skip comments - -* adapted for the new object syntax - -Version 1.07: ------------- -* next-error bug fix by John Malecki - -* camldebug.el modified by Xavier Leroy - -Version 1.06: ------------- -* new keywords in O'Caml 1.06 - -* compatibility with GNU Emacs 20 - -* changed from caml-imenu-disable to caml-imenu-enable (off by default) - -Version 1.05: ------------- -* a few indentation bugs corrected. let, val ... are now indented - correctly even when you write them at the beginning of a line. - -* added a Caml menu, and Imenu support. Imenu menu can be disabled - by setting the variable caml-imenu-disable to t. - Xemacs support for the Menu, but no Imenu. - -* key bindings closer to lisp-mode. - -* O'Labl compatibility (":" is part of words) may be switched off by - setting caml-olabl-disable to t. - -* camldebug.el was updated by Xavier Leroy. - -Version 1.03b: -------------- -* many bugs corrected. - -* (partial) compatibility with Caml-Light added. - (setq caml-quote-char "`") - (setq inferior-caml-program "camllight") - Literals will be correctly understood and highlighted. However, - indentation rules are still Objective Caml's: this just happens to - work well in most cases, but is only intended for occasional use. - -* as many people asked for it, application is now indented. This seems - to work well: this time differences in indentation between the - compiler's source and this mode are really exceptionnal. On the - other hand, you may think that some special cases are strange. No - miracle. - -* nicer behaviour when sending a phrase/region to the inferior caml - process. - -Version 1.03: ------------- -* support of Objective Caml and Objective Label. - -* an indentation very close to mine, which happens to be the same as - Xavier's, since the sources of the Objective Caml compiler do not - change if you indent them in this mode. - -* highlighting. - -Some remarks about the style supported: --------------------------------------- - -Since Objective Caml's syntax is very liberal (more than 100 -shift-reduce conflicts with yacc), automatic indentation is far from -easy. Moreover, you expect the indentation to be not purely syntactic, -but also semantic: reflecting the meaning of your program. - -This mode tries to be intelligent. For instance some operators are -indented differently in the middle and at the end of a line (thanks to -Ian Zimmerman). Also, we do not indent after if .. then .. else, when -else is on the same line, to reflect that this idiom is equivalent to -a return instruction in a more imperative language, or after the in of -let .. in, since you may see that as an assignment. - -However, you may want to use a different indentation style. This is -made partly possible by a number of variables at the beginning of -caml.el. Try to set them. However this only changes the size of -indentations, not really the look of your program. This is enough to -disable the two idioms above, but to do anything more you will have to -edit the code... Enjoy! - -This mode does not force you to put ;; in your program. This means -that we had to use a heuristic to decide where a phrase starts and -stops, to speed up the code. A phrase starts when any of the keywords -let, type, class, module, functor, exception, val, external, appears -at the beginning of a line. Using the first column for such keywords -in other cases may confuse the phrase selection function. - -Comments and bug reports to - - Jacques Garrigue diff --git a/emacs/README.itz b/emacs/README.itz deleted file mode 100644 index 8e1366f478..0000000000 --- a/emacs/README.itz +++ /dev/null @@ -1,177 +0,0 @@ -DESCRIPTION: - -This directory contains files to help editing Caml code, running a -Caml toplevel, and running the Caml debugger under the Gnu Emacs editor. - -AUTHORS: - -Ian T Zimmerman added indentation to caml mode, beefed -up camldebug to work much like gud/gdb. - -Xavier Leroy (Xavier.Leroy@inria.fr), Jerome Vouillon (Jerome.Vouillon@ens.fr). -camldebug.el is derived from FSF code. - -CONTENTS: - - caml.el A major mode for editing Caml code in Gnu Emacs - inf-caml.el To run a Caml toplevel under Emacs, with input and - output in an Emacs buffer. - camldebug.el To run the Caml debugger under Emacs. - - -NOTE FOR EMACS 18 USERS: - -This package will no longer work with Emacs 18.x. Sorry. You really -should consider upgrading to Emacs 19. - -USAGE: - -Add the following lines to your .emacs file: - -(setq auto-mode-alist (cons '("\\.ml[iylp]?" . caml-mode) auto-mode-alist)) -(autoload 'caml-mode "caml" "Major mode for editing Caml code." t) -(autoload 'run-caml "inf-caml" "Run an inferior Caml process." t) -(autoload 'camldebug "camldebug" "Run the Caml debugger." t) - -The Caml major mode is triggered by visiting a file with extension .ml, -.mli, .mly. .mll or .mlp, or manually by M-x caml-mode. It gives you the -correct syntax table for the Caml language. For a brief description of -the indentation capabilities, see below under NEWS. - -The Caml mode also allows you to run batch Caml compilations from -Emacs (using M-x compile) and browse the errors (C-x `). Typing C-x ` -sets the point at the beginning of the erroneous program fragment, and -the mark at the end. Under Emacs 19, the program fragment is -temporarily highlighted. - -M-x run-caml starts a Caml toplevel with input and output in an Emacs -buffer named *inferior-caml*. This gives you the full power of Emacs -to edit the input to the Caml toplevel. This mode is based on comint -so you get all the usual comint features, including command history. - -After M-x run-caml, typing C-c C-e or M-C-x in a buffer in Caml mode -sends the current phrase (containing the point) to the Caml toplevel, -and evaluates it. - -M-x camldebug FILE starts the Caml debugger camldebug on the executable -FILE, with input and output in an Emacs buffer named *camldebug-FILE*. -For a brief description of the commands available in this buffer, see -NEWS below. - -NEWS: - -Ok, so this is the really important part of this file :-) I took the -original package from the contrib subdirectory of the caml-light -distribution, and hacked on it. First, I added real syntax dependent -indentation to caml mode. Like Xavier has said, it was hard (and I -knew it would be), but I refused to believe it was impossible, partly -because I knew of a Standard ML mode with indentation (written by -Matthew Morley). - -Indentation works pretty much like in other programming modes. C-j at -the end of a line starts a new line properly indented. M-C-\ indents -the current region (this may take a while :-)). I incorporated a -slightly different TAB function, one that I use in other modes: if TAB -is pressed while the point is not in line indentation, the line is -indented to the column where point is (instead of just inserting a TAB -character - you can always to that with C-q C-i). This way, you can -indent a line any time, regardless of where the point lies, by hitting -TAB twice in succession. If you don't like this behaviour (but you -should), it's quite easy to add to your startup code like this: - -(defun caml-old-style-indent () - (if (caml-in-indentation) - (caml-indent-command) - (insert "\t"))) - -(add-hook 'caml-mode-hook - (function (lambda () - (define-key 'caml-mode-map "\t" - caml-old-style-indent)))) - -You can customize the appearance of your caml code by twiddling the -variables listed at the start of caml.el. Good luck. :-) - -Other news in caml mode are the various caml-insert-*-form commands. I -believe they are self-explanatory - just do a C-h m in a caml buffer -to see what you've got. - -The ohter major news is that I changed camldebug mode considerably. I -took many clues from the gud "Grand Unified Debugger" mode distributed -with modern versions of Emacs. The main benefit here is that you can -do debugger commands _from your caml source buffer_. Commands with the -C-c prefix in the debugger buffer have counterparts which do the same -thing (well, a similar thing) in the source buffer, with the C-x C-a -prefix. - -I made the existing debugger commands smarter in that they now attempt -to guess the correct parameter to the underlying camldebug command. A -numeric argument will always override that guess. For example, the -guess for C-c C-b (camldebug-break) is to set a breakpoint at the -current event (which was the only behaviour provided with the old -camldebug.el). But C-u 1 C-c C-b will now send "break 1" to the -camldebug process, setting a break at code address 1. - -This also allowed me to add many more commands for which the -underlying camldebug commands require a parameter. The best way to -learn about them is to do C-h m in the camldebug buffer, and then C-h -f for the commands you'll see listed. - -Finally, I added command completion. To use it, you'll have to apply -the provided patch to the debugger itself -(contrib/debugger/command_line_interpreter.ml), and recompile it -(you'll get one warning from the compiler; it is safe to ignore -it). Then hitting TAB in the following situation, for example: - -(cdb) pri_ - -will complete the "pri" to "print". - -CAVEATS: - -I don't use X and haven't tested this stuff under the X mode of -emacs. It is entirely possible (though not very probable) that I -introduced some undesirable interaction between X (fontification, -highlighting,...) and caml mode. I will welcome reports of such -problems (see REPORTING below), but I won't be able to do much about -them unless you also provide a patch. - -I don't know if the informational messages produced by camldebug are -internationalized. If they are, the debugger mode won't work unless -you set the language to English. The mode uses the messages to -synchronize with camldebug, and looks for fixed Emacs regular -expressions that match them. This may be fixed (if necessary) in a -future release. - -BUGS: - -In the debugger buffer, it's possible to overflow your mental stack by -asking for help on help on help on help on help on help on help on -help... - -THANKS: - -Xavier Leroy for Caml-light. Used together with the -Emacs interface, it is about the most pleasant programming environment -I've known on any platform. - -Eric Raymond for gud, which camldebug mode apes. - -Barry Warsaw for elp, without which I wouldn't have -been able to get the indentation code to perform acceptably. - -Gareth Rees for suggestions how to speed up -Emacs regular expression search, even if I didn't use them in the end. - -Bill Dubuque for alerting me to the -necessity of guarding against C-g inside Emacs code which modifies -syntax tables. - -REPORTING: - -Bug reports (preferably with patches), suggestions, donations etc. to: - -Ian T Zimmerman +-------------------------------------------+ -Box 13445 I With so many executioners available, I -Berkeley CA 94712 USA I suicide is a really foolish thing to do. I -mailto:itz@rahul.net +-------------------------------------------+ diff --git a/emacs/caml-compat.el b/emacs/caml-compat.el deleted file mode 100644 index 63b4a480fd..0000000000 --- a/emacs/caml-compat.el +++ /dev/null @@ -1,28 +0,0 @@ -;; function definitions for old versions of emacs - -;; indent-line-to - -(if (not (fboundp 'indent-line-to)) - (defun indent-line-to (column) - "Indent current line to COLUMN. - -This function removes or adds spaces and tabs at beginning of line -only if necessary. It leaves point at end of indentation." - (if (= (current-indentation) column) - (back-to-indentation) - (beginning-of-line 1) - (delete-horizontal-space) - (indent-to column)))) - -;; buffer-substring-no-properties - -(cond - ((fboundp 'buffer-substring-no-properties)) - ((fboundp 'buffer-substring-without-properties) - (defalias 'buffer-substring-no-properties - 'buffer-substring-without-properties)) - (t - (defalias 'buffer-substring-no-properties 'buffer-substring))) - -(provide 'caml-compat) - diff --git a/emacs/caml-emacs.el b/emacs/caml-emacs.el deleted file mode 100644 index 5f35c2451a..0000000000 --- a/emacs/caml-emacs.el +++ /dev/null @@ -1,29 +0,0 @@ -;; for caml-help.el -(defalias 'caml-info-other-window 'info-other-window) - -;; for caml-types.el - -(defalias 'caml-line-beginning-position 'line-beginning-position) - -(defalias 'caml-read-event 'read-event) -(defalias 'caml-window-edges 'window-edges) -(defun caml-mouse-vertical-position () - (cddr (mouse-position))) -(defalias 'caml-ignore-event-p 'integer-or-marker-p) -(defalias 'caml-mouse-movement-p 'mouse-movement-p) -(defalias 'caml-sit-for 'sit-for) - -(defmacro caml-track-mouse (&rest body) (cons 'track-mouse body)) - -(defun caml-event-window (e) (posn-window (event-start e))) -(defun caml-event-point-start (e) (posn-point (event-start e))) -(defun caml-event-point-end (e) (posn-point (event-end e))) - -(defun caml-release-event-p (original event) - (and (equal (event-basic-type original) (event-basic-type event)) - (let ((modifiers (event-modifiers event))) - (or (member 'drag modifiers) - (member 'click modifiers))))) - - -(provide 'caml-emacs) diff --git a/emacs/caml-font.el b/emacs/caml-font.el deleted file mode 100644 index 678b2a5020..0000000000 --- a/emacs/caml-font.el +++ /dev/null @@ -1,125 +0,0 @@ -;; useful colors - -(cond - ((x-display-color-p) - (cond - ((not (memq 'font-lock-type-face (face-list))) - ; make the necessary faces - (make-face 'Firebrick) - (set-face-foreground 'Firebrick "Firebrick") - (make-face 'RosyBrown) - (set-face-foreground 'RosyBrown "RosyBrown") - (make-face 'Purple) - (set-face-foreground 'Purple "Purple") - (make-face 'MidnightBlue) - (set-face-foreground 'MidnightBlue "MidnightBlue") - (make-face 'DarkGoldenRod) - (set-face-foreground 'DarkGoldenRod "DarkGoldenRod") - (make-face 'DarkOliveGreen) - (set-face-foreground 'DarkOliveGreen "DarkOliveGreen4") - (make-face 'CadetBlue) - (set-face-foreground 'CadetBlue "CadetBlue") - ; assign them as standard faces - (setq font-lock-comment-face 'Firebrick) - (setq font-lock-string-face 'RosyBrown) - (setq font-lock-keyword-face 'Purple) - (setq font-lock-function-name-face 'MidnightBlue) - (setq font-lock-variable-name-face 'DarkGoldenRod) - (setq font-lock-type-face 'DarkOliveGreen) - (setq font-lock-reference-face 'CadetBlue))) - ; extra faces for documention - (make-face 'Stop) - (set-face-foreground 'Stop "White") - (set-face-background 'Stop "Red") - (make-face 'Doc) - (set-face-foreground 'Doc "Red") - (setq font-lock-stop-face 'Stop) - (setq font-lock-doccomment-face 'Doc) -)) - -; The same definition is in caml.el: -; we don't know in which order they will be loaded. -(defvar caml-quote-char "'" - "*Quote for character constants. \"'\" for Objective Caml, \"`\" for Caml-Light.") - -(defconst caml-font-lock-keywords - (list -;stop special comments - '("\\(^\\|[^\"]\\)\\((\\*\\*/\\*\\*)\\)" - 2 font-lock-stop-face) -;doccomments - '("\\(^\\|[^\"]\\)\\((\\*\\*[^*]*\\([^)*][^*]*\\*+\\)*)\\)" - 2 font-lock-doccomment-face) -;comments - '("\\(^\\|[^\"]\\)\\((\\*[^*]*\\*+\\([^)*][^*]*\\*+\\)*)\\)" - 2 font-lock-comment-face) -;character literals - (cons (concat caml-quote-char "\\(\\\\\\([ntbr" caml-quote-char "\\]\\|" - "[0-9][0-9][0-9]\\)\\|.\\)" caml-quote-char - "\\|\"[^\"\\]*\\(\\\\\\(.\\|\n\\)[^\"\\]*\\)*\"") - 'font-lock-string-face) -;modules and constructors - '("`?\\<[A-Z][A-Za-z0-9_']*\\>" . font-lock-function-name-face) -;definition - (cons (concat - "\\<\\(a\\(nd\\|s\\)\\|c\\(onstraint\\|lass\\)" - "\\|ex\\(ception\\|ternal\\)\\|fun\\(ct\\(ion\\|or\\)\\)?" - "\\|in\\(herit\\|itializer\\)?\\|let" - "\\|m\\(ethod\\|utable\\|odule\\)" - "\\|of\\|p\\(arser\\|rivate\\)\\|rec\\|type" - "\\|v\\(al\\|irtual\\)\\)\\>") - 'font-lock-type-face) -;blocking - '("\\<\\(begin\\|end\\|object\\|s\\(ig\\|truct\\)\\)\\>" - . font-lock-keyword-face) -;control - (cons (concat - "\\<\\(do\\(ne\\|wnto\\)?\\|else\\|for\\|i\\(f\\|gnore\\)" - "\\|lazy\\|match\\|new\\|or\\|t\\(hen\\|o\\|ry\\)" - "\\|w\\(h\\(en\\|ile\\)\\|ith\\)\\)\\>" - "\\|\|\\|->\\|&\\|#") - 'font-lock-reference-face) - '("\\" . font-lock-comment-face) -;labels (and open) - '("\\(\\([~?]\\|\\<\\)[a-z][a-zA-Z0-9_']*:\\)[^:=]" 1 - font-lock-variable-name-face) - '("\\<\\(assert\\|open\\|include\\)\\>\\|[~?][ (]*[a-z][a-zA-Z0-9_']*" - . font-lock-variable-name-face))) - -(defconst inferior-caml-font-lock-keywords - (append - (list -;inferior - '("^[#-]" . font-lock-comment-face)) - caml-font-lock-keywords)) - -;; font-lock commands are similar for caml-mode and inferior-caml-mode -(add-hook 'caml-mode-hook - '(lambda () - (cond - ((fboundp 'global-font-lock-mode) - (make-local-variable 'font-lock-defaults) - (setq font-lock-defaults - '(caml-font-lock-keywords nil nil ((?' . "w") (?_ . "w"))))) - (t - (setq font-lock-keywords caml-font-lock-keywords))) - (make-local-variable 'font-lock-keywords-only) - (setq font-lock-keywords-only t) - (font-lock-mode 1))) - -(defun inferior-caml-mode-font-hook () - (cond - ((fboundp 'global-font-lock-mode) - (make-local-variable 'font-lock-defaults) - (setq font-lock-defaults - '(inferior-caml-font-lock-keywords - nil nil ((?' . "w") (?_ . "w"))))) - (t - (setq font-lock-keywords inferior-caml-font-lock-keywords))) - (make-local-variable 'font-lock-keywords-only) - (setq font-lock-keywords-only t) - (font-lock-mode 1)) - -(add-hook 'inferior-caml-mode-hooks 'inferior-caml-mode-font-hook) - -(provide 'caml-font) diff --git a/emacs/caml-help.el b/emacs/caml-help.el deleted file mode 100644 index ea082bf242..0000000000 --- a/emacs/caml-help.el +++ /dev/null @@ -1,815 +0,0 @@ -;; caml-info.el --- contextual completion and help to caml-mode - -;; Didier Remy, November 2001. - -;; This provides two functions completion and help -;; look for caml-complete and caml-help - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; This is a preliminary version. -;; -;; Possible improvements? -;; - dump some databaes: Info, Lib, ... -;; - accept a search path for local libraries instead of current dir -;; (then distinguish between different modules lying in different -;; directories) -;; - improve the construction for info files. -;; -;; Abstract over -;; - the viewing method and the database, so that the documentation for -;; and identifier could be search in -;; * info / html / man / mli's sources -;; * viewed in emacs or using an external previewer. -;; -;; Take all identifiers (labels, Constructors, exceptions, etc.) -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - -(eval-and-compile - (if (and (boundp 'running-xemacs) running-xemacs) - (require 'caml-xemacs) - (require 'caml-emacs))) - -;; Loading or building databases. -;; - -;; variables to be customized - -(defvar ocaml-lib-path 'lazy - "Path list for ocaml lib sources (mli files) - -'lazy means ask ocaml to find it for your at first use.") -(defun ocaml-lib-path () - "Computes if necessary and returns the path for ocaml libs" - (if (listp ocaml-lib-path) nil - (setq ocaml-lib-path - (split-string - (shell-command-to-string - (or - (and (boundp 'inferior-caml-program) - (string-match "\\([^ ]*/ocaml\\)\\( \\|$\\)" - inferior-caml-program) - (let ((file - (concat (match-string 1 inferior-caml-program) - "c"))) - (and (file-executable-p file) - (concat file " -where")))) - "ocamlc -where"))))) - ocaml-lib-path) - - - -;; General purpose auxiliary functions - -(defun ocaml-capitalize (s) - (concat (capitalize (substring s 0 1)) (substring s 1))) - -(defun ocaml-uncapitalize (s) - (if (> (length s) 0) - (concat (downcase (substring s 0 1)) (substring s 1)) - s)) - -(defun iter (f l) (while (consp l) (apply f (list (car l))) (setq l (cdr l)))) - -(defun ocaml-find-files (path filter &optional depth split) - (let* ((path-string - (if (stringp path) - (if (file-directory-p path) path nil) - (mapconcat '(lambda (d) (if (file-directory-p d) d)) - path " "))) - (command - (and path-string - (concat "find " path-string - " '(' " filter " ')' " - (if depth (concat " -maxdepth " (int-to-string depth))) - (if split nil " -printf '%\p '") - ))) - (files - (and command (shell-command-to-string command)))) - (if (and split (stringp files)) (split-string files "\n") files) - )) - -;; Specialized auxiliary functions - - -;; Global table of modules contents of modules loaded lazily. - -(defvar ocaml-module-alist 'lazy - "A-list of modules with how and where to find help information. - 'delay means non computed yet") - -(defun ocaml-add-mli-modules (modules tag &optional path) - (let ((files - (ocaml-find-files (or path (ocaml-lib-path)) - "-type f -name '*.mli'" 1 t))) - (while (consp files) - (if (string-match "\\([^/]*\\).mli" (car files)) - (let* ((module (ocaml-capitalize (match-string 1 (car files)))) - (dir (file-name-directory (car files))) - (dirp (member dir (ocaml-lib-path)))) - (if (and (consp dirp) (string-equal dir (car dirp))) - (setq dir (car dirp))) - (if (assoc module modules) nil - (setq modules - (cons (cons module (cons (cons tag dir) 'lazy)) modules)) - ))) - (setq files (cdr files))) - modules)) - -(defun ocaml-add-path (dir &optional path) - "Extend ocaml-module-alist with modules of DIR relative to PATH" - (interactive "D") - (let* ((old (ocaml-lib-path)) - (new - (if (file-name-absolute-p dir) dir - (concat - (or (find-if '(lambda (p) (file-directory-p (concat p "/" dir))) - (cons default-directory old)) - (error "Directory not found")) - "/" dir)))) - (setq ocaml-lib-path (cons (car old) (cons new (cdr old)))) - (setq ocaml-module-alist - (ocaml-add-mli-modules (ocaml-module-alist) 'lib new)))) - -(defun ocaml-module-alist () - "Call by need value of variable ocaml-module-alist" - (if (listp ocaml-module-alist) - nil - ;; build list of mli files - (setq ocaml-module-alist (ocaml-add-mli-modules nil 'lib)) - ;; dumping information ? TODO - ) - ocaml-module-alist) - -(defun ocaml-get-or-make-module (module &optional tag) - (let ((info (assoc module (ocaml-module-alist)))) - (if info nil - (setq info (cons module (cons (cons 'local default-directory) 'lazy))) - (setq ocaml-module-alist (cons info ocaml-module-alist)) - ) - info)) - -;; Symbols of module are lazily computed - -(defun ocaml-module-filename (module) - (let ((module (ocaml-uncapitalize module)) (name)) - (if (file-exists-p (setq name (concat module ".mli"))) nil - (let ((tmp (ocaml-lib-path))) - (while (consp tmp) - (setq name (concat (car tmp) "/" module ".mli")) - (if (file-exists-p name) (setq tmp nil) - (setq name nil))))) - name)) - -(defun ocaml-module-symbols (module-info) - (let* ((module (car module-info)) - (tail (and module-info (cdr module-info))) - (tag (caar tail)) - (dir (cdar tail)) - (file) - (alist)) - (if (listp (cdr tail)) - (cdr tail) - (if (equal tag 'info) - (setq dir (car ocaml-lib-path)) ; XXX to be fixed - ) - (setq file (concat dir "/" (ocaml-uncapitalize module) ".mli")) - (message file) - (save-window-excursion - (set-buffer (get-buffer-create "*caml-help*")) - (if (and file (file-exists-p file)) - (progn - (message "Scanning module %s" file) - (insert-file-contents file)) - (message "Module %s not found" module)) - (while (re-search-forward - "\\([ \t]*val\\|let\\|external\\| [|]\\) \\([a-zA-Z_0-9'][a-zA-Z_0-9']*\\)\\|^ *[{]* \\([a-z_][A-Za-z_0-9]*\\) : [^;\n][^;\n]*;" - (point-max) 'move) - (pop-to-buffer (current-buffer)) - (setq alist (cons (or (match-string 2) (match-string 3)) alist))) - (erase-buffer) - ) - (setcdr tail alist) - alist) - )) - -;; Local list of visible modules. - -(defvar ocaml-visible-modules 'lazy - "A-list of open modules, local to every file.") -(make-variable-buffer-local 'ocaml-visible-modules) -(defun ocaml-visible-modules () - (if (listp ocaml-visible-modules) nil - (progn - (setq ocaml-visible-modules - (list (ocaml-get-or-make-module "Pervasives"))) - (save-excursion - (goto-char (point-min)) - (while (re-search-forward "^ *open *\\([A-Z][a-zA-Z'_0-9]*\\)" - (point-max) t) - (let ((module (match-string 1))) - (if (assoc module ocaml-visible-modules) nil - (setq ocaml-visible-modules - (cons (ocaml-get-or-make-module module) - ocaml-visible-modules))))) - ))) - ocaml-visible-modules) - -(defun ocaml-open-module (arg) - "*Make module of name ARG visible whe ARG is a string. -When call interactively, make completion over known modules." - (interactive "P") - (if (not (stringp arg)) - (let ((modules (ocaml-module-alist))) - (setq arg - (completing-read "Open module: " modules)))) - (if (and (stringp arg) (not (equal arg ""))) - (progn - (if (assoc arg (ocaml-visible-modules)) - (ocaml-close-module arg)) - (setq ocaml-visible-modules - (cons (ocaml-get-or-make-module arg) (ocaml-visible-modules))) - )) - (message "%S" (mapcar 'car (ocaml-visible-modules)))) - -(defun ocaml-close-module (arg) - "*Close module of name ARG when ARG is a string. -When call interactively, make completion over visible modules. -Otherwise if ARG is true, close all modules and reset to default. " - (interactive "P") - (if (= (prefix-numeric-value arg) 4) - (setq ocaml-visible-modules 'lazy) - (let* ((modules (ocaml-visible-modules))) - (if (null modules) (error "No visible module to close")) - (unless (stringp arg) - (setq arg - (completing-read - (concat "Close module [" (caar modules) "] : ") - modules)) - (if (equal arg "") (setq arg (caar modules)))) - (setq ocaml-visible-modules - (remove-if '(lambda (m) (equal (car m) arg)) - ocaml-visible-modules)) - )) - (message "%S" (mapcar 'car (ocaml-visible-modules)))) - - -;; Look for identifiers around point - -(defun ocaml-qualified-identifier (&optional show) - "Search for a qualified identifier (Path. entry) around point. - -Entry may be nil. -Currently, the path may only be nil or a single Module. -For paths is of the form Module.Path', it returns Module -and always nil for entry. - -If defined Module and Entry are represented by a region in the buffer, -and are nil otherwise. - -For debugging purposes, it returns the string Module.entry if called -with an optional non-nil argument. -" - (save-excursion - (let ((module) (entry)) - (if (looking-at "[ \n]") (skip-chars-backward " ")) - (if (re-search-backward - "\\([^A-Za-z0-9_.']\\|\\`\\)\\([A-Za-z0-9_']*[.]\\)*[A-Za-z0-9_']*\\=" - (- (point) 100) t) - (progn - (or (looking-at "\\`[A-Za-z)-9_.]") (forward-char 1)) - (if (looking-at "\\<\\([A-Za-z_][A-Za-z0-9_']*\\)[.]") - (progn - (setq module (cons (match-beginning 1) (match-end 1))) - (goto-char (match-end 0)))) - (if (looking-at "\\<\\([A-Za-z_][A-Za-z0-9_']*\\)\\>") - (setq entry (cons (match-beginning 1) (match-end 1)))))) - (if show - (concat - (and module (buffer-substring (car module) (cdr module))) - "." - (and entry (buffer-substring (car entry) (cdr entry)))) - (cons module entry)) - ))) - -;; completion around point - -(defun ocaml-completion (pattern module) - (let ((list - (or - (and module - (list - (or (assoc module (ocaml-module-alist)) - (error "Unknown module %s" module)))) - (ocaml-visible-modules)))) - (message "Completion from %s" (mapconcat 'car list " ")) - (if (null pattern) - (apply 'append (mapcar 'ocaml-module-symbols list)) - (let ((pat (concat "^" (regexp-quote pattern))) (res)) - (iter - '(lambda (l) - (iter '(lambda (x) - (if (string-match pat (car l)) - (if (member x res) nil (setq res (cons x res))))) - (ocaml-module-symbols l))) - list) - res) - ))) - -(defun caml-complete (arg) - "Does completion for OCaml identifiers qualified. - -It attemps to recognize an qualified identifier Module . entry -around point using function \\[ocaml-qualified-identifier]. - -If Module is defined, it does completion for identifier in Module. - -If Module is undefined, it does completion in visible modules. -Then, if completion fails, it does completion among all modules -where identifier is defined." - (interactive "p") - (let* ((module-entry (ocaml-qualified-identifier)) (entry) - (module) - (beg) (end) (pattern)) - (if (car module-entry) - (progn - (setq module - (buffer-substring (caar module-entry) (cdar module-entry))) - (or (assoc module (ocaml-module-alist)) - (and (setq module - (completing-read "Module: " (ocaml-module-alist) - nil nil module)) - (save-excursion - (goto-char (caar module-entry)) - (delete-region (caar module-entry) (cdar module-entry)) - (insert module) t) - (setq module-entry (ocaml-qualified-identifier)) - (car module-entry) - (progn (setq entry (cdr module-entry)) t)) - (error "Unknown module %s" module)))) - (if (consp (cdr module-entry)) - (progn - (setq beg (cadr module-entry)) - (setq end (cddr module-entry))) - (if (and module - (save-excursion - (goto-char (cdar module-entry)) - (looking-at " *[.]"))) - (progn - (setq beg (match-end 0)) - (setq end beg)))) - (if (not (and beg end)) - (error "Did not find anything to complete around point") - - (setq pattern (buffer-substring beg end)) - (let* ((all-completions (ocaml-completion pattern module)) - (completion - (try-completion pattern (mapcar 'list all-completions)))) - (cond ((eq completion t)) - - ((null completion) - (let* - ((modules (ocaml-find-module pattern)) - (visible (intersection modules (ocaml-visible-modules))) - (hist) - (module - (cond - ((null modules) - nil) - ((equal (length modules) 1) - (caar modules)) - ((equal (length visible) 1) - (caar visible)) - (t - (setq hist (mapcar 'car modules)) - (completing-read "Module: " modules nil t - "" (cons hist 0))) - ))) - (if (null module) - (error "Can't find completion for \"%s\"" pattern) - (message "Completion found in module %s" module) - (if (and (consp module-entry) (consp (cdr module-entry))) - (delete-region (caar module-entry) end) - (delete-region beg end)) - (insert module "." pattern)))) - - ((not (string-equal pattern completion)) - (delete-region beg end) - (goto-char beg) - (insert completion)) - - (t - (with-output-to-temp-buffer "*Completions*" - (display-completion-list all-completions)) - )) - )))) - - -;; Info files (only in ocamldoc style) - - -(defvar ocaml-info-prefix "ocaml-lib" - "Prefix of ocaml info files describing library modules. -Suffix .info will be added to info files. -Additional suffix .gz may be added if info files are compressed. -") -;; - -(defun ocaml-hevea-info-add-entries (entries dir name) - (let* - ((filter - (concat "-type f -regex '.*/" name - "\\(.info\\|\\)\\(-[0-9]*\\|\\)\\([.]gz\\|\\)'" - )) - (section-regexp - "\\* \\(Section [1-9][0-9--]*\\)::[ \t][ \t]*Module *\\([A-Z][A-Za-z_0-9]*\\)") - (files (ocaml-find-files dir filter)) - (command)) - ;; scanning info files - (if (or (null files) - (not (stringp files)) - (string-match files "^ *$")) - (message "No info file found: %s." (mapconcat 'identity files " ")) - (message "Scanning info files %s." files) - (save-window-excursion - (set-buffer (get-buffer-create "*caml-help*")) - (setq command - (concat "zcat -f " files - " | grep -e '" section-regexp "'")) - (message "Scanning files with: %s" command) - (or (shell-command command (current-buffer)) - (error "Error while scanning")) - (goto-char (point-min)) - (while (re-search-forward section-regexp (point-max) t) - (let* ((module (match-string 2)) - (section (match-string 1))) - ;; (message "%s %s" module section) - (if (assoc module entries) nil - (setq entries - (cons (cons module (concat "(" name ")" section)) - entries)) - ))) - (let ((buf (get-buffer "*caml-help*"))) - (if buf (kill-buffer buf))))) - entries)) - -(defun ocaml-hevea-info () - "The default way to create an info data base from the value -of \\[Info-default-directory-list] and the base name \\[ocaml-info-name] -of files to look for. - -This uses info files produced by HeVeA. -" - (let ((collect) (seen)) - (iter '(lambda (d) - (if (member d seen) nil - (setq collect - (ocaml-hevea-info-add-entries - collect d ocaml-info-prefix)) - (setq done (cons d seen)))) - Info-directory-list) - collect)) - -(defun ocaml-ocamldoc-info-add-entries (entries dir name) - (let* - ((module-regexp "^Node: \\([A-Z][A-Za-z_0-9]*\\)[^ ]") - (command - (concat - "find " dir " -type f -regex '.*/" name - "\\(.info\\|\\)\\([.]gz\\|\\)' -print0" - " | xargs -0 zcat -f | grep '" module-regexp "'"))) - (message "Scanning info files in %s" dir) - (save-window-excursion - (set-buffer (get-buffer-create "*caml-help*")) - (or (shell-command command (current-buffer)) (error "HERE")) - (goto-char (point-min)) - (while (re-search-forward module-regexp (point-max) t) - (if (equal (char-after (match-end 1)) 127) - (let* ((module (match-string 1))) - (if (assoc module entries) nil - (setq entries - (cons (cons module (concat "(" name ")" module)) - entries)) - )))) - ; (kill-buffer (current-buffer)) - ) - entries)) - -(defun ocaml-ocamldoc-info () - "The default way to create an info data base from the value -of \\[Info-default-directory-list] and the base name \\[ocaml-info-name] -of files to look for. - -This uses info files produced by ocamldoc." - (require 'info) - (let ((collect) (seen)) - (iter '(lambda (d) - (if (member d seen) nil - (setq collect - (ocaml-ocamldoc-info-add-entries collect d - ocaml-info-prefix)) - (setq done (cons d seen)))) - Info-directory-list) - collect)) - -;; Continuing - -(defvar ocaml-info-alist 'ocaml-ocamldoc-info - "A-list binding module names to info entries: - - nil means do not use info. - - A function to build the list lazily (at the first call). The result of -the function call will be assign permanently to this variable for future -uses. We provide two default functions \\[ocaml-info-default-function] -(info produced by HeVeA is the default) and \\[ocaml-info-default-function] -(info produced by ocamldoc). - - Otherwise, this value should be an alist binding module names to info -entries of the form to \"(entry)section\" be taken by the \\[info] -command. An entry may be an info module or a complete file name." -) - -(defun ocaml-info-alist () - "Call by need value of variable ocaml-info-alist" - (cond - ((listp ocaml-info-alist)) - ((functionp ocaml-info-alist) - (setq ocaml-info-alist (apply ocaml-info-alist nil))) - (t - (error "wrong type for ocaml-info-alist"))) - ocaml-info-alist) - -;; help around point - -(defun ocaml-find-module (symbol &optional module-list) - (let ((list (or module-list (ocaml-module-alist))) - (collect)) - (while (consp list) - (if (member symbol (ocaml-module-symbols (car list))) - (setq collect (cons (car list) collect))) - (setq list (cdr list))) - (nreverse collect) - )) - -(defun ocaml-buffer-substring (region) - (and region (buffer-substring-no-properties (car region) (cdr region)))) - -;; Help function. - - -(defun ocaml-goto-help (&optional module entry same-window) - "Searches info manual for MODULE and ENTRY in MODULE. -If unspecified, MODULE and ENTRY are inferred from the position in the -current buffer using \\[ocaml-qualified-identifier]." - (interactive) - (let ((window (selected-window)) - (info-section (assoc module (ocaml-info-alist)))) - (if info-section - (caml-info-other-window (cdr info-section)) - (ocaml-visible-modules) - (let* ((module-info - (or (assoc module (ocaml-module-alist)) - (and (file-exists-p - (concat (ocaml-uncapitalize module) ".mli")) - (ocaml-get-or-make-module module)))) - (location (cdr (cadr module-info)))) - (cond - (location - (let ((file (concat location (ocaml-uncapitalize module) ".mli"))) - (if (window-live-p same-window) - (progn (select-window same-window) - (view-mode-exit view-return-to-alist view-exit-action)) - ;; (view-buffer (find-file-noselect file) 'view)) - ) - (view-file-other-window file) - (bury-buffer (current-buffer)))) - (info-section (error "Aborted")) - (t (error "No help for module %s" module)))) - ) - (if (stringp entry) - (let ((here (point)) - (case-fold-search nil)) - (goto-char (point-min)) - (if (or (re-search-forward - (concat "\\(val\\|exception\\|type\\|external\\|[|{;]\\) +" - (regexp-quote entry)) - (point-max) t) - (re-search-forward - (concat "type [^{]*{[^}]*" (regexp-quote entry) " :") - (point-max) t) - (progn - (if (window-live-p window) (select-window window)) - (error "Entry %s not found in module %s" - entry module)) - ;; (search-forward entry (point-max) t) - ) - (recenter 1) - (progn - (message "Help for entry %s not found in module %s" - entry module) - (goto-char here))))) - (ocaml-link-activate (cdr info-section)) - (if (window-live-p window) (select-window window)) - )) - -(defun caml-help (arg) - "Find documentation for OCaml qualified identifiers. - -It attemps to recognize an qualified identifier of the form -``Module . entry'' around point using function `ocaml-qualified-identifier'. - -If Module is undetermined it is temptatively guessed from the identifier name -and according to visible modules. If this is still unsucessful, the user is -then prompted for a Module name. - -The documentation for Module is first seach in the info manual if available, -then in the ``module.mli'' source file. The entry is then searched in the documentation. - -Visible modules are computed only once, at the first call. -Modules can be made visible explicitly with `ocaml-open-module' and -hidden with `ocaml-close-module'. - -Prefix arg 0 forces recompilation of visible modules (and their content) -from the file content. - -Prefix arg 4 prompts for Module and identifier instead of guessing values -from the possition of point in the current buffer. -" - (interactive "p") - (let ((module) (entry) (module-entry)) - (cond - ((= arg 4) - (or (and - (setq module - (completing-read "Module: " (ocaml-module-alist) - nil t "" (cons 'hist 0))) - (not (string-equal module ""))) - (error "Quit")) - (let ((symbols - (mapcar 'list - (ocaml-module-symbols - (assoc module (ocaml-module-alist)))))) - (setq entry (completing-read "Value: " symbols nil t))) - (if (string-equal entry "") (setq entry nil)) - ) - (t - (if (= arg 0) (setq ocaml-visible-modules 'lazy)) - (setq module-entry (ocaml-qualified-identifier)) - (setq entry (ocaml-buffer-substring (cdr module-entry))) - (setq module - (or (ocaml-buffer-substring (car module-entry)) - (let ((modules - (or (ocaml-find-module entry (ocaml-visible-modules)) - (ocaml-find-module entry))) - (hist) (default)) - (cond - ((null modules) - (error "No module found for entry %s" entry)) - ((equal (length modules) 1) - (caar modules)) - (t - (setq hist (mapcar 'car modules)) - (setq default (car hist)) - (setq module - (completing-read - (concat "Module: " - (and default (concat "[" default "] "))) - modules nil t "" (cons 'hist 0))) - (if (string-equal module "") default module)) - )))) - )) - (message "Help for %s%s%s" module (if entry "." "") (or entry "")) - (ocaml-goto-help module entry) - )) - -;; auto-links - -(defconst ocaml-link-regexp - "\\(type\\|and\\) \\('[a-z] +\\|(\\('[a-z], *\\)*'[a-z])\\|\\) *\\([a-zA-Z0-9_]*\\)\\( *$\\| =\\)") -(defconst ocaml-longident-regexp - "\\([A-Z][a-zA-Z_0]*\\)[.]\\([a-zA-Z][A-Za-z0-9_]*\\)") - -(defvar ocaml-links nil - "Local links in the current of last info node or interface file. - -The car of the list is a key that indentifies the module to prevent -recompilation when next help command is relative to the same module. -The cdr is a list of elments, each of which is an string and a pair of -buffer positions." -) -(make-variable-buffer-local 'ocaml-links) - -(defun ocaml-info-links (section) - (cdr - (if (and ocaml-links section (equal (car ocaml-links) section)) - ocaml-links - (save-excursion - (goto-char (point-min)) - (let ((regexp (concat (if (equal major-mode 'Info-mode) "^ - " "^") - ocaml-link-regexp)) - (all)) - (while (re-search-forward regexp (point-max) t) - (setq all - (cons (cons (match-string 4) - (cons (match-beginning 4) - (match-end 4))) - all))) - (setq ocaml-links (cons section all)) - ))))) - -(defvar ocaml-link-map (make-sparse-keymap)) -(define-key ocaml-link-map [mouse-2] 'ocaml-link-goto) - -(defun ocaml-link-goto (click) - (interactive "e") - (let* ((pos (caml-event-point-start click)) - (win (caml-event-window click)) - (buf (window-buffer win)) - (window (selected-window)) - (link)) - (setq link - (with-current-buffer buf - (buffer-substring - (previous-single-property-change (+ pos 1) 'local-map - buf (- pos 100)) - (next-single-property-change pos 'local-map - buf (+ pos 100))))) - (if (string-match (concat "^" ocaml-longident-regexp "$") link) - (ocaml-goto-help (match-string 1 link) (match-string 2 link) win) - (if (not (equal (window-buffer window) buf)) - (switch-to-buffer-other-window buf)) - (if (setq link (assoc link (cdr ocaml-links))) - (progn - (goto-char (cadr link)) - (recenter 1))) - (if (window-live-p window) (select-window window)) - ))) - -(cond - ((and (x-display-color-p) - (not (memq 'ocaml-link-face (face-list)))) - (make-face 'ocaml-link-face) - (set-face-foreground 'ocaml-link-face "Purple"))) - - -(defun ocaml-link-activate (section) - (let ((links (ocaml-info-links section))) - (if links - (let ((regexp (concat "[^A-Za-z0-9'_]\\(" - ocaml-longident-regexp "\\|" - (mapconcat 'car links "\\|") - "\\)[^A-Za-z0-9'_]")) - (case-fold-search nil)) - (goto-char (point-min)) - (let ((buffer-read-only nil) - ;; use of dynamic scoping, need not be restored! - (modified-p (buffer-modified-p))) - (unwind-protect - (save-excursion - (goto-char (point-min)) - (while (re-search-forward regexp (point-max) t) - (put-text-property (match-beginning 1) (match-end 1) - 'mouse-face 'highlight) - (put-text-property (match-beginning 1) (match-end 1) - 'local-map ocaml-link-map) - (if (x-display-color-p) - (put-text-property (match-beginning 1) (match-end 1) - 'face 'ocaml-link-face))) - ) - ;; need to restore flag if buffer was unmodified. - (unless modified-p (set-buffer-modified-p nil)) - )) - )))) - - - -;; bindings ---now in caml.el - -; (and -; (boundp 'caml-mode-map) -; (keymapp caml-mode-map) -; (progn -; (define-key caml-mode-map [?\C-c?i] 'ocaml-add-path) -; (define-key caml-mode-map [?\C-c?]] 'ocaml-close-module) -; (define-key caml-mode-map [?\C-c?[] 'ocaml-open-module) -; (define-key caml-mode-map [?\C-c?\C-h] 'caml-help) -; (define-key caml-mode-map [?\C-c?\t] 'caml-complete) -; (let ((map (lookup-key caml-mode-map [menu-bar caml]))) -; (and -; (keymapp map) -; (progn -; (define-key map [separator-help] '("---")) -; (define-key map [open] '("Open add path" . ocaml-add-path )) -; (define-key map [close] -; '("Close module for help" . ocaml-close-module)) -; (define-key map [open] '("Open module for help" . ocaml-open-module)) -; (define-key map [help] '("Help for identifier" . caml-help)) -; (define-key map [complete] '("Complete identifier" . caml-complete)) -; ) -; )))) - - -(provide 'caml-help) diff --git a/emacs/caml-hilit.el b/emacs/caml-hilit.el deleted file mode 100644 index 7b48a8119f..0000000000 --- a/emacs/caml-hilit.el +++ /dev/null @@ -1,53 +0,0 @@ -; Highlighting patterns for hilit19 under caml-mode - -; defined also in caml.el -(defvar caml-quote-char "'" - "*Quote for character constants. \"'\" for Objective Caml, \"`\" for Caml-Light.") - -(defconst caml-mode-patterns - (list -;comments - '("\\(^\\|[^\"]\\)\\((\\*[^*]*\\*+\\([^)*][^*]*\\*+\\)*)\\)" - 2 comment) -;string - (list 'hilit-string-find (string-to-char caml-quote-char) 'string) - (list (concat caml-quote-char "\\(\\\\\\([ntbr" caml-quote-char "\\]\\|" - "[0-9][0-9][0-9]\\)\\|.\\)" caml-quote-char) - nil - 'string) -;labels - '("\\(\\([~?]\\|\\<\\)[a-z][a-zA-Z0-9_']*:\\)[^:=]" 1 brown) - '("[~?][ (]*[a-z][a-zA-Z0-9_']*" nil brown) -;modules - '("\\<\\(assert\\|open\\|include\\)\\>" nil brown) - '("`?\\<[A-Z][A-Za-z0-9_\']*\\>" nil MidnightBlue) -;definition - (list (concat - "\\<\\(a\\(nd\\|s\\)\\|c\\(onstraint\\|lass\\)" - "\\|ex\\(ception\\|ternal\\)\\|fun\\(ct\\(ion\\|or\\)\\)?" - "\\|in\\(herit\\)?\\|let\\|m\\(ethod\\|utable\\|odule\\)" - "\\|of\\|p\\(arser\\|rivate\\)\\|rec\\|type" - "\\|v\\(al\\|irtual\\)\\)\\>") - nil 'ForestGreen) -;blocking - '("\\<\\(object\\|struct\\|sig\\|begin\\|end\\)\\>" 2 include) -;control - (list (concat - "\\<\\(do\\(ne\\|wnto\\)?\\|else\\|for\\|i\\(f\\|gnore\\)" - "\\|lazy\\|match\\|new\\|or\\|t\\(hen\\|o\\|ry\\)" - "\\|w\\(h\\(en\\|ile\\)\\|ith\\)\\)\\>" - "\\|\|\\|->\\|&\\|#") - nil 'keyword) - '(";" nil struct)) - "Hilit19 patterns used for Caml mode") - -(hilit-set-mode-patterns 'caml-mode caml-mode-patterns) -(hilit-set-mode-patterns - 'inferior-caml-mode - (append - (list -;inferior - '("^[#-]" nil firebrick)) - caml-mode-patterns)) - -(provide 'caml-hilit) diff --git a/emacs/caml-types.el b/emacs/caml-types.el deleted file mode 100644 index 743dd2f8ec..0000000000 --- a/emacs/caml-types.el +++ /dev/null @@ -1,572 +0,0 @@ -;(***********************************************************************) -;(* *) -;(* Objective Caml *) -;(* *) -;(* Damien Doligez, projet Moscova, INRIA Rocquencourt *) -;(* *) -;(* Copyright 2003 Institut National de Recherche en Informatique et *) -;(* en Automatique. All rights reserved. This file is distributed *) -;(* under the terms of the Q Public License version 1.0. *) -;(* *) -;(***********************************************************************) - -;(* $Id$ *) - -; An emacs-lisp complement to the "-dtypes" option of ocamlc and ocamlopt. - -;; XEmacs compatibility - -(eval-and-compile - (if (and (boundp 'running-xemacs) running-xemacs) - (require 'caml-xemacs) - (require 'caml-emacs))) - - - -(defvar caml-types-location-re nil "Regexp to parse *.annot files. - -Annotation files *.annot may be generated with the \"-dtypes\" option -of ocamlc and ocamlopt. - -Their format is: - - file ::= block * - block ::= position position annotation * - position ::= filename num num num - annotation ::= keyword open-paren data close-paren - - is a space character (ASCII 0x20) - is a line-feed character (ASCII 0x0A) - num is a sequence of decimal digits - filename is a string with the lexical conventions of O'Caml - open-paren is an open parenthesis (ASCII 0x28) - close-paren is a closed parenthesis (ASCII 0x29) - data is any sequence of characters where is always followed by - at least two space characters. - -- in each block, the two positions are respectively the start and the -- end of the range described by the block. -- in a position, the filename is the name of the file, the first num - is the line number, the second num is the offset of the beginning - of the line, the third num is the offset of the position itself. -- the char number within the line is the difference between the third - and second nums. - -For the moment, the only possible keyword is \"type\"." -) - -(let* ((caml-types-filename-re "\"\\(\\([^\\\"]\\|\\\\.\\)*\\)\"") - (caml-types-number-re "\\([0-9]*\\)") - (caml-types-position-re - (concat caml-types-filename-re " " - caml-types-number-re " " - caml-types-number-re " " - caml-types-number-re))) - (setq caml-types-location-re - (concat "^" caml-types-position-re " " caml-types-position-re))) - -(defvar caml-types-expr-ovl (make-overlay 1 1)) - -(make-face 'caml-types-face) -(set-face-doc-string 'caml-types-face - "face for hilighting expressions and types") -(if (not (face-differs-from-default-p 'caml-types-face)) - (set-face-background 'caml-types-face "#88FF44")) - -(defvar caml-types-typed-ovl (make-overlay 1 1)) - -(make-face 'caml-types-typed-face) -(set-face-doc-string 'caml-types-typed-face - "face for hilighting typed expressions") -(if (not (face-differs-from-default-p 'caml-types-typed-face)) - (set-face-background 'caml-types-typed-face "#FF8844")) - -(overlay-put caml-types-expr-ovl 'face 'caml-types-face) -(overlay-put caml-types-typed-ovl 'face 'caml-types-typed-face) - - -(defvar caml-types-annotation-tree nil) -(defvar caml-types-annotation-date nil) -(make-variable-buffer-local 'caml-types-annotation-tree) -(make-variable-buffer-local 'caml-types-annotation-date) - -(defvar caml-types-buffer-name "*caml-types*" - "Name of buffer for diplaying caml types") -(defvar caml-types-buffer nil - "buffer for diplaying caml types") - -(defun caml-types-show-type (arg) - "Show the type of expression or pattern at point. - The smallest expression or pattern that contains point is - temporarily highlighted. Its type is highlighted in the .annot - file and the mark is set to the beginning of the type. - The type is also displayed in the mini-buffer. - - Hints on using the type display: - . If you want the type of an identifier, put point within any - occurrence of this identifier. - . If you want the result type of a function application, put point - at the first space after the function name. - . If you want the type of a list, put point on a bracket, on a - semicolon, or on the :: constructor. - . Even if type checking fails, you can still look at the types - in the file, up to where the type checker failed. - -Types are also diplayed in the buffer *caml-types*, which buffer is -display when the commande is called with Prefix argument 4. - -See also `caml-types-explore' for exploration by mouse dragging. -See `caml-types-location-re' for annotation file format. -" - (interactive "p") - (let* ((target-buf (current-buffer)) - (target-file (file-name-nondirectory (buffer-file-name))) - (target-line (1+ (count-lines (point-min) - (caml-line-beginning-position)))) - (target-bol (caml-line-beginning-position)) - (target-cnum (point)) - (type-file (concat (file-name-sans-extension (buffer-file-name)) - ".annot"))) - (caml-types-preprocess type-file) - (unless caml-types-buffer - (setq caml-types-buffer (get-buffer-create caml-types-buffer-name))) - (let* ((targ-loc (vector target-file target-line target-bol target-cnum)) - (node (caml-types-find-location targ-loc () - caml-types-annotation-tree))) - (cond - ((null node) - (delete-overlay caml-types-expr-ovl) - (message "Point is not within a typechecked expression or pattern.") - ; (with-current-buffer type-buf (narrow-to-region 1 1)) - ) - (t - (let ((left (caml-types-get-pos target-buf (elt node 0))) - (right (caml-types-get-pos target-buf (elt node 1))) - (type (elt node 2))) - (move-overlay caml-types-expr-ovl left right target-buf) - (with-current-buffer caml-types-buffer - (erase-buffer) - (insert type) - (message (format "type: %s" type))) - )))) - (if (and (= arg 4) - (not (window-live-p (get-buffer-window caml-types-buffer)))) - (display-buffer caml-types-buffer)) - (unwind-protect - (caml-sit-for 60) - (delete-overlay caml-types-expr-ovl) - ))) - -(defun caml-types-preprocess (type-file) - (let* ((type-date (nth 5 (file-attributes type-file))) - (target-file (file-name-nondirectory (buffer-file-name))) - (target-date (nth 5 (file-attributes target-file)))) - (unless (and caml-types-annotation-tree - type-date - caml-types-annotation-date - (not (caml-types-date< caml-types-annotation-date type-date))) - (if (and type-date target-date (caml-types-date< type-date target-date)) - (error (format "%s is more recent than %s" target-file type-file))) - (message "Reading annotation file...") - (let* ((type-buf (caml-types-find-file type-file)) - (tree (with-current-buffer type-buf - (widen) - (goto-char (point-min)) - (caml-types-build-tree target-file)))) - (setq caml-types-annotation-tree tree - caml-types-annotation-date type-date) - (kill-buffer type-buf) - (message "")) - ))) - -(defun caml-types-date< (date1 date2) - (or (< (car date1) (car date2)) - (and (= (car date1) (car date2)) - (< (nth 1 date1) (nth 1 date2))))) - - -; we use an obarray for hash-consing the strings within each tree - -(defun caml-types-make-hash-table () - (make-vector 255 0)) - -(defun caml-types-hcons (elem table) - (symbol-name (intern elem table))) - - -; tree of intervals -; each node is a vector -; [ pos-left pos-right type-info child child child... ] -; type-info = -; () if this node does not correspond to an annotated interval -; (type-start . type-end) address of the annotation in the .annot file - -(defun caml-types-build-tree (target-file) - (let ((stack ()) - (accu ()) - (table (caml-types-make-hash-table)) - (type-info ())) - (while (re-search-forward caml-types-location-re () t) - (let ((l-file (file-name-nondirectory (match-string 1))) - (l-line (string-to-int (match-string 3))) - (l-bol (string-to-int (match-string 4))) - (l-cnum (string-to-int (match-string 5))) - (r-file (file-name-nondirectory (match-string 6))) - (r-line (string-to-int (match-string 8))) - (r-bol (string-to-int (match-string 9))) - (r-cnum (string-to-int (match-string 10)))) - (unless (caml-types-not-in-file l-file r-file target-file) - (while (and (re-search-forward "^" () t) - (not (looking-at "type")) - (not (looking-at "\\\""))) - (forward-char 1)) - (setq type-info - (if (looking-at - "^type(\n\\( \\([^\n)]\\|.)\\|\n[^)]\\)*\\)\n)") - (caml-types-hcons (match-string 1) table))) - (setq accu ()) - (while (and stack - (caml-types-pos-contains l-cnum r-cnum (car stack))) - (setq accu (cons (car stack) accu)) - (setq stack (cdr stack))) - (let* ((left-pos (vector l-file l-line l-bol l-cnum)) - (right-pos (vector r-file r-line r-bol r-cnum)) - (node (caml-types-make-node left-pos right-pos type-info - accu))) - (setq stack (cons node stack)))))) - (if (null stack) - (error "no annotations found for this source file") - (let* ((left-pos (elt (car (last stack)) 0)) - (right-pos (elt (car stack) 1))) - (if (null (cdr stack)) - (car stack) - (caml-types-make-node left-pos right-pos () (nreverse stack))))))) - -(defun caml-types-not-in-file (l-file r-file target-file) - (or (and (not (string= l-file target-file)) - (not (string= l-file ""))) - (and (not (string= r-file target-file)) - (not (string= r-file ""))))) - -(defun caml-types-make-node (left-pos right-pos type-info children) - (let ((result (make-vector (+ 3 (length children)) ())) - (i 3)) - (aset result 0 left-pos) - (aset result 1 right-pos) - (aset result 2 type-info) - (while children - (aset result i (car children)) - (setq children (cdr children)) - (setq i (1+ i))) - result)) - -(defun caml-types-pos-contains (l-cnum r-cnum node) - (and (<= l-cnum (elt (elt node 0) 3)) - (>= r-cnum (elt (elt node 1) 3)))) - -(defun caml-types-find-location (targ-pos curr node) - (if (not (caml-types-pos-inside targ-pos node)) - curr - (if (elt node 2) - (setq curr node)) - (let ((i (caml-types-search node targ-pos))) - (if (and (> i 3) - (caml-types-pos-inside targ-pos (elt node (1- i)))) - (caml-types-find-location targ-pos curr (elt node (1- i))) - curr)))) - -; trouve le premier fils qui commence apres la position -; ou (length node) si tous commencent avant -(defun caml-types-search (node pos) - (let ((min 3) - (max (length node)) - med) - (while (< min max) - (setq med (/ (+ min max) 2)) - (if (caml-types-pos<= (elt (elt node med) 0) pos) - (setq min (1+ med)) - (setq max med))) - min)) - -(defun caml-types-pos-inside (pos node) - (let ((left-pos (elt node 0)) - (right-pos (elt node 1))) - (and (caml-types-pos<= left-pos pos) - (caml-types-pos> right-pos pos)))) - -(defun caml-types-find-interval (buf targ-pos node) - (let ((nleft (elt node 0)) - (nright (elt node 1)) - (left ()) - (right ()) - i) - (cond - ((not (caml-types-pos-inside targ-pos node)) - (if (not (caml-types-pos<= nleft targ-pos)) - (setq right nleft)) - (if (not (caml-types-pos> nright targ-pos)) - (setq left nright))) - (t - (setq left nleft - right nright) - (setq i (caml-types-search node targ-pos)) - (if (< i (length node)) - (setq right (elt (elt node i) 0))) - (if (> i 3) - (setq left (elt (elt node (1- i)) 1))))) - (cons (if left - (caml-types-get-pos buf left) - (with-current-buffer buf (point-min))) - (if right - (caml-types-get-pos buf right) - (with-current-buffer buf (point-max)))))) - - -;; Warning: these comparison functions are not symmetric. -;; The first argument determines the format: -;; when its file component is empty, only the cnum is compared. - -(defun caml-types-pos<= (pos1 pos2) - (let ((file1 (elt pos1 0)) - (line1 (elt pos1 1)) - (bol1 (elt pos1 2)) - (cnum1 (elt pos1 3)) - (file2 (elt pos2 0)) - (line2 (elt pos2 1)) - (bol2 (elt pos2 2)) - (cnum2 (elt pos2 3))) - (if (string= file1 "") - (<= cnum1 cnum2) - (and (string= file1 file2) - (or (< line1 line2) - (and (= line1 line2) - (<= (- cnum1 bol1) (- cnum2 bol2)))))))) - -(defun caml-types-pos> (pos1 pos2) - (let ((file1 (elt pos1 0)) - (line1 (elt pos1 1)) - (bol1 (elt pos1 2)) - (cnum1 (elt pos1 3)) - (file2 (elt pos2 0)) - (line2 (elt pos2 1)) - (bol2 (elt pos2 2)) - (cnum2 (elt pos2 3))) - (if (string= file1 "") - (> cnum1 cnum2) - (and (string= file1 file2) - (or (> line1 line2) - (and (= line1 line2) - (> (- cnum1 bol1) (- cnum2 bol2)))))))) - -(defun caml-types-get-pos (buf pos) - (save-excursion - (set-buffer buf) - (goto-line (elt pos 1)) - (forward-char (- (elt pos 3) (elt pos 2))) - (point))) - -; find-file-read-only-noselect seems to be missing from emacs... -(defun caml-types-find-file (name) - (let (buf) - (cond - ((setq buf (get-file-buffer name)) - (unless (verify-visited-file-modtime buf) - (if (buffer-modified-p buf) - (find-file-noselect name) - (with-current-buffer buf (revert-buffer t t))) - )) - ((and (file-readable-p name) - (setq buf (find-file-noselect name))) - (with-current-buffer buf (toggle-read-only 1)) - ) - (t - (error "No annotation file. You should compile with option \"-dtypes\".")) - ) - buf)) - -(defun caml-types-mouse-ignore (event) - (interactive "e") - nil) - -(defun caml-types-time () - (let ((time (current-time))) - (+ (* (mod (cadr time) 1000) 1000) - (/ (cadr (cdr time)) 1000)))) - -(defun caml-types-explore (event) - "Explore type annotations by mouse dragging. - -The expression under the mouse is highlighted and its type is displayed -in the minibuffer, until the move is released, much as `caml-types-show-type'. -The function uses two overlays. - - . One overlay delimits the largest region whose all subnodes - are well-typed. - . Another overlay delimits the current node under the mouse (whose type - annotation is beeing displayed). -" - (interactive "e") - (set-buffer (window-buffer (caml-event-window event))) - (let* ((target-buf (current-buffer)) - (target-file (file-name-nondirectory (buffer-file-name))) - (type-file (concat (file-name-sans-extension (buffer-file-name)) - ".annot")) - (target-line) (target-bol) - target-pos - Left Right limits cnum node mes type - region - (window (caml-event-window event)) - target-tree - (speed 100) - (last-time (caml-types-time)) - (original-event event) - ) - (select-window window) - (unwind-protect - (progn - (caml-types-preprocess type-file) - (setq target-tree caml-types-annotation-tree) - (unless caml-types-buffer - (setq caml-types-buffer - (get-buffer-create caml-types-buffer-name))) - ;; (message "Drag the mouse to explore types") - (unwind-protect - (caml-track-mouse - (while event - (cond - ;; we ignore non mouse events - ((caml-ignore-event-p event)) - ;; we stop when the original button is released - ((caml-release-event-p original-event event) - (setq event nil)) - ;; we scroll when the motion is outside the window - ((and (caml-mouse-movement-p event) - (not (and (equal window (caml-event-window event)) - (integer-or-marker-p - (caml-event-point-end event))))) - (let* ((win (caml-window-edges window)) - (top (nth 1 win)) - (bottom (- (nth 3 win) 1)) - mouse - time - ) - (while (and - (caml-sit-for 0 (/ 500 speed)) - (setq time (caml-types-time)) - (> (- time last-time) (/ 500 speed)) - (setq mouse (caml-mouse-vertical-position)) - (or (< mouse top) (>= mouse bottom)) - ) - (setq last-time time) - (cond - ((< mouse top) - (setq speed (- top mouse)) - (condition-case nil - (scroll-down 1) - (error (message "Beginning of buffer!")))) - ((>= mouse bottom) - (setq speed (+ 1 (- mouse bottom))) - (condition-case nil - (scroll-up 1) - (error (message "End of buffer!")))) - ) - (setq speed (* speed speed)) - ))) - ;; main action, when the motion is inside the window - ;; or on orginal button down event - ((or (caml-mouse-movement-p event) - (equal original-event event)) - (setq cnum (caml-event-point-end event)) - (if (and region - (<= (car region) cnum) (< cnum (cdr region))) - ;; mouse remains in outer region - nil - ;; otherwise, reset the outer region - (setq region - (caml-types-typed-make-overlay - target-buf (caml-event-point-start event)))) - (if - (and limits - (>= cnum (car limits)) (< cnum (cdr limits))) - ;; inner region is unchanged - nil - ;; recompute the inner region and type annotation - (setq target-bol - (save-excursion - (goto-char cnum) (caml-line-beginning-position)) - target-line (1+ (count-lines (point-min) - target-bol)) - target-pos - (vector target-file target-line target-bol cnum)) - (save-excursion - (setq node (caml-types-find-location - target-pos () target-tree)) - (set-buffer caml-types-buffer) - (erase-buffer) - (cond - (node - (setq Left - (caml-types-get-pos target-buf (elt node 0)) - Right - (caml-types-get-pos target-buf (elt node 1))) - (move-overlay - caml-types-expr-ovl Left Right target-buf) - (setq limits - (caml-types-find-interval target-buf - target-pos node) - type (elt node 2)) - ) - (t - (delete-overlay caml-types-expr-ovl) - (setq type "*no type information*") - (setq limits - (caml-types-find-interval - target-buf target-pos target-tree)) - )) - (setq mes (format "type: %s" type)) - (insert type) - )) - (message mes) - ) - ) - ;; we read next event, unless it is nil, and loop back. - (if event (setq event (caml-read-event))) - ) - ) - ;; delete overlays at end of exploration - (delete-overlay caml-types-expr-ovl) - (delete-overlay caml-types-typed-ovl) - )) - ;; When an error occurs, the mouse release event has not been read. - ;; We could wait for mouse release to prevent execution of - ;; a binding of mouse release, such as cut or paste. - ;; In most common cases, next event will be the mouse release. - ;; However, it could also be a key stroke before mouse release. - ;; Emacs does not allow to test whether mouse is up or down. - ;; Not sure it is robust to loop for mouse release after an error - ;; occured, as is done for exploration. - ;; So far, we just ignore next event. (Next line also be uncommenting.) - (if event (caml-read-event)) - ))) - -(defun caml-types-typed-make-overlay (target-buf pos) - (interactive "p") - (let ((start pos) (end pos) len node left right) - (setq len (length caml-types-annotation-tree)) - (while (> len 3) - (setq len (- len 1)) - (setq node (aref caml-types-annotation-tree len)) - (if (and (equal target-buf (current-buffer)) - (setq left (caml-types-get-pos target-buf (elt node 0)) - right (caml-types-get-pos target-buf (elt node 1))) - (<= left pos) (> right pos) - ) - (setq start (min start left) - end (max end right)) - )) - (move-overlay caml-types-typed-ovl - (max (point-min) (- start 1)) - (min (point-max) (+ end 1)) target-buf) - (cons start end))) - -(provide 'caml-types) diff --git a/emacs/caml-xemacs.el b/emacs/caml-xemacs.el deleted file mode 100644 index ff49391576..0000000000 --- a/emacs/caml-xemacs.el +++ /dev/null @@ -1,39 +0,0 @@ -(require 'overlay) - -;; for caml-help.el -(defun caml-info-other-window (arg) - (save-excursion (info arg)) - (view-buffer-other-window "*info*")) - -;; for caml-types.el -(defun caml-line-beginning-position () - (save-excursion (beginning-of-line) (point))) - -(defalias 'caml-read-event 'next-event) -(defalias 'caml-window-edges 'window-pixel-edges) -(defun caml-mouse-vertical-position () - (let ((e (mouse-position-as-motion-event))) - (and e (event-y-pixel e)))) -(defalias 'caml-mouse-movement-p 'motion-event-p) -(defun caml-event-window (e) - (and (mouse-event-p e) (event-window e))) -(defun caml-event-point-start (e) (event-closest-point e)) -(defun caml-event-point-end (e) (event-closest-point e)) -(defun caml-ignore-event-p (e) - (if (and (key-press-event-p e) (equal (key-binding e) 'keyboard-quit)) - (keyboard-quit)) - (not (mouse-event-p e))) - - -(defun caml-sit-for (sec &optional mili) - (sit-for (+ sec (if mili (* 0.001 mili))))) - - - -(defmacro caml-track-mouse (&rest body) (cons 'progn body)) - -(defun caml-release-event-p (original event) - (and (button-release-event-p event) - (equal (event-button original) (event-button event)))) - -(provide 'caml-xemacs) diff --git a/emacs/caml.el b/emacs/caml.el deleted file mode 100644 index 8e6da6a251..0000000000 --- a/emacs/caml.el +++ /dev/null @@ -1,1894 +0,0 @@ -;;; caml.el --- O'Caml code editing commands for Emacs - -;; Xavier Leroy, july 1993. - -;;indentation code is Copyright (C) 1996 by Ian T Zimmerman -;;copying: covered by the current FSF General Public License. - -;; indentation code adapted for Objective Caml by Jacques Garrigue, -;; july 1997. - -;;user customizable variables -(defvar caml-quote-char "'" - "*Quote for character constants. \"'\" for Objective Caml, \"`\" for Caml-Light.") - -(defvar caml-imenu-enable nil - "*Enable Imenu support.") - -(defvar caml-mode-indentation 2 - "*Used for \\[caml-unindent-command].") - -(defvar caml-lookback-limit 5000 - "*How far to look back for syntax things in caml mode.") - -(defvar caml-max-indent-priority 8 - "*Bounds priority of operators permitted to affect caml indentation. - -Priorities are assigned to `interesting' caml operators as follows: - - all keywords 0 to 7 8 - type, val, ... + 0 7 - :: ^ 6 - @ 5 - := <- 4 - if 3 - fun, let, match ... 2 - module 1 - opening keywords 0.") - -(defvar caml-apply-extra-indent 2 - "*How many spaces to add to indentation for an application in caml mode.") -(make-variable-buffer-local 'caml-apply-extra-indent) - -(defvar caml-begin-indent 2 - "*How many spaces to indent from a begin keyword in caml mode.") -(make-variable-buffer-local 'caml-begin-indent) - -(defvar caml-class-indent 2 - "*How many spaces to indent from a class keyword in caml mode.") -(make-variable-buffer-local 'caml-class-indent) - -(defvar caml-exception-indent 2 - "*How many spaces to indent from a exception keyword in caml mode.") -(make-variable-buffer-local 'caml-exception-indent) - -(defvar caml-for-indent 2 - "*How many spaces to indent from a for keyword in caml mode.") -(make-variable-buffer-local 'caml-for-indent) - -(defvar caml-fun-indent 2 - "*How many spaces to indent from a fun keyword in caml mode.") -(make-variable-buffer-local 'caml-fun-indent) - -(defvar caml-function-indent 4 - "*How many spaces to indent from a function keyword in caml mode.") -(make-variable-buffer-local 'caml-function-indent) - -(defvar caml-if-indent 2 - "*How many spaces to indent from a if keyword in caml mode.") -(make-variable-buffer-local 'caml-if-indent) - -(defvar caml-if-else-indent 0 - "*How many spaces to indent from an if .. else line in caml mode.") -(make-variable-buffer-local 'caml-if-else-indent) - -(defvar caml-inherit-indent 2 - "*How many spaces to indent from a inherit keyword in caml mode.") -(make-variable-buffer-local 'caml-inherit-indent) - -(defvar caml-initializer-indent 2 - "*How many spaces to indent from a initializer keyword in caml mode.") -(make-variable-buffer-local 'caml-initializer-indent) - -(defvar caml-include-indent 2 - "*How many spaces to indent from a include keyword in caml mode.") -(make-variable-buffer-local 'caml-include-indent) - -(defvar caml-let-indent 2 - "*How many spaces to indent from a let keyword in caml mode.") -(make-variable-buffer-local 'caml-let-indent) - -(defvar caml-let-in-indent 0 - "*How many spaces to indent from a let .. in keyword in caml mode.") -(make-variable-buffer-local 'caml-let-in-indent) - -(defvar caml-match-indent 2 - "*How many spaces to indent from a match keyword in caml mode.") -(make-variable-buffer-local 'caml-match-indent) - -(defvar caml-method-indent 2 - "*How many spaces to indent from a method keyword in caml mode.") -(make-variable-buffer-local 'caml-method-indent) - -(defvar caml-module-indent 2 - "*How many spaces to indent from a module keyword in caml mode.") -(make-variable-buffer-local 'caml-module-indent) - -(defvar caml-object-indent 2 - "*How many spaces to indent from a object keyword in caml mode.") -(make-variable-buffer-local 'caml-object-indent) - -(defvar caml-of-indent 2 - "*How many spaces to indent from a of keyword in caml mode.") -(make-variable-buffer-local 'caml-of-indent) - -(defvar caml-parser-indent 4 - "*How many spaces to indent from a parser keyword in caml mode.") -(make-variable-buffer-local 'caml-parser-indent) - -(defvar caml-sig-indent 2 - "*How many spaces to indent from a sig keyword in caml mode.") -(make-variable-buffer-local 'caml-sig-indent) - -(defvar caml-struct-indent 2 - "*How many spaces to indent from a struct keyword in caml mode.") -(make-variable-buffer-local 'caml-struct-indent) - -(defvar caml-try-indent 2 - "*How many spaces to indent from a try keyword in caml mode.") -(make-variable-buffer-local 'caml-try-indent) - -(defvar caml-type-indent 4 - "*How many spaces to indent from a type keyword in caml mode.") -(make-variable-buffer-local 'caml-type-indent) - -(defvar caml-val-indent 2 - "*How many spaces to indent from a val keyword in caml mode.") -(make-variable-buffer-local 'caml-val-indent) - -(defvar caml-while-indent 2 - "*How many spaces to indent from a while keyword in caml mode.") -(make-variable-buffer-local 'caml-while-indent) - -(defvar caml-::-indent 2 - "*How many spaces to indent from a :: operator in caml mode.") -(make-variable-buffer-local 'caml-::-indent) - -(defvar caml-@-indent 2 - "*How many spaces to indent from a @ operator in caml mode.") -(make-variable-buffer-local 'caml-@-indent) - -(defvar caml-:=-indent 2 - "*How many spaces to indent from a := operator in caml mode.") -(make-variable-buffer-local 'caml-:=-indent) - -(defvar caml-<--indent 2 - "*How many spaces to indent from a <- operator in caml mode.") -(make-variable-buffer-local 'caml-<--indent) - -(defvar caml-->-indent 2 - "*How many spaces to indent from a -> operator in caml mode.") -(make-variable-buffer-local 'caml-->-indent) - -(defvar caml-lb-indent 2 - "*How many spaces to indent from a \[ operator in caml mode.") -(make-variable-buffer-local 'caml-lb-indent) - -(defvar caml-lc-indent 2 - "*How many spaces to indent from a \{ operator in caml mode.") -(make-variable-buffer-local 'caml-lc-indent) - -(defvar caml-lp-indent 1 - "*How many spaces to indent from a \( operator in caml mode.") -(make-variable-buffer-local 'caml-lp-indent) - -(defvar caml-and-extra-indent nil - "*Extra indent for caml lines starting with the and keyword. -Usually negative. nil is align on master.") -(make-variable-buffer-local 'caml-and-extra-indent) - -(defvar caml-do-extra-indent nil - "*Extra indent for caml lines starting with the do keyword. -Usually negative. nil is align on master.") -(make-variable-buffer-local 'caml-do-extra-indent) - -(defvar caml-done-extra-indent nil - "*Extra indent for caml lines starting with the done keyword. -Usually negative. nil is align on master.") -(make-variable-buffer-local 'caml-done-extra-indent) - -(defvar caml-else-extra-indent nil - "*Extra indent for caml lines starting with the else keyword. -Usually negative. nil is align on master.") -(make-variable-buffer-local 'caml-else-extra-indent) - -(defvar caml-end-extra-indent nil - "*Extra indent for caml lines starting with the end keyword. -Usually negative. nil is align on master.") -(make-variable-buffer-local 'caml-end-extra-indent) - -(defvar caml-in-extra-indent nil - "*Extra indent for caml lines starting with the in keyword. -Usually negative. nil is align on master.") -(make-variable-buffer-local 'caml-in-extra-indent) - -(defvar caml-then-extra-indent nil - "*Extra indent for caml lines starting with the then keyword. -Usually negative. nil is align on master.") -(make-variable-buffer-local 'caml-then-extra-indent) - -(defvar caml-to-extra-indent -1 - "*Extra indent for caml lines starting with the to keyword. -Usually negative. nil is align on master.") -(make-variable-buffer-local 'caml-to-extra-indent) - -(defvar caml-with-extra-indent nil - "*Extra indent for caml lines starting with the with keyword. -Usually negative. nil is align on master.") -(make-variable-buffer-local 'caml-with-extra-indent) - -(defvar caml-comment-indent 3 - "*Indent inside comments.") -(make-variable-buffer-local 'caml-comment-indent) - -(defvar caml-|-extra-indent -2 - "*Extra indent for caml lines starting with the | operator. -Usually negative. nil is align on master.") -(make-variable-buffer-local 'caml-|-extra-indent) - -(defvar caml-rb-extra-indent -2 - "*Extra indent for caml lines statring with ]. -Usually negative. nil is align on master.") - -(defvar caml-rc-extra-indent -2 - "*Extra indent for caml lines starting with }. -Usually negative. nil is align on master.") - -(defvar caml-rp-extra-indent -1 - "*Extra indent for caml lines starting with ). -Usually negative. nil is align on master.") - -(defvar caml-electric-indent t - "*Non-nil means electrically indent lines starting with |, ] or }. - -Many people find eletric keys irritating, so you can disable them if -you are one.") - -(defvar caml-electric-close-vector t - "*Non-nil means electrically insert a | before a vector-closing ]. - -Many people find eletric keys irritating, so you can disable them if -you are one. You should probably have this on, though, if you also -have caml-electric-indent on, which see.") - -;;code -(if (or (not (fboundp 'indent-line-to)) - (not (fboundp 'buffer-substring-no-properties))) - (require 'caml-compat)) - -(defvar caml-shell-active nil - "Non nil when a subshell is running.") - -(defvar running-xemacs (string-match "XEmacs" emacs-version) - "Non-nil if we are running in the XEmacs environment.") - -(defvar caml-mode-map nil - "Keymap used in Caml mode.") -(if caml-mode-map - () - (setq caml-mode-map (make-sparse-keymap)) - (define-key caml-mode-map "|" 'caml-electric-pipe) - (define-key caml-mode-map "}" 'caml-electric-pipe) - (define-key caml-mode-map "]" 'caml-electric-rb) - (define-key caml-mode-map "\t" 'caml-indent-command) - (define-key caml-mode-map [backtab] 'caml-unindent-command) - -;itz 04-21-96 instead of defining a new function, use defadvice -;that way we get out effect even when we do \C-x` in compilation buffer -; (define-key caml-mode-map "\C-x`" 'caml-next-error) - - (if running-xemacs - (define-key caml-mode-map 'backspace 'backward-delete-char-untabify) - (define-key caml-mode-map "\177" 'backward-delete-char-untabify)) - - ;; caml-types - (define-key caml-mode-map [?\C-c?\C-t] 'caml-types-show-type) - ;; must be a mouse-down event. Can be any button and any prefix - (define-key caml-mode-map [?\C-c down-mouse-1] 'caml-types-explore) - ;; caml-help - (define-key caml-mode-map [?\C-c?i] 'ocaml-add-path) - (define-key caml-mode-map [?\C-c?]] 'ocaml-close-module) - (define-key caml-mode-map [?\C-c?[] 'ocaml-open-module) - (define-key caml-mode-map [?\C-c?\C-h] 'caml-help) - (define-key caml-mode-map [?\C-c?\t] 'caml-complete) - ;; others - (define-key caml-mode-map "\C-cb" 'caml-insert-begin-form) - (define-key caml-mode-map "\C-cf" 'caml-insert-for-form) - (define-key caml-mode-map "\C-ci" 'caml-insert-if-form) - (define-key caml-mode-map "\C-cl" 'caml-insert-let-form) - (define-key caml-mode-map "\C-cm" 'caml-insert-match-form) - (define-key caml-mode-map "\C-ct" 'caml-insert-try-form) - (define-key caml-mode-map "\C-cw" 'caml-insert-while-form) - (define-key caml-mode-map "\C-c`" 'caml-goto-phrase-error) - (define-key caml-mode-map "\C-c\C-a" 'caml-find-alternate-file) - (define-key caml-mode-map "\C-c\C-c" 'compile) - (define-key caml-mode-map "\C-c\C-e" 'caml-eval-phrase) - (define-key caml-mode-map "\C-c\C-\[" 'caml-backward-to-less-indent) - (define-key caml-mode-map "\C-c\C-\]" 'caml-forward-to-less-indent) - (define-key caml-mode-map "\C-c\C-q" 'caml-indent-phrase) - (define-key caml-mode-map "\C-c\C-r" 'caml-eval-region) - (define-key caml-mode-map "\C-c\C-s" 'caml-show-subshell) - (define-key caml-mode-map "\M-\C-h" 'caml-mark-phrase) - (define-key caml-mode-map "\M-\C-q" 'caml-indent-phrase) - (define-key caml-mode-map "\M-\C-x" 'caml-eval-phrase) - - (if running-xemacs nil ; if not running xemacs - (let ((map (make-sparse-keymap "Caml")) - (forms (make-sparse-keymap "Forms"))) - (define-key caml-mode-map "\C-c\C-d" 'caml-show-imenu) - (define-key caml-mode-map [menu-bar] (make-sparse-keymap)) - (define-key caml-mode-map [menu-bar caml] (cons "Caml" map)) - ;; caml-help - - (define-key map [open] '("Open add path" . ocaml-add-path )) - (define-key map [close] - '("Close module for help" . ocaml-close-module)) - (define-key map [open] '("Open module for help" . ocaml-open-module)) - (define-key map [help] '("Help for identifier" . caml-help)) - (define-key map [complete] '("Complete identifier" . caml-complete)) - (define-key map [separator-help] '("---")) - - ;; caml-types - (define-key map [show-type] - '("Show type at point" . caml-types-show-type )) - (define-key map [separator-types] '("---")) - - ;; others - (define-key map [run-caml] '("Start subshell..." . run-caml)) - (define-key map [compile] '("Compile..." . compile)) - (define-key map [switch-view] - '("Switch view" . caml-find-alternate-file)) - (define-key map [separator-format] '("--")) - (define-key map [forms] (cons "Forms" forms)) - (define-key map [show-imenu] '("Show index" . caml-show-imenu)) - (put 'caml-show-imenu 'menu-enable '(not caml-imenu-shown)) - (define-key map [show-subshell] '("Show subshell" . caml-show-subshell)) - (put 'caml-show-subshell 'menu-enable 'caml-shell-active) - (define-key map [eval-phrase] '("Eval phrase" . caml-eval-phrase)) - (put 'caml-eval-phrase 'menu-enable 'caml-shell-active) - (define-key map [indent-phrase] '("Indent phrase" . caml-indent-phrase)) - (define-key forms [while] - '("while .. do .. done" . caml-insert-while-form)) - (define-key forms [try] '("try .. with .." . caml-insert-try-form)) - (define-key forms [match] '("match .. with .." . caml-insert-match-form)) - (define-key forms [let] '("let .. in .." . caml-insert-let-form)) - (define-key forms [if] '("if .. then .. else .." . caml-insert-if-form)) - (define-key forms [begin] '("for .. do .. done" . caml-insert-for-form)) - (define-key forms [begin] '("begin .. end" . caml-insert-begin-form))))) - -(defvar caml-mode-xemacs-menu - (if running-xemacs - '("Caml" - [ "Indent phrase" caml-indent-phrase :keys "C-M-q" ] - [ "Eval phrase" caml-eval-phrase - :active caml-shell-active :keys "C-M-x" ] - [ "Show subshell" caml-show-subshell caml-shell-active ] - ("Forms" - [ "while .. do .. done" caml-insert-while-form t] - [ "try .. with .." caml-insert-try-form t ] - [ "match .. with .." caml-insert-match-form t ] - [ "let .. in .." caml-insert-let-form t ] - [ "if .. then .. else .." caml-insert-if-form t ] - [ "for .. do .. done" caml-insert-for-form t ] - [ "begin .. end" caml-insert-begin-form t ]) - "---" - [ "Switch view" caml-find-alternate-file t ] - [ "Compile..." compile t ] - [ "Start subshell..." run-caml t ] - "---" - [ "Show type at point" caml-types-show-type t ] - "---" - [ "Complete identifier" caml-complete t ] - [ "Help for identifier" caml-help t ] - [ "Add path for documentation" ocaml-add-path t ] - [ "Open module for documentation" ocaml-open t ] - [ "Close module for documentation" ocaml-close t ] - )) - "Menu to add to the menubar when running Xemacs") - -(defvar caml-mode-syntax-table nil - "Syntax table in use in Caml mode buffers.") -(if caml-mode-syntax-table - () - (setq caml-mode-syntax-table (make-syntax-table)) - ; backslash is an escape sequence - (modify-syntax-entry ?\\ "\\" caml-mode-syntax-table) - ; ( is first character of comment start - (modify-syntax-entry ?\( "()1" caml-mode-syntax-table) - ; * is second character of comment start, - ; and first character of comment end - (modify-syntax-entry ?* ". 23" caml-mode-syntax-table) - ; ) is last character of comment end - (modify-syntax-entry ?\) ")(4" caml-mode-syntax-table) - ; backquote was a string-like delimiter (for character literals) - ; (modify-syntax-entry ?` "\"" caml-mode-syntax-table) - ; quote and underscore are part of words - (modify-syntax-entry ?' "w" caml-mode-syntax-table) - (modify-syntax-entry ?_ "w" caml-mode-syntax-table) - ; ISO-latin accented letters and EUC kanjis are part of words - (let ((i 160)) - (while (< i 256) - (modify-syntax-entry i "w" caml-mode-syntax-table) - (setq i (1+ i))))) - -(defvar caml-mode-abbrev-table nil - "Abbrev table used for Caml mode buffers.") -(if caml-mode-abbrev-table nil - (setq caml-mode-abbrev-table (make-abbrev-table)) - (define-abbrev caml-mode-abbrev-table "and" "and" 'caml-abbrev-hook) - (define-abbrev caml-mode-abbrev-table "do" "do" 'caml-abbrev-hook) - (define-abbrev caml-mode-abbrev-table "done" "done" 'caml-abbrev-hook) - (define-abbrev caml-mode-abbrev-table "else" "else" 'caml-abbrev-hook) - (define-abbrev caml-mode-abbrev-table "end" "end" 'caml-abbrev-hook) - (define-abbrev caml-mode-abbrev-table "in" "in" 'caml-abbrev-hook) - (define-abbrev caml-mode-abbrev-table "then" "then" 'caml-abbrev-hook) - (define-abbrev caml-mode-abbrev-table "with" "with" 'caml-abbrev-hook)) - -;; Other internal variables - -(defvar caml-last-noncomment-pos nil - "Caches last buffer position determined not inside a caml comment.") -(make-variable-buffer-local 'caml-last-noncomment-pos) - -;;last-noncomment-pos can be a simple position, because we nil it -;;anyway whenever buffer changes upstream. last-comment-start and -end -;;have to be markers, because we preserve them when the changes' end -;;doesn't overlap with the comment's start. - -(defvar caml-last-comment-start nil - "A marker caching last determined caml comment start.") -(make-variable-buffer-local 'caml-last-comment-start) - -(defvar caml-last-comment-end nil - "A marker caching last determined caml comment end.") -(make-variable-buffer-local 'caml-last-comment-end) - -(make-variable-buffer-local 'before-change-function) - -(defvar caml-imenu-shown nil - "True if we have computed definition list.") -(make-variable-buffer-local 'caml-imenu-shown) - -(defconst caml-imenu-search-regexp - (concat "\\\\|" - "^[ \t]*\\(let\\|class\\|type\\|m\\(odule\\|ethod\\)" - "\\|functor\\|and\\|val\\)[ \t]+" - "\\(\\('[a-zA-Z0-9]+\\|([^)]+)" - "\\|mutable\\|private\\|rec\\|type\\)[ \t]+\\)?" - "\\([a-zA-Z][a-zA-Z0-9_']*\\)")) - -;;; The major mode -(eval-when-compile - (if (and (boundp 'running-xemacs) running-xemacs) nil - (require 'imenu))) - -;; -(defvar caml-mode-hook nil - "Hook for caml-mode") - -(defun caml-mode () - "Major mode for editing Caml code. - -\\{caml-mode-map}" - - (interactive) - (kill-all-local-variables) - (setq major-mode 'caml-mode) - (setq mode-name "caml") - (use-local-map caml-mode-map) - (set-syntax-table caml-mode-syntax-table) - (setq local-abbrev-table caml-mode-abbrev-table) - (make-local-variable 'paragraph-start) - (setq paragraph-start (concat "^$\\|" page-delimiter)) - (make-local-variable 'paragraph-separate) - (setq paragraph-separate paragraph-start) - (make-local-variable 'paragraph-ignore-fill-prefix) - (setq paragraph-ignore-fill-prefix t) - (make-local-variable 'require-final-newline) - (setq require-final-newline t) - (make-local-variable 'comment-start) - (setq comment-start "(*") - (make-local-variable 'comment-end) - (setq comment-end "*)") - (make-local-variable 'comment-column) - (setq comment-column 40) - (make-local-variable 'comment-start-skip) - (setq comment-start-skip "(\\*+ *") - (make-local-variable 'parse-sexp-ignore-comments) - (setq parse-sexp-ignore-comments nil) - (make-local-variable 'indent-line-function) - (setq indent-line-function 'caml-indent-command) - ;itz Fri Sep 25 13:23:49 PDT 1998 - (make-local-variable 'add-log-current-defun-function) - (setq add-log-current-defun-function 'caml-current-defun) - ;itz 03-25-96 - (setq before-change-function 'caml-before-change-function) - (setq caml-last-noncomment-pos nil) - (setq caml-last-comment-start (make-marker)) - (setq caml-last-comment-end (make-marker)) - ;garrigue 27-11-96 - (setq case-fold-search nil) - ;garrigue july 97 - (if running-xemacs ; from Xemacs lisp mode - (if (and (featurep 'menubar) - current-menubar) - (progn - ;; make a local copy of the menubar, so our modes don't - ;; change the global menubar - (set-buffer-menubar current-menubar) - (add-submenu nil caml-mode-xemacs-menu))) - ;imenu support (not for Xemacs) - (make-local-variable 'imenu-create-index-function) - (setq imenu-create-index-function 'caml-create-index-function) - (make-local-variable 'imenu-generic-expression) - (setq imenu-generic-expression caml-imenu-search-regexp) - (if (and caml-imenu-enable (< (buffer-size) 10000)) - (caml-show-imenu))) - (run-hooks 'caml-mode-hook)) - -(defun caml-set-compile-command () - "Hook to set compile-command locally, unless there is a Makefile in the - current directory." - (interactive) - (unless (or (null buffer-file-name) - (file-exists-p "makefile") - (file-exists-p "Makefile")) - (let* ((filename (file-name-nondirectory buffer-file-name)) - (basename (file-name-sans-extension filename)) - (command nil)) - (cond - ((string-match ".*\\.mli\$" filename) - (setq command "ocamlc -c")) - ((string-match ".*\\.ml\$" filename) - (setq command "ocamlc -c") ; (concat "ocamlc -o " basename) - ) - ((string-match ".*\\.mll\$" filename) - (setq command "ocamllex")) - ((string-match ".*\\.mll\$" filename) - (setq command "ocamlyacc")) - ) - (if command - (progn - (make-local-variable 'compile-command) - (setq compile-command (concat command " " filename)))) - ))) - -(add-hook 'caml-mode-hook 'caml-set-compile-command) - -;;; Auxiliary function. Garrigue 96-11-01. - -(defun caml-find-alternate-file () - (interactive) - (let ((name (buffer-file-name))) - (if (string-match "^\\(.*\\)\\.\\(ml\\|mli\\)$" name) - (find-file - (concat - (caml-match-string 1 name) - (if (string= "ml" (caml-match-string 2 name)) ".mli" ".ml")))))) - -;;; subshell support - -(defun caml-eval-region (start end) - "Send the current region to the inferior Caml process." - (interactive"r") - (require 'inf-caml) - (inferior-caml-eval-region start end)) - -;; old version ---to be deleted later -; -; (defun caml-eval-phrase () -; "Send the current Caml phrase to the inferior Caml process." -; (interactive) -; (save-excursion -; (let ((bounds (caml-mark-phrase))) -; (inferior-caml-eval-region (car bounds) (cdr bounds))))) - -(defun caml-eval-phrase (arg &optional min max) - "Send the phrase containing the point to the CAML process. -With prefix-arg send as many phrases as its numeric value, -If an error occurs during evalutaion, stop at this phrase and -repport the error. - -Return nil if noerror and position of error if any. - -If arg's numeric value is zero or negative, evaluate the current phrase -or as many as prefix arg, ignoring evaluation errors. -This allows to jump other erroneous phrases. - -Optional arguments min max defines a region within which the phrase -should lies." - (interactive "p") - (require 'inf-caml) - (inferior-caml-eval-phrase arg min max)) - -(defun caml-eval-buffer (arg) - "Evaluate the buffer from the beginning to the phrase under the point. -With prefix arg, evaluate past the whole buffer, no stopping at -the current point." - (interactive "p") - (let ((here (point)) err) - (goto-char (point-min)) - (setq err - (caml-eval-phrase 500 (point-min) (if arg (point-max) here))) - (if err (set-mark err)) - (goto-char here))) - -(defun caml-show-subshell () - (interactive) - (require 'inf-caml) - (inferior-caml-show-subshell)) - - -;;; Imenu support -(defun caml-show-imenu () - (interactive) - (require 'imenu) - (switch-to-buffer (current-buffer)) - (imenu-add-to-menubar "Defs") - (setq caml-imenu-shown t)) - -(defun caml-prev-index-position-function () - (let (found data) - (while (and (setq found - (re-search-backward caml-imenu-search-regexp nil 'move)) - (progn (setq data (match-data)) t) - (or (caml-in-literal-p) - (caml-in-comment-p) - (if (looking-at "in") (caml-find-in-match))))) - (set-match-data data) - found)) -(defun caml-create-index-function () - (let (value-alist - type-alist - class-alist - method-alist - module-alist - and-alist - all-alist - menu-alist - (prev-pos (point-max)) - index) - (goto-char prev-pos) - (imenu-progress-message prev-pos 0 t) - ;; collect definitions - (while (caml-prev-index-position-function) - (setq index (cons (caml-match-string 5) (point))) - (imenu-progress-message prev-pos nil t) - (setq all-alist (cons index all-alist)) - (cond - ((looking-at "[ \t]*and") - (setq and-alist (cons index and-alist))) - ((looking-at "[ \t]*let") - (setq value-alist (cons index (append and-alist value-alist))) - (setq and-alist nil)) - ((looking-at "[ \t]*type") - (setq type-alist (cons index (append and-alist type-alist))) - (setq and-alist nil)) - ((looking-at "[ \t]*class") - (setq class-alist (cons index (append and-alist class-alist))) - (setq and-alist nil)) - ((looking-at "[ \t]*val") - (setq value-alist (cons index value-alist))) - ((looking-at "[ \t]*\\(module\\|functor\\)") - (setq module-alist (cons index module-alist))) - ((looking-at "[ \t]*method") - (setq method-alist (cons index method-alist))))) - ;; build menu - (mapcar - '(lambda (pair) - (if (symbol-value (cdr pair)) - (setq menu-alist - (cons - (cons (car pair) - (sort (symbol-value (cdr pair)) 'imenu--sort-by-name)) - menu-alist)))) - '(("Values" . value-alist) - ("Types" . type-alist) - ("Modules" . module-alist) - ("Methods" . method-alist) - ("Classes" . class-alist))) - (if all-alist (setq menu-alist (cons (cons "Index" all-alist) menu-alist))) - (imenu-progress-message prev-pos 100 t) - menu-alist)) - -;;; Indentation stuff - -(defun caml-in-indentation () - "Tests whether all characters between beginning of line and point -are blanks." - (save-excursion - (skip-chars-backward " \t") - (bolp))) - -;;; The command -;;; Sorry, I didn't like the previous behaviour... Garrigue 96/11/01 - -(defun caml-indent-command (&optional p) - "Indent the current line in Caml mode. - -Compute new indentation based on caml syntax. If prefixed, indent -the line all the way to where point is." - - (interactive "*p") - (cond - ((and p (> p 1)) (indent-line-to (current-column))) - ((caml-in-indentation) (indent-line-to (caml-compute-final-indent))) - (t (save-excursion - (indent-line-to - (caml-compute-final-indent)))))) - -(defun caml-unindent-command () - - "Decrease indentation by one level in Caml mode. - -Works only if the point is at the beginning of an indented line -\(i.e. all characters between beginning of line and point are -blanks\). Does nothing otherwise. The unindent size is given by the -variable caml-mode-indentation." - - (interactive "*") - (let* ((begline - (save-excursion - (beginning-of-line) - (point))) - (current-offset - (- (point) begline))) - (if (and (>= current-offset caml-mode-indentation) - (caml-in-indentation)) - (backward-delete-char-untabify caml-mode-indentation)))) - -;;; -;;; Error processing -;;; - -;; Error positions are given in bytes, not in characters -;; This function switches to monobyte mode - -(if (not (fboundp 'char-bytes)) - (defalias 'forward-byte 'forward-char) - (defun caml-char-bytes (ch) - (let ((l (char-bytes ch))) - (if (> l 1) (- l 1) l))) - (defun forward-byte (count) - (if (> count 0) - (while (> count 0) - (let ((char (char-after))) - (if (null char) - (setq count 0) - (setq count (- count (caml-char-bytes (char-after)))) - (forward-char)))) - (while (< count 0) - (let ((char (char-after))) - (if (null char) - (setq count 0) - (setq count (+ count (caml-char-bytes (char-before)))) - (backward-char)))) - ))) - -(require 'compile) - -;; In Emacs 19, the regexps in compilation-error-regexp-alist do not -;; match the error messages when the language is not English. -;; Hence we add a regexp. - -(defconst caml-error-regexp - "^[A-\377]+ \"\\([^\"\n]+\\)\", [A-\377]+ \\([0-9]+\\)[-,:]" - "Regular expression matching the error messages produced by camlc.") - -(if (boundp 'compilation-error-regexp-alist) - (or (assoc caml-error-regexp - compilation-error-regexp-alist) - (setq compilation-error-regexp-alist - (cons (list caml-error-regexp 1 2) - compilation-error-regexp-alist)))) - -;; A regexp to extract the range info - -(defconst caml-error-chars-regexp - ".*, .*, [A-\377]+ \\([0-9]+\\)-\\([0-9]+\\):" - "Regular expression extracting the character numbers -from an error message produced by camlc.") - -;; Wrapper around next-error. - -(defvar caml-error-overlay nil) - -;;itz 04-21-96 somebody didn't get the documetation for next-error -;;right. When the optional argument is a number n, it should move -;;forward n errors, not reparse. - -;itz 04-21-96 instead of defining a new function, use defadvice -;that way we get our effect even when we do \C-x` in compilation buffer - -(defadvice next-error (after caml-next-error activate) - "Reads the extra positional information provided by the Caml compiler. - -Puts the point and the mark exactly around the erroneous program -fragment. The erroneous fragment is also temporarily highlighted if -possible." - - (if (eq major-mode 'caml-mode) - (let (bol beg end) - (save-excursion - (set-buffer - (if (boundp 'compilation-last-buffer) - compilation-last-buffer ;Emacs 19 - "*compilation*")) ;Emacs 18 - (save-excursion - (goto-char (window-point (get-buffer-window (current-buffer)))) - (if (looking-at caml-error-chars-regexp) - (setq beg - (string-to-int - (buffer-substring (match-beginning 1) (match-end 1))) - end - (string-to-int - (buffer-substring (match-beginning 2) (match-end 2))))))) - (cond (beg - (setq end (- end beg)) - (beginning-of-line) - (forward-byte beg) - (setq beg (point)) - (forward-byte end) - (setq end (point)) - (goto-char beg) - (push-mark end t) - (cond ((fboundp 'make-overlay) - (if caml-error-overlay () - (setq caml-error-overlay (make-overlay 1 1)) - (overlay-put caml-error-overlay 'face 'region)) - (unwind-protect - (progn - (move-overlay caml-error-overlay - beg end (current-buffer)) - (sit-for 60)) - (delete-overlay caml-error-overlay))))))))) - -;; Usual match-string doesn't work properly with font-lock-mode -;; on some emacs. - -(defun caml-match-string (num &optional string) - - "Return string of text matched by last search, without properties. - -NUM specifies which parenthesized expression in the last regexp. -Value is nil if NUMth pair didn't match, or there were less than NUM -pairs. Zero means the entire text matched by the whole regexp or -whole string." - - (let* ((data (match-data)) - (begin (nth (* 2 num) data)) - (end (nth (1+ (* 2 num)) data))) - (if string (substring string begin end) - (buffer-substring-no-properties begin end)))) - -;; itz Thu Sep 24 19:02:42 PDT 1998 this is to have some level of -;; comfort when sending phrases to the toplevel and getting errors. -(defun caml-goto-phrase-error () - "Find the error location in current Caml phrase." - (interactive) - (require 'inf-caml) - (let ((bounds (save-excursion (caml-mark-phrase)))) - (inferior-caml-goto-error (car bounds) (cdr bounds)))) - -;;; Phrases - -;itz the heuristics used to see if we're `between two phrases' -;didn't seem right to me. - -(defconst caml-phrase-start-keywords - (concat "\\<\\(class\\|ex\\(ternal\\|ception\\)\\|functor" - "\\|let\\|module\\|open\\|type\\|val\\)\\>") - "Keywords starting phrases in files") - -;; a phrase starts when a toplevel keyword is at the beginning of a line -(defun caml-at-phrase-start-p () - (and (bolp) - (or (looking-at "#") - (looking-at caml-phrase-start-keywords)))) - -(defun caml-skip-comments-forward () - (skip-chars-forward " \n\t") - (while (or (looking-at comment-start-skip) (caml-in-comment-p)) - (if (= (following-char) ?\)) (forward-char) - (search-forward comment-end)) - (skip-chars-forward " \n\t"))) - -(defun caml-skip-comments-backward () - (skip-chars-backward " \n\t") - (while (and (eq (preceding-char) ?\)) (eq (char-after (- (point) 2)) ?*)) - (backward-char) - (while (caml-in-comment-p) (search-backward comment-start)) - (skip-chars-backward " \n\t"))) - -(defconst caml-phrase-sep-keywords (concat ";;\\|" caml-phrase-start-keywords)) - -(defun caml-find-phrase (&optional min-pos max-pos) - "Find the CAML phrase containing the point. -Return the position of the beginning of the phrase, and move point -to the end. -" - (interactive) - (if (not min-pos) (setq min-pos (point-min))) - (if (not max-pos) (setq max-pos (point-max))) - (let (beg end use-semi kwop) - ;(caml-skip-comments-backward) - (cond - ; shall we have special processing for semicolons? - ;((and (eq (char-before (- (point) 1)) ?\;) (eq (char-before) ?\;)) - ; (forward-char) - ; (caml-skip-comments-forward) - ; (setq beg (point)) - ; (while (and (search-forward ";;" max-pos 'move) - ; (or (caml-in-comment-p) (caml-in-literal-p))))) - (t - (caml-skip-comments-forward) - (if (caml-at-phrase-start-p) (forward-char)) - (while (and (cond - ((re-search-forward caml-phrase-sep-keywords max-pos 'move) - (goto-char (match-beginning 0)) t)) - (or (not (or (bolp) (looking-at ";;"))) - (caml-in-comment-p) - (caml-in-literal-p))) - (forward-char)) - (setq end (+ (point) (if (looking-at ";;") 2 0))) - (while (and - (setq kwop (caml-find-kwop caml-phrase-sep-keywords min-pos)) - (not (string= kwop ";;")) - (not (bolp)))) - (if (string= kwop ";;") (forward-char 2)) - (if (not kwop) (goto-char min-pos)) - (caml-skip-comments-forward) - (setq beg (point)) - (if (>= beg end) (error "no phrase before point")) - (goto-char end))) - (caml-skip-comments-forward) - beg)) - -(defun caml-mark-phrase (&optional min-pos max-pos) - "Put mark at end of this Caml phrase, point at beginning. -" - (interactive) - (let* ((beg (caml-find-phrase min-pos max-pos)) (end (point))) - (push-mark) - (goto-char beg) - (cons beg end))) - -;;itz Fri Sep 25 12:58:13 PDT 1998 support for adding change-log entries -(defun caml-current-defun () - (save-excursion - (caml-mark-phrase) - (if (not (looking-at caml-phrase-start-keywords)) nil - (re-search-forward caml-phrase-start-keywords) - (let ((done nil)) - (while (not done) - (cond - ((looking-at "\\s ") - (skip-syntax-forward " ")) - ((char-equal (following-char) ?\( ) - (forward-sexp 1)) - ((char-equal (following-char) ?') - (skip-syntax-forward "w_")) - (t (setq done t))))) - (re-search-forward "\\(\\sw\\|\\s_\\)+") - (match-string 0)))) - -(defun caml-overlap (b1 e1 b2 e2) - (<= (max b1 b2) (min e1 e2))) - -;this clears the last comment cache if necessary -(defun caml-before-change-function (begin end) - (if (and caml-last-noncomment-pos - (> caml-last-noncomment-pos begin)) - (setq caml-last-noncomment-pos nil)) - (if (and (marker-position caml-last-comment-start) - (marker-position caml-last-comment-end) - (caml-overlap begin end - caml-last-comment-start - caml-last-comment-end)) - (prog2 - (set-marker caml-last-comment-start nil) - (set-marker caml-last-comment-end nil))) - (let ((orig-function (default-value 'before-change-function))) - (if orig-function (funcall orig-function begin end)))) - -(defun caml-in-literal-p () - "Returns non-nil if point is inside a caml literal." - (let* ((start-literal (concat "[\"" caml-quote-char "]")) - (char-literal - (concat "\\([^\\]\\|\\\\\\.\\|\\\\[0-9][0-9][0-9]\\)" - caml-quote-char)) - (pos (point)) - (eol (progn (end-of-line 1) (point))) - state in-str) - (beginning-of-line 1) - (while (and (not state) - (re-search-forward start-literal eol t) - (<= (point) pos)) - (cond - ((string= (caml-match-string 0) "\"") - (setq in-str t) - (while (and in-str (not state) - (re-search-forward "\"\\|\\\\\"" eol t)) - (if (> (point) pos) (setq state t)) - (if (string= (caml-match-string 0) "\"") (setq in-str nil))) - (if in-str (setq state t))) - ((looking-at char-literal) - (if (and (>= pos (match-beginning 0)) (< pos (match-end 0))) - (setq state t) - (goto-char (match-end 0)))))) - (goto-char pos) - state)) - -(defun caml-forward-comment () - "Skip one (eventually nested) comment." - (let ((count 1) match) - (while (> count 0) - (if (not (re-search-forward "(\\*\\|\\*)" nil 'move)) - (setq count -1) - (setq match (caml-match-string 0)) - (cond - ((caml-in-literal-p) - nil) - ((string= match comment-start) - (setq count (1+ count))) - (t - (setq count (1- count)))))) - (= count 0))) - -(defun caml-backward-comment () - "Skip one (eventually nested) comment." - (let ((count 1) match) - (while (> count 0) - (if (not (re-search-backward "(\\*\\|\\*)" nil 'move)) - (setq count -1) - (setq match (caml-match-string 0)) - (cond - ((caml-in-literal-p) - nil) - ((string= match comment-start) - (setq count (1- count))) - (t - (setq count (1+ count)))))) - (= count 0))) - -(defun caml-in-comment-p () - "Returns non-nil if point is inside a caml comment. -Returns nil for the parenthesis openning a comment." - ;;we look for comments differently than literals. there are two - ;;reasons for this. first, caml has nested comments and it is not so - ;;clear that parse-partial-sexp supports them; second, if proper - ;;style is used, literals are never split across lines, so we don't - ;;have to worry about bogus phrase breaks inside literals, while we - ;;have to account for that possibility in comments. - (if caml-last-comment-start - (save-excursion - (let* ((cached-pos caml-last-noncomment-pos) - (cached-begin (marker-position caml-last-comment-start)) - (cached-end (marker-position caml-last-comment-end))) - (cond - ((and cached-begin cached-end - (< cached-begin (point)) (< (point) cached-end)) t) - ((and cached-pos (= cached-pos (point))) nil) - ((and cached-pos (> cached-pos (point)) - (< (abs (- cached-pos (point))) caml-lookback-limit)) - (let (end found (here (point))) - ; go back to somewhere sure - (goto-char cached-pos) - (while (> (point) here) - ; look for the end of a comment - (while (and (if (search-backward comment-end (1- here) 'move) - (setq end (match-end 0)) - (setq end nil)) - (caml-in-literal-p))) - (if end (setq found (caml-backward-comment)))) - (if (and found (= (point) here)) (setq end nil)) - (if (not end) - (setq caml-last-noncomment-pos here) - (set-marker caml-last-comment-start (point)) - (set-marker caml-last-comment-end end)) - end)) - (t - (let (begin found (here (point))) - ;; go back to somewhere sure (or far enough) - (goto-char - (if cached-pos cached-pos (- (point) caml-lookback-limit))) - (while (< (point) here) - ;; look for the beginning of a comment - (while (and (if (search-forward comment-start (1+ here) 'move) - (setq begin (match-beginning 0)) - (setq begin nil)) - (caml-in-literal-p))) - (if begin (setq found (caml-forward-comment)))) - (if (and found (= (point) here)) (setq begin nil)) - (if (not begin) - (setq caml-last-noncomment-pos here) - (set-marker caml-last-comment-start begin) - (set-marker caml-last-comment-end (point))) - begin))))))) - -;; Various constants and regexps - -(defconst caml-before-expr-prefix - (concat "\\<\\(asr\\|begin\\|class\\|do\\(wnto\\)?\\|else" - "\\|i\\(f\\|n\\(herit\\|itializer\\)?\\)" - "\\|f\\(or\\|un\\(ct\\(ion\\|or\\)\\)?\\)" - "\\|l\\(and\\|or\\|s[lr]\\|xor\\)\\|m\\(atch\\|od\\)" - "\\|o[fr]\\|parser\\|s\\(ig\\|truct\\)\\|t\\(hen\\|o\\|ry\\)" - "\\|w\\(h\\(en\\|ile\\)\\|ith\\)\\)\\>\\|:begin\\>" - "\\|[=<>@^|&+-*/$%][!$%*+-./:<=>?@^|~]*\\|:[:=]\\|[[({,;]") - - "Keywords that may appear immediately before an expression. -Used to distinguish it from toplevel let construct.") - -(defconst caml-matching-kw-regexp - (concat - "\\<\\(and\\|do\\(ne\\)?\\|e\\(lse\\|nd\\)\\|in\\|t\\(hen\\|o\\)" - "\\|with\\)\\>\\|[^[|]|") - "Regexp used in caml mode for skipping back over nested blocks.") - -(defconst caml-matching-kw-alist - '(("|" . caml-find-pipe-match) - (";" . caml-find-semi-match) - ("," . caml-find-comma-match) - ("end" . caml-find-end-match) - ("done" . caml-find-done-match) - ("in" . caml-find-in-match) - ("with" . caml-find-with-match) - ("else" . caml-find-else-match) - ("then" . caml-find-then-match) - ("to" . caml-find-done-match) - ("do" . caml-find-done-match) - ("and" . caml-find-and-match)) - - "Association list used in caml mode for skipping back over nested blocks.") - -(defconst caml-kwop-regexps (make-vector 9 nil) - "Array of regexps representing caml keywords of different priorities.") - -(defun caml-in-expr-p () - (let ((pos (point)) (in-expr t)) - (caml-find-kwop - (concat caml-before-expr-prefix "\\|" - caml-matching-kw-regexp "\\|" - (aref caml-kwop-regexps caml-max-indent-priority))) - (cond - ; special case for ;; - ((and (> (point) 1) (= (preceding-char) ?\;) (= (following-char) ?\;)) - (setq in-expr nil)) - ((looking-at caml-before-expr-prefix) - (if (not (looking-at "(\\*")) (goto-char (match-end 0))) - (skip-chars-forward " \t\n") - (while (looking-at "(\\*") - (forward-char) - (caml-forward-comment) - (skip-chars-forward " \t\n")) - (if (<= pos (point)) (setq in-expr nil)))) - (goto-char pos) - in-expr)) - -(defun caml-at-sexp-close-p () - (or (char-equal ?\) (following-char)) - (char-equal ?\] (following-char)) - (char-equal ?} (following-char)))) - -(defun caml-find-kwop (kwop-regexp &optional min-pos) - "Look back for a caml keyword or operator matching KWOP-REGEXP. -Second optional argument MIN-POS bounds the search. - -Ignore occurences inside literals. If found, return a list of two -values: the actual text of the keyword or operator, and a boolean -indicating whether the keyword was one we looked for explicitly -{non-nil}, or on the other hand one of the block-terminating -keywords." - - (let ((start-literal (concat "[\"" caml-quote-char "]")) - found kwop) - (while (and (> (point) 1) (not found) - (re-search-backward kwop-regexp min-pos 'move)) - (setq kwop (caml-match-string 0)) - (cond - ((looking-at "(\\*") - (if (> (point) 1) (backward-char))) - ((caml-in-comment-p) - (search-backward "(" min-pos 'move)) - ((looking-at start-literal)) - ((caml-in-literal-p) - (re-search-backward start-literal min-pos 'move)) ;ugly hack - ((setq found t)))) - (if found - (if (not (string-match "\\`[^|[]|[^]|]?\\'" kwop)) ;arrrrgh!! - kwop - (forward-char 1) "|") nil))) - -; Association list of indentation values based on governing keywords. -; -;Each element is of the form (KEYWORD OP-TYPE PRIO INDENT). OP-TYPE is -;non-nil for operator-type nodes, which affect indentation in a -;different way from keywords: subsequent lines are indented to the -;actual occurrence of an operator, but relative to the indentation of -;the line where the governing keyword occurs. - -(defconst caml-no-indent 0) - -(defconst caml-kwop-alist - '(("begin" nil 6 caml-begin-indent) - (":begin" nil 6 caml-begin-indent) ; hack - ("class" nil 0 caml-class-indent) - ("constraint" nil 0 caml-val-indent) - ("sig" nil 1 caml-sig-indent) - ("struct" nil 1 caml-struct-indent) - ("exception" nil 0 caml-exception-indent) - ("for" nil 6 caml-for-indent) - ("fun" nil 3 caml-fun-indent) - ("function" nil 3 caml-function-indent) - ("if" nil 6 caml-if-indent) - ("if-else" nil 6 caml-if-else-indent) - ("include" nil 0 caml-include-indent) - ("inherit" nil 0 caml-inherit-indent) - ("initializer" nil 0 caml-initializer-indent) - ("let" nil 6 caml-let-indent) - ("let-in" nil 6 caml-let-in-indent) - ("match" nil 6 caml-match-indent) - ("method" nil 0 caml-method-indent) - ("module" nil 0 caml-module-indent) - ("object" nil 6 caml-object-indent) - ("of" nil 7 caml-of-indent) - ("open" nil 0 caml-no-indent) - ("parser" nil 3 caml-parser-indent) - ("try" nil 6 caml-try-indent) - ("type" nil 0 caml-type-indent) - ("val" nil 0 caml-val-indent) - ("when" nil 2 caml-if-indent) - ("while" nil 6 caml-while-indent) - ("::" t 5 caml-::-indent) - ("@" t 4 caml-@-indent) - ("^" t 4 caml-@-indent) - (":=" nil 3 caml-:=-indent) - ("<-" nil 3 caml-<--indent) - ("->" nil 2 caml-->-indent) - ("\[" t 8 caml-lb-indent) - ("{" t 8 caml-lc-indent) - ("\(" t 8 caml-lp-indent) - ("|" nil 2 caml-no-indent) - (";;" nil 0 caml-no-indent)) -; if-else and let-in are not keywords but idioms -; "|" is not in the regexps -; all these 3 values correspond to hard-coded names - -"Association list of indentation values based on governing keywords. - -Each element is of the form (KEYWORD OP-TYPE PRIO INDENT). OP-TYPE is -non-nil for operator-type nodes, which affect indentation in a -different way from keywords: subsequent lines are indented to the -actual occurrence of an operator, but relative to the indentation of -the line where the governing keyword occurs.") - -;;Originally, we had caml-kwop-regexp create these at runtime, from an -;;additional field in caml-kwop-alist. That proved way too slow, -;;although I still can't understand why. itz - -(aset caml-kwop-regexps 0 - (concat - "\\<\\(begin\\|object\\|for\\|s\\(ig\\|truct\\)\\|while\\)\\>" - "\\|:begin\\>\\|[[({]\\|;;")) -(aset caml-kwop-regexps 1 - (concat (aref caml-kwop-regexps 0) "\\|\\<\\(class\\|module\\)\\>")) -(aset caml-kwop-regexps 2 - (concat - (aref caml-kwop-regexps 1) - "\\|\\<\\(fun\\(ction\\)?\\|initializer\\|let\\|m\\(atch\\|ethod\\)" - "\\|parser\\|try\\|val\\)\\>\\|->")) -(aset caml-kwop-regexps 3 - (concat (aref caml-kwop-regexps 2) "\\|\\")) -(aset caml-kwop-regexps 4 - (concat (aref caml-kwop-regexps 3) "\\|:=\\|<-")) -(aset caml-kwop-regexps 5 - (concat (aref caml-kwop-regexps 4) "\\|@")) -(aset caml-kwop-regexps 6 - (concat (aref caml-kwop-regexps 5) "\\|::\\|\\^")) -(aset caml-kwop-regexps 7 - (concat - (aref caml-kwop-regexps 0) - "\\|\\<\\(constraint\\|exception\\|in\\(herit\\|clude\\)" - "\\|o\\(f\\|pen\\)\\|type\\|val\\)\\>")) -(aset caml-kwop-regexps 8 - (concat (aref caml-kwop-regexps 6) - "\\|\\<\\(constraint\\|exception\\|in\\(herit\\|clude\\)" - "\\|o\\(f\\|pen\\)\\|type\\)\\>")) - -(defun caml-find-done-match () - (let ((unbalanced 1) (kwop t)) - (while (and (not (= 0 unbalanced)) kwop) - (setq kwop (caml-find-kwop "\\<\\(done\\|for\\|while\\)\\>")) - (cond - ((not kwop)) - ((string= kwop "done") (setq unbalanced (1+ unbalanced))) - (t (setq unbalanced (1- unbalanced))))) - kwop)) - -(defun caml-find-end-match () - (let ((unbalanced 1) (kwop t)) - (while (and (not (= 0 unbalanced)) kwop) - (setq kwop - (caml-find-kwop - "\\<\\(end\\|begin\\|object\\|s\\(ig\\|truct\\)\\)\\>\\|:begin\\>\\|;;")) - (cond - ((not kwop)) - ((string= kwop ";;") (setq kwop nil) (forward-line 1)) - ((string= kwop "end") (setq unbalanced (1+ unbalanced))) - ( t (setq unbalanced (1- unbalanced))))) - (if (string= kwop ":begin") "begin" - kwop))) - -(defun caml-find-in-match () - (let ((unbalanced 1) (kwop t)) - (while (and (not (= 0 unbalanced)) kwop) - (setq kwop (caml-find-kwop "\\<\\(in\\|let\\|end\\)\\>")) - (cond - ((not kwop)) - ((string= kwop "end") (caml-find-end-match)) - ((string= kwop "in") (setq unbalanced (1+ unbalanced))) - (t (setq unbalanced (1- unbalanced))))) - kwop)) - -(defun caml-find-with-match () - (let ((unbalanced 1) (kwop t)) - (while (and (not (= 0 unbalanced)) kwop) - (setq kwop - (caml-find-kwop - "\\<\\(with\\|try\\|m\\(atch\\|odule\\)\\|functor\\)\\>\\|[{}()]")) - (cond - ((not kwop)) - ((caml-at-sexp-close-p) - (caml-find-paren-match (following-char))) - ((string= kwop "with") - (setq unbalanced (1+ unbalanced))) - ((or (string= kwop "module") - (string= kwop "functor") - (string= kwop "{") - (string= kwop "(")) - (setq unbalanced 0)) - (t (setq unbalanced (1- unbalanced))))) - kwop)) - -(defun caml-find-paren-match (close) - (let ((unbalanced 1) - (regexp (cond ((= close ?\)) "[()]") - ((= close ?\]) "[][]") - ((= close ?\}) "[{}]")))) - (while (and (> unbalanced 0) - (caml-find-kwop regexp)) - (if (= close (following-char)) - (setq unbalanced (1+ unbalanced)) - (setq unbalanced (1- unbalanced)))))) - -(defun caml-find-then-match (&optional from-else) - (let ((bol (if from-else - (save-excursion - (progn (beginning-of-line) (point))))) - kwop done matching-fun) - (while (not done) - (setq kwop - (caml-find-kwop - "\\<\\(e\\(nd\\|lse\\)\\|done\\|then\\|if\\|with\\)\\>\\|[])};]")) - (cond - ((not kwop) (setq done t)) - ((caml-at-sexp-close-p) - (caml-find-paren-match (following-char))) - ((string= kwop "if") (setq done t)) - ((string= kwop "then") - (if (not from-else) (setq kwop (caml-find-then-match)))) - ((setq matching-fun (cdr-safe (assoc kwop caml-matching-kw-alist))) - (setq kwop (funcall matching-fun))))) - (if (and bol (>= (point) bol)) - "if-else" - kwop))) - -(defun caml-find-pipe-match () - (let ((done nil) (kwop) - (re (concat - "\\<\\(try\\|match\\|with\\|function\\|parser\\|type" - "\\|e\\(nd\\|lse\\)\\|done\\|then\\|in\\)\\>" - "\\|[^[|]|\\|[])}]"))) - (while (not done) - (setq kwop (caml-find-kwop re)) - (cond - ((not kwop) (setq done t)) - ((looking-at "[^[|]\\(|\\)") - (goto-char (match-beginning 1)) - (setq kwop "|") - (setq done t)) - ((caml-at-sexp-close-p) - (caml-find-paren-match (following-char))) - ((string= kwop "with") - (setq kwop (caml-find-with-match)) - (setq done t)) - ((string= kwop "parser") - (if (re-search-backward "\\" (- (point) 5) t) - (setq kwop (caml-find-with-match))) - (setq done t)) - ((string= kwop "done") (caml-find-done-match)) - ((string= kwop "end") (caml-find-end-match)) - ((string= kwop "then") (caml-find-then-match)) - ((string= kwop "else") (caml-find-else-match)) - ((string= kwop "in") (caml-find-in-match)) - (t (setq done t)))) - kwop)) - -(defun caml-find-and-match () - (let ((done nil) (kwop)) - (while (not done) - (setq kwop (caml-find-kwop - "\\<\\(object\\|exception\\|let\\|type\\|end\\|in\\)\\>")) - (cond - ((not kwop) (setq done t)) - ((string= kwop "end") (caml-find-end-match)) - ((string= kwop "in") (caml-find-in-match)) - (t (setq done t)))) - kwop)) - -(defun caml-find-else-match () - (caml-find-then-match t)) - -(defun caml-find-semi-match () - (caml-find-kwop-skipping-blocks 2)) - -(defun caml-find-comma-match () - (caml-find-kwop-skipping-blocks 3)) - -(defun caml-find-kwop-skipping-blocks (prio) - "Look back for a caml keyword matching caml-kwop-regexps [PRIO]. - - Skip nested blocks." - - (let ((done nil) (kwop nil) (matching-fun) - (kwop-list (aref caml-kwop-regexps prio))) - (while (not done) - (setq kwop (caml-find-kwop - (concat caml-matching-kw-regexp - (cond ((> prio 3) "\\|[])},;]\\|") - ((> prio 2) "\\|[])};]\\|") - (t "\\|[])}]\\|")) - kwop-list))) - (cond - ((not kwop) (setq done t)) - ((caml-at-sexp-close-p) - (caml-find-paren-match (following-char))) - ((or (string= kwop ";;") - (and (string= kwop ";") (= (preceding-char) ?\;))) - (forward-line 1) - (setq kwop ";;") - (setq done t)) - ((and (>= prio 2) (string= kwop "|")) (setq done t)) - ((string= kwop "end") (caml-find-end-match)) - ((string= kwop "done") (caml-find-done-match)) - ((string= kwop "in") - (cond ((and (caml-find-in-match) (>= prio 2)) - (setq kwop "let-in") - (setq done t)))) - ((and (string= kwop "parser") (>= prio 2) - (re-search-backward "\\" (- (point) 5) t)) - (setq kwop (caml-find-with-match)) - (setq done t)) - ((setq matching-fun (cdr-safe (assoc kwop caml-matching-kw-alist))) - (setq kwop (funcall matching-fun)) - (if (looking-at kwop-list) (setq done t))) - (t (let* ((kwop-info (assoc kwop caml-kwop-alist)) - (is-op (and (nth 1 kwop-info) - ; check that we are not at beginning of line - (let ((pos (point)) bti) - (back-to-indentation) - (setq bti (point)) - (goto-char pos) - (< bti pos))))) - (if (and is-op (looking-at - (concat (regexp-quote kwop) - "|?[ \t]*\\(\n\\|(\\*\\)"))) - (setq kwop-list - (aref caml-kwop-regexps (nth 2 kwop-info))) - (setq done t)))))) - kwop)) - -(defun caml-compute-basic-indent (prio) - "Compute indent of current caml line, ignoring leading keywords. - -Find the `governing node' for current line. Compute desired -indentation based on the node and the indentation alists. -Assumes point is exactly at line indentation. -Does not preserve point." - - (let* (in-expr - (kwop (cond - ((looking-at ";;") - (beginning-of-line 1)) - ((looking-at "|\\([^]|]\\|\\'\\)") - (caml-find-pipe-match)) - ((and (looking-at caml-phrase-start-keywords) - (caml-in-expr-p)) - (caml-find-end-match)) - ((and (looking-at caml-matching-kw-regexp) - (assoc (caml-match-string 0) caml-matching-kw-alist)) - (funcall (cdr-safe (assoc (caml-match-string 0) - caml-matching-kw-alist)))) - ((looking-at - (aref caml-kwop-regexps caml-max-indent-priority)) - (let* ((kwop (caml-match-string 0)) - (kwop-info (assoc kwop caml-kwop-alist)) - (prio (if kwop-info (nth 2 kwop-info) - caml-max-indent-priority))) - (if (and (looking-at (aref caml-kwop-regexps 0)) - (not (looking-at "object")) - (caml-in-expr-p)) - (setq in-expr t)) - (caml-find-kwop-skipping-blocks prio))) - (t - (if (and (= prio caml-max-indent-priority) (caml-in-expr-p)) - (setq in-expr t)) - (caml-find-kwop-skipping-blocks prio)))) - (kwop-info (assoc kwop caml-kwop-alist)) - (indent-diff - (cond - ((not kwop-info) (beginning-of-line 1) 0) - ((looking-at "[[({][|<]?[ \t]*") - (length (caml-match-string 0))) - ((nth 1 kwop-info) (symbol-value (nth 3 kwop-info))) - (t - (let ((pos (point))) - (back-to-indentation) -; (if (looking-at "\\") (goto-char pos)) - (- (symbol-value (nth 3 kwop-info)) - (if (looking-at "|") caml-|-extra-indent 0)))))) - (extra (if in-expr caml-apply-extra-indent 0))) - (+ indent-diff extra (current-column)))) - -(defconst caml-leading-kwops-regexp - (concat - "\\<\\(and\\|do\\(ne\\)?\\|e\\(lse\\|nd\\)\\|in" - "\\|t\\(hen\\|o\\)\\|with\\)\\>\\|[]|})]") - - "Regexp matching caml keywords which need special indentation.") - -(defconst caml-leading-kwops-alist - '(("and" caml-and-extra-indent 2) - ("do" caml-do-extra-indent 0) - ("done" caml-done-extra-indent 0) - ("else" caml-else-extra-indent 3) - ("end" caml-end-extra-indent 0) - ("in" caml-in-extra-indent 2) - ("then" caml-then-extra-indent 3) - ("to" caml-to-extra-indent 0) - ("with" caml-with-extra-indent 2) - ("|" caml-|-extra-indent 2) - ("]" caml-rb-extra-indent 0) - ("}" caml-rc-extra-indent 0) - (")" caml-rp-extra-indent 0)) - - "Association list of special caml keyword indent values. - -Each member is of the form (KEYWORD EXTRA-INDENT PRIO) where -EXTRA-INDENT is the variable holding extra indentation amount for -KEYWORD (usually negative) and PRIO is upper bound on priority of -matching nodes to determine KEYWORD's final indentation.") - -(defun caml-compute-final-indent () - (save-excursion - (back-to-indentation) - (cond - ((and (bolp) (looking-at comment-start-skip)) (current-column)) - ((caml-in-comment-p) - (let ((closing (looking-at "\\*)")) - (comment-mark (looking-at "\\*"))) - (caml-backward-comment) - (looking-at comment-start-skip) - (+ (current-column) - (cond - (closing 1) - (comment-mark 1) - (t caml-comment-indent))))) - (t (let* ((leading (looking-at caml-leading-kwops-regexp)) - (assoc-val (if leading (assoc (caml-match-string 0) - caml-leading-kwops-alist))) - (extra (if leading (symbol-value (nth 1 assoc-val)) 0)) - (prio (if leading (nth 2 assoc-val) - caml-max-indent-priority)) - (basic (caml-compute-basic-indent prio))) - (max 0 (if extra (+ extra basic) (current-column)))))))) - - - -(defun caml-split-string () - "Called whenever a line is broken inside a caml string literal." - (insert-before-markers "\"^\"") - (backward-char 1)) - -(defadvice indent-new-comment-line (around - caml-indent-new-comment-line - activate) - - "Handle multi-line strings in caml mode." - -;this advice doesn't make sense in other modes. I wish there were a -;cleaner way to do this: I haven't found one. - - (let ((hooked (and (eq major-mode 'caml-mode) (caml-in-literal-p))) - (split-mark)) - (if (not hooked) nil - (setq split-mark (set-marker (make-marker) (point))) - (caml-split-string)) - ad-do-it - (if (not hooked) nil - (goto-char split-mark) - (set-marker split-mark nil)))) - -(defadvice newline-and-indent (around - caml-newline-and-indent - activate) - - "Handle multi-line strings in caml mode." - - (let ((hooked (and (eq major-mode 'caml-mode) (caml-in-literal-p))) - (split-mark)) - (if (not hooked) nil - (setq split-mark (set-marker (make-marker) (point))) - (caml-split-string)) - ad-do-it - (if (not hooked) nil - (goto-char split-mark) - (set-marker split-mark nil)))) - -(defun caml-electric-pipe () - "If inserting a | or } operator at beginning of line, reindent the line. - -Unfortunately there is a situation where this mechanism gets -confused. It's when | is the first character of a |] sequence. This is -a misfeature of caml syntax and cannot be fixed, however, as a -workaround, the electric ] inserts | itself if the matching [ is -followed by |." - - (interactive "*") - (let ((electric (and caml-electric-indent - (caml-in-indentation) - (not (caml-in-comment-p))))) - (self-insert-command 1) - (if electric (save-excursion (caml-indent-command))))) - -(defun caml-electric-rb () - "If inserting a ] operator at beginning of line, reindent the line. - -Also, if the matching [ is followed by a | and this ] is not preceded -by |, insert one." - - (interactive "*") - (let* ((prec (preceding-char)) - (use-pipe (and caml-electric-close-vector - (not (caml-in-comment-p)) - (not (caml-in-literal-p)) - (or (not (numberp prec)) - (not (char-equal ?| prec))))) - (electric (and caml-electric-indent - (caml-in-indentation) - (not (caml-in-comment-p))))) - (self-insert-command 1) - (if electric (save-excursion (caml-indent-command))) - (if (and use-pipe - (save-excursion - (condition-case nil - (prog2 - (backward-list 1) - (looking-at "\\[|")) - (error "")))) - (save-excursion - (backward-char 1) - (insert "|"))))) - -(defun caml-abbrev-hook () - "If inserting a leading keyword at beginning of line, reindent the line." - ;itz unfortunately we need a special case - (if (and (not (caml-in-comment-p)) (not (= last-command-char ?_))) - (let* ((bol (save-excursion (beginning-of-line) (point))) - (kw (save-excursion - (and (re-search-backward "^[ \t]*\\(\\sw+\\)\\=" bol t) - (caml-match-string 1))))) - (if kw - (let ((indent (save-excursion - (goto-char (match-beginning 1)) - (caml-indent-command) - (current-column))) - (abbrev-correct (if (= last-command-char ?\ ) 1 0))) - (indent-to (- indent - (or - (symbol-value - (nth 1 - (assoc kw caml-leading-kwops-alist))) - 0) - abbrev-correct))))))) - -; (defun caml-indent-phrase () -; (interactive "*") -; (let ((bounds (caml-mark-phrase))) -; (indent-region (car bounds) (cdr bounds) nil))) - -;;; Additional commands by Didier to report errors in toplevel mode - -(defun caml-skip-blank-forward () - (if (looking-at "[ \t\n]*\\((\\*\\([^*]\\|[^(]\\*[^)]\\)*\\*)[ \t\n]*\\)*") - (goto-char (match-end 0)))) - -;; to mark phrases, so that repeated calls will take several of them -;; knows little about Ocaml appart literals and comments, so it should work -;; with other dialects as long as ;; marks the end of phrase. - -(defun caml-indent-phrase (arg) - "Indent current phrase -with prefix arg, indent that many phrases starting with the current phrase." - (interactive "p") - (save-excursion - (let ((beg (caml-find-phrase))) - (while (progn (setq arg (- arg 1)) (> arg 0)) (caml-find-phrase)) - (indent-region beg (point) nil)))) - -(defun caml-indent-buffer () - (interactive) - (indent-region (point-min) (point-max) nil)) - -(defun caml-backward-to-less-indent (&optional n) - "Move cursor back N lines with less or same indentation." - (interactive "p") - (beginning-of-line 1) - (if (< n 0) (caml-forward-to-less-indent (- n)) - (while (> n 0) - (let ((i (current-indentation))) - (forward-line -1) - (while (or (> (current-indentation) i) - (caml-in-comment-p) - (looking-at - (concat "[ \t]*\\(\n\\|" comment-start-skip "\\)"))) - (forward-line -1))) - (setq n (1- n)))) - (back-to-indentation)) - -(defun caml-forward-to-less-indent (&optional n) - "Move cursor back N lines with less or same indentation." - (interactive "p") - (beginning-of-line 1) - (if (< n 0) (caml-backward-to-less-indent (- n)) - (while (> n 0) - (let ((i (current-indentation))) - (forward-line 1) - (while (or (> (current-indentation) i) - (caml-in-comment-p) - (looking-at - (concat "[ \t]*\\(\n\\|" comment-start-skip "\\)"))) - (forward-line 1))) - (setq n (1- n)))) - (back-to-indentation)) - -(defun caml-insert-begin-form () - "Inserts a nicely formatted begin-end form, leaving a mark after end." - (interactive "*") - (let ((prec (preceding-char))) - (if (and (numberp prec) (not (char-equal ?\ (char-syntax prec)))) - (insert " "))) - (let* ((c (current-indentation)) (i (+ caml-begin-indent c))) - (insert "begin\n\nend") - (push-mark) - (indent-line-to c) - (forward-line -1) - (indent-line-to i))) - -(defun caml-insert-for-form () - "Inserts a nicely formatted for-do-done form, leaving a mark after do(ne)." - (interactive "*") - (let ((prec (preceding-char))) - (if (and (numberp prec) (not (char-equal ?\ (char-syntax prec)))) - (insert " "))) - (let* ((c (current-indentation)) (i (+ caml-for-indent c))) - (insert "for do\n\ndone") - (push-mark) - (indent-line-to c) - (forward-line -1) - (indent-line-to i) - (push-mark) - (beginning-of-line 1) - (backward-char 4))) - -(defun caml-insert-if-form () - "Insert nicely formatted if-then-else form leaving mark after then, else." - (interactive "*") - (let ((prec (preceding-char))) - (if (and (numberp prec) (not (char-equal ?\ (char-syntax prec)))) - (insert " "))) - (let* ((c (current-indentation)) (i (+ caml-if-indent c))) - (insert "if\n\nthen\n\nelse\n") - (indent-line-to i) - (push-mark) - (forward-line -1) - (indent-line-to c) - (forward-line -1) - (indent-line-to i) - (push-mark) - (forward-line -1) - (indent-line-to c) - (forward-line -1) - (indent-line-to i))) - -(defun caml-insert-match-form () - "Insert nicely formatted match-with form leaving mark after with." - (interactive "*") - (let ((prec (preceding-char))) - (if (and (numberp prec) (not (char-equal ?\ (char-syntax prec)))) - (insert " "))) - (let* ((c (current-indentation)) (i (+ caml-match-indent c))) - (insert "match\n\nwith\n") - (indent-line-to i) - (push-mark) - (forward-line -1) - (indent-line-to c) - (forward-line -1) - (indent-line-to i))) - -(defun caml-insert-let-form () - "Insert nicely formatted let-in form leaving mark after in." - (interactive "*") - (let ((prec (preceding-char))) - (if (and (numberp prec) (not (char-equal ?\ (char-syntax prec)))) - (insert " "))) - (let* ((c (current-indentation))) - (insert "let in\n") - (indent-line-to c) - (push-mark) - (forward-line -1) - (forward-char (+ c 4)))) - -(defun caml-insert-try-form () - "Insert nicely formatted try-with form leaving mark after with." - (interactive "*") - (let ((prec (preceding-char))) - (if (and (numberp prec) (not (char-equal ?\ (char-syntax prec)))) - (insert " "))) - (let* ((c (current-indentation)) (i (+ caml-try-indent c))) - (insert "try\n\nwith\n") - (indent-line-to i) - (push-mark) - (forward-line -1) - (indent-line-to c) - (forward-line -1) - (indent-line-to i))) - -(defun caml-insert-while-form () - "Insert nicely formatted while-do-done form leaving mark after do, done." - (interactive "*") - (let ((prec (preceding-char))) - (if (and (numberp prec) (not (char-equal ?\ (char-syntax prec)))) - (insert " "))) - (let* ((c (current-indentation)) (i (+ caml-if-indent c))) - (insert "while do\n\ndone") - (push-mark) - (indent-line-to c) - (forward-line -1) - (indent-line-to i) - (push-mark) - (beginning-of-line 1) - (backward-char 4))) - -(autoload 'run-caml "inf-caml" "Run an inferior Caml process." t) - -(autoload 'caml-types-show-type "caml-types" - "Show the type of expression or pattern at point." t) -(autoload 'caml-types-explore "caml-types" - "Explore type annotations by mouse dragging." t) - -(autoload 'caml-help "caml-help" - "Show documentation for qualilifed OCaml identifier." t) -(autoload 'caml-complete "caml-help" - "Does completion for documented qualified OCaml identifier." t) -(autoload 'ocaml-open-module "caml-help" - "Add module in documentation search path." t) -(autoload 'ocaml-close-module "caml-help" - "Remove module from documentation search path." t) -(autoload 'ocaml-add-path "caml-help" - "Add search path for documentation." t) - -;;; caml.el ends here - -(provide 'caml) diff --git a/emacs/camldebug.el b/emacs/camldebug.el deleted file mode 100644 index c66343a4e1..0000000000 --- a/emacs/camldebug.el +++ /dev/null @@ -1,754 +0,0 @@ -;;; Run camldebug under Emacs -;;; Derived from gdb.el. -;;; gdb.el is Copyright (C) 1988 Free Software Foundation, Inc, and is part -;;; of GNU Emacs -;;; Modified by Jerome Vouillon, 1994. -;;; Modified by Ian T. Zimmerman, 1996. -;;; Modified by Xavier Leroy, 1997. - -;; This file is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 1, or (at your option) -;; any later version. - -;; This file is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;;itz 04-06-96 I pondered basing this on gud. The potential advantages -;;were: automatic bugfix , keymaps and menus propagation. -;;Disadvantages: gud is not so clean itself, there is little common -;;functionality it abstracts (most of the stuff is done in the -;;debugger specific parts anyway), and, most seriously, gud sees it -;;fit to add C-x C-a bindings to the _global_ map, so there would be a -;;conflict between camldebug and gdb, for instance. While it's OK to -;;assume that a sane person doesn't use gdb and dbx at the same time, -;;it's not so OK (IMHO) for gdb and camldebug. - -;; Xavier Leroy, 21/02/97: adaptation to ocamldebug. - -(require 'comint) -(require 'shell) -(require 'caml) -(require 'derived) -(require 'thingatpt) - -;;; Variables. - -(defvar camldebug-last-frame) -(defvar camldebug-delete-prompt-marker) -(defvar camldebug-filter-accumulator nil) -(defvar camldebug-last-frame-displayed-p) -(defvar camldebug-filter-function) - -(defvar camldebug-prompt-pattern "^(ocd) *" - "A regexp to recognize the prompt for ocamldebug.") - -(defvar camldebug-overlay-event nil - "Overlay for displaying the current event.") -(defvar camldebug-overlay-under nil - "Overlay for displaying the current event.") -(defvar camldebug-event-marker nil - "Marker for displaying the current event.") - -(defvar camldebug-track-frame t - "*If non-nil, always display current frame position in another window.") - -(cond - (window-system - (make-face 'camldebug-event) - (make-face 'camldebug-underline) - (if (not (face-differs-from-default-p 'camldebug-event)) - (invert-face 'camldebug-event)) - (if (not (face-differs-from-default-p 'camldebug-underline)) - (set-face-underline-p 'camldebug-underline t)) - (setq camldebug-overlay-event (make-overlay 1 1)) - (overlay-put camldebug-overlay-event 'face 'camldebug-event) - (setq camldebug-overlay-under (make-overlay 1 1)) - (overlay-put camldebug-overlay-under 'face 'camldebug-underline)) - (t - (setq camldebug-event-marker (make-marker)) - (setq overlay-arrow-string "=>"))) - -;;; Camldebug mode. - -(define-derived-mode camldebug-mode comint-mode "Inferior CDB" - - "Major mode for interacting with an inferior Camldebug process. - -The following commands are available: - -\\{camldebug-mode-map} - -\\[camldebug-display-frame] displays in the other window -the last line referred to in the camldebug buffer. - -\\[camldebug-step], \\[camldebug-back] and \\[camldebug-next], in the camldebug window, -call camldebug to step, backstep or next and then update the other window -with the current file and position. - -If you are in a source file, you may select a point to break -at, by doing \\[camldebug-break]. - -Commands: -Many commands are inherited from comint mode. -Additionally we have: - -\\[camldebug-display-frame] display frames file in other window -\\[camldebug-step] advance one line in program -C-x SPACE sets break point at current line." - - (mapcar 'make-local-variable - '(camldebug-last-frame-displayed-p camldebug-last-frame - camldebug-delete-prompt-marker camldebug-filter-function - camldebug-filter-accumulator paragraph-start)) - (setq - camldebug-last-frame nil - camldebug-delete-prompt-marker (make-marker) - camldebug-filter-accumulator "" - camldebug-filter-function 'camldebug-marker-filter - comint-prompt-regexp camldebug-prompt-pattern - comint-dynamic-complete-functions (cons 'camldebug-complete - comint-dynamic-complete-functions) - paragraph-start comint-prompt-regexp - camldebug-last-frame-displayed-p t) - (make-local-variable 'shell-dirtrackp) - (setq shell-dirtrackp t) - (setq comint-input-sentinel 'shell-directory-tracker)) - -;;; Keymaps. - -(defun camldebug-numeric-arg (arg) - (and arg (prefix-numeric-value arg))) - -(defmacro def-camldebug (name key &optional doc args) - - "Define camldebug-NAME to be a command sending NAME ARGS and bound -to KEY, with optional doc string DOC. Certain %-escapes in ARGS are -interpreted specially if present. These are: - - %m module name of current module. - %d directory of current source file. - %c number of current character position - %e text of the caml variable surrounding point. - - The `current' source file is the file of the current buffer (if -we're in a caml buffer) or the source file current at the last break -or step (if we're in the camldebug buffer), and the `current' module -name is the filename stripped of any *.ml* suffixes (this assumes the -usual correspondence between module and file naming is observed). The -`current' position is that of the current buffer (if we're in a source -file) or the position of the last break or step (if we're in the -camldebug buffer). - -If a numeric is present, it overrides any ARGS flags and its string -representation is simply concatenated with the COMMAND." - - (let* ((fun (intern (format "camldebug-%s" name)))) - (list 'progn - (if doc - (list 'defun fun '(arg) - doc - '(interactive "P") - (list 'camldebug-call name args - '(camldebug-numeric-arg arg)))) - (list 'define-key 'camldebug-mode-map - (concat "\C-c" key) - (list 'quote fun)) - (list 'define-key 'caml-mode-map - (concat "\C-x\C-a" key) - (list 'quote fun))))) - -(def-camldebug "step" "\C-s" "Step one event forward.") -(def-camldebug "backstep" "\C-k" "Step one event backward.") -(def-camldebug "run" "\C-r" "Run the program.") -(def-camldebug "reverse" "\C-v" "Run the program in reverse.") -(def-camldebug "last" "\C-l" "Go to latest time in execution history.") -(def-camldebug "backtrace" "\C-t" "Print the call stack.") -(def-camldebug "finish" "\C-f" "Finish executing current function.") -(def-camldebug "print" "\C-p" "Print value of symbol at point." "%e") -(def-camldebug "display" "\C-d" "Display value of symbol at point." "%e") -(def-camldebug "next" "\C-n" "Step one event forward (skip functions)") -(def-camldebug "up" "<" "Go up N stack frames (numeric arg) with display") -(def-camldebug "down" ">" "Go down N stack frames (numeric arg) with display") -(def-camldebug "break" "\C-b" "Set breakpoint at current line." - "@ \"%m\" # %c") - -(defun camldebug-mouse-display (click) - "Display value of $NNN clicked on." - (interactive "e") - (let* ((start (event-start click)) - (window (car start)) - (pos (car (cdr start))) - symb) - (save-excursion - (select-window window) - (goto-char pos) - (setq symb (thing-at-point 'symbol)) - (if (string-match "^\\$[0-9]+$" symb) - (camldebug-call "display" symb))))) - -(define-key camldebug-mode-map [mouse-2] 'camldebug-mouse-display) - -(defun camldebug-kill-filter (string) - ;gob up stupid questions :-) - (setq camldebug-filter-accumulator - (concat camldebug-filter-accumulator string)) - (if (not (string-match "\\(.* \\)(y or n) " - camldebug-filter-accumulator)) nil - (setq camldebug-kill-output - (cons t (match-string 1 camldebug-filter-accumulator))) - (setq camldebug-filter-accumulator "")) - (if (string-match comint-prompt-regexp camldebug-filter-accumulator) - (let ((output (substring camldebug-filter-accumulator - (match-beginning 0)))) - (setq camldebug-kill-output - (cons nil (substring camldebug-filter-accumulator 0 - (1- (match-beginning 0))))) - (setq camldebug-filter-accumulator "") - output) - "")) - -(def-camldebug "kill" "\C-k") - -(defun camldebug-kill () - "Kill the program." - (interactive) - (let ((camldebug-kill-output)) - (save-excursion - (set-buffer current-camldebug-buffer) - (let ((proc (get-buffer-process (current-buffer))) - (camldebug-filter-function 'camldebug-kill-filter)) - (camldebug-call "kill") - (while (not (and camldebug-kill-output - (zerop (length camldebug-filter-accumulator)))) - (accept-process-output proc)))) - (if (not (car camldebug-kill-output)) - (error (cdr camldebug-kill-output)) - (sit-for 0 300) - (camldebug-call-1 (if (y-or-n-p (cdr camldebug-kill-output)) "y" "n"))))) -;;FIXME: camldebug doesn't output the Hide marker on kill - -(defun camldebug-goto-filter (string) - ;accumulate onto previous output - (setq camldebug-filter-accumulator - (concat camldebug-filter-accumulator string)) - (if (not (string-match (concat "\\(\n\\|\\`\\)[ \t]*\\([0-9]+\\)[ \t]+" - camldebug-goto-position - "[ \t]*\\(before\\|after\\)\n") - camldebug-filter-accumulator)) nil - (setq camldebug-goto-output - (match-string 2 camldebug-filter-accumulator)) - (setq camldebug-filter-accumulator - (substring camldebug-filter-accumulator (1- (match-end 0))))) - (if (not (string-match comint-prompt-regexp - camldebug-filter-accumulator)) nil - (setq camldebug-goto-output (or camldebug-goto-output 'fail)) - (setq camldebug-filter-accumulator "")) - (if (string-match "\n\\(.*\\)\\'" camldebug-filter-accumulator) - (setq camldebug-filter-accumulator - (match-string 1 camldebug-filter-accumulator))) - "") - -(def-camldebug "goto" "\C-g") -(defun camldebug-goto (&optional time) - - "Go to the execution time TIME. - -Without TIME, the command behaves as follows: In the camldebug buffer, -if the point at buffer end, goto time 0\; otherwise, try to obtain the -time from context around point. In a caml mode buffer, try to find the -time associated in execution history with the current point location. - -With a negative TIME, move that many lines backward in the camldebug -buffer, then try to obtain the time from context around point." - - (interactive "P") - (cond - (time - (let ((ntime (camldebug-numeric-arg time))) - (if (>= ntime 0) (camldebug-call "goto" nil ntime) - (save-selected-window - (select-window (get-buffer-window current-camldebug-buffer)) - (save-excursion - (if (re-search-backward "^Time : [0-9]+ - pc : [0-9]+ " - nil t (- 1 ntime)) - (camldebug-goto nil) - (error "I don't have %d times in my history" - (- 1 ntime)))))))) - ((eq (current-buffer) current-camldebug-buffer) - (let ((time (cond - ((eobp) 0) - ((save-excursion - (beginning-of-line 1) - (looking-at "^Time : \\([0-9]+\\) - pc : [0-9]+ ")) - (string-to-int (match-string 1))) - ((string-to-int (camldebug-format-command "%e")))))) - (camldebug-call "goto" nil time))) - (t - (let ((module (camldebug-module-name (buffer-file-name))) - (camldebug-goto-position (int-to-string (1- (point)))) - (camldebug-goto-output) (address)) - ;get a list of all events in the current module - (save-excursion - (set-buffer current-camldebug-buffer) - (let* ((proc (get-buffer-process (current-buffer))) - (camldebug-filter-function 'camldebug-goto-filter)) - (camldebug-call-1 (concat "info events " module)) - (while (not (and camldebug-goto-output - (zerop (length camldebug-filter-accumulator)))) - (accept-process-output proc)) - (setq address (if (eq camldebug-goto-output 'fail) nil - (re-search-backward - (concat "^Time : \\([0-9]+\\) - pc : " - camldebug-goto-output - " - module " - module "$") nil t) - (match-string 1))))) - (if address (camldebug-call "goto" nil (string-to-int address)) - (error "No time at %s at %s" module camldebug-goto-position)))))) - - -(defun camldebug-delete-filter (string) - (setq camldebug-filter-accumulator - (concat camldebug-filter-accumulator string)) - (if (not (string-match - (concat "\\(\n\\|\\`\\)[ \t]*\\([0-9]+\\)[ \t]+[0-9]+[ \t]*in " - (regexp-quote camldebug-delete-file) - ", character " - camldebug-delete-position "\n") - camldebug-filter-accumulator)) nil - (setq camldebug-delete-output - (match-string 2 camldebug-filter-accumulator)) - (setq camldebug-filter-accumulator - (substring camldebug-filter-accumulator (1- (match-end 0))))) - (if (not (string-match comint-prompt-regexp - camldebug-filter-accumulator)) nil - (setq camldebug-delete-output (or camldebug-delete-output 'fail)) - (setq camldebug-filter-accumulator "")) - (if (string-match "\n\\(.*\\)\\'" camldebug-filter-accumulator) - (setq camldebug-filter-accumulator - (match-string 1 camldebug-filter-accumulator))) - "") - - -(def-camldebug "delete" "\C-d") - -(defun camldebug-delete (&optional arg) - "Delete the breakpoint numbered ARG. - -Without ARG, the command behaves as follows: In the camldebug buffer, -try to obtain the time from context around point. In a caml mode -buffer, try to find the breakpoint associated with the current point -location. - -With a negative ARG, look for the -ARGth breakpoint pattern in the -camldebug buffer, then try to obtain the breakpoint info from context -around point." - - (interactive "P") - (cond - (arg - (let ((narg (camldebug-numeric-arg arg))) - (if (> narg 0) (camldebug-call "delete" nil narg) - (save-excursion - (set-buffer current-camldebug-buffer) - (if (re-search-backward "^Breakpoint [0-9]+ at [0-9]+ : file " - nil t (- 1 narg)) - (camldebug-delete nil) - (error "I don't have %d breakpoints in my history" - (- 1 narg))))))) - ((eq (current-buffer) current-camldebug-buffer) - (let* ((bpline "^Breakpoint \\([0-9]+\\) at [0-9]+ : file ") - (arg (cond - ((eobp) - (save-excursion (re-search-backward bpline nil t)) - (string-to-int (match-string 1))) - ((save-excursion - (beginning-of-line 1) - (looking-at bpline)) - (string-to-int (match-string 1))) - ((string-to-int (camldebug-format-command "%e")))))) - (camldebug-call "delete" nil arg))) - (t - (let ((camldebug-delete-file - (concat (camldebug-format-command "%m") ".ml")) - (camldebug-delete-position (camldebug-format-command "%c"))) - (save-excursion - (set-buffer current-camldebug-buffer) - (let ((proc (get-buffer-process (current-buffer))) - (camldebug-filter-function 'camldebug-delete-filter) - (camldebug-delete-output)) - (camldebug-call-1 "info break") - (while (not (and camldebug-delete-output - (zerop (length - camldebug-filter-accumulator)))) - (accept-process-output proc)) - (if (eq camldebug-delete-output 'fail) - (error "No breakpoint in %s at %s" - camldebug-delete-file - camldebug-delete-position) - (camldebug-call "delete" nil - (string-to-int camldebug-delete-output))))))))) - -(defun camldebug-complete-filter (string) - (setq camldebug-filter-accumulator - (concat camldebug-filter-accumulator string)) - (while (string-match "\\(\n\\|\\`\\)\\(.+\\)\n" - camldebug-filter-accumulator) - (setq camldebug-complete-list - (cons (match-string 2 camldebug-filter-accumulator) - camldebug-complete-list)) - (setq camldebug-filter-accumulator - (substring camldebug-filter-accumulator - (1- (match-end 0))))) - (if (not (string-match comint-prompt-regexp - camldebug-filter-accumulator)) nil - (setq camldebug-complete-list - (or camldebug-complete-list 'fail)) - (setq camldebug-filter-accumulator "")) - (if (string-match "\n\\(.*\\)\\'" camldebug-filter-accumulator) - (setq camldebug-filter-accumulator - (match-string 1 camldebug-filter-accumulator))) - "") - -(defun camldebug-complete () - - "Perform completion on the camldebug command preceding point." - - (interactive) - (let* ((end (point)) - (command (save-excursion - (beginning-of-line) - (and (looking-at comint-prompt-regexp) - (goto-char (match-end 0))) - (buffer-substring (point) end))) - (camldebug-complete-list nil) (command-word)) - - ;; Find the word break. This match will always succeed. - (string-match "\\(\\`\\| \\)\\([^ ]*\\)\\'" command) - (setq command-word (match-string 2 command)) - - ;itz 04-21-96 if we are trying to complete a word of nonzero - ;length, chop off the last character. This is a nasty hack, but it - ;works - in general, not just for this set of words: the comint - ;call below will weed out false matches - and it avoids further - ;mucking with camldebug's lexer. - (if (> (length command-word) 0) - (setq command (substring command 0 (1- (length command))))) - - (let ((camldebug-filter-function 'camldebug-complete-filter)) - (camldebug-call-1 (concat "complete " command)) - (set-marker camldebug-delete-prompt-marker nil) - (while (not (and camldebug-complete-list - (zerop (length camldebug-filter-accumulator)))) - (accept-process-output (get-buffer-process - (current-buffer))))) - (if (eq camldebug-complete-list 'fail) - (setq camldebug-complete-list nil)) - (setq camldebug-complete-list - (sort camldebug-complete-list 'string-lessp)) - (comint-dynamic-simple-complete command-word camldebug-complete-list))) - -(define-key camldebug-mode-map "\C-l" 'camldebug-refresh) -(define-key camldebug-mode-map "\t" 'comint-dynamic-complete) -(define-key camldebug-mode-map "\M-?" 'comint-dynamic-list-completions) - -(define-key caml-mode-map "\C-x " 'camldebug-break) - - -(defvar current-camldebug-buffer nil) - - -;;;###autoload -(defvar camldebug-command-name "ocamldebug" - "*Pathname for executing camldebug.") - -;;;###autoload -(defun camldebug (path) - "Run camldebug on program FILE in buffer *camldebug-FILE*. -The directory containing FILE becomes the initial working directory -and source-file directory for camldebug. If you wish to change this, use -the camldebug commands `cd DIR' and `directory'." - (interactive "fRun ocamldebug on file: ") - (setq path (expand-file-name path)) - (let ((file (file-name-nondirectory path))) - (pop-to-buffer (concat "*camldebug-" file "*")) - (setq default-directory (file-name-directory path)) - (message "Current directory is %s" default-directory) - (make-comint (concat "camldebug-" file) - (substitute-in-file-name camldebug-command-name) - nil - "-emacs" "-cd" default-directory file) - (set-process-filter (get-buffer-process (current-buffer)) - 'camldebug-filter) - (set-process-sentinel (get-buffer-process (current-buffer)) - 'camldebug-sentinel) - (camldebug-mode) - (camldebug-set-buffer))) - -(defun camldebug-set-buffer () - (if (eq major-mode 'camldebug-mode) - (setq current-camldebug-buffer (current-buffer)) - (save-selected-window (pop-to-buffer current-camldebug-buffer)))) - -;;; Filter and sentinel. - -(defun camldebug-marker-filter (string) - (setq camldebug-filter-accumulator - (concat camldebug-filter-accumulator string)) - (let ((output "") (begin)) - ;; Process all the complete markers in this chunk. - (while (setq begin - (string-match - "\032\032\\(H\\|M\\(.+\\):\\(.+\\):\\(before\\|after\\)\\)\n" - camldebug-filter-accumulator)) - (setq camldebug-last-frame - (if (char-equal ?H (aref camldebug-filter-accumulator - (1+ (1+ begin)))) nil - (list (match-string 2 camldebug-filter-accumulator) - (string-to-int - (match-string 3 camldebug-filter-accumulator)) - (string= "before" - (match-string 4 - camldebug-filter-accumulator)))) - output (concat output - (substring camldebug-filter-accumulator - 0 begin)) - ;; Set the accumulator to the remaining text. - camldebug-filter-accumulator (substring - camldebug-filter-accumulator - (match-end 0)) - camldebug-last-frame-displayed-p nil)) - - ;; Does the remaining text look like it might end with the - ;; beginning of another marker? If it does, then keep it in - ;; camldebug-filter-accumulator until we receive the rest of it. Since we - ;; know the full marker regexp above failed, it's pretty simple to - ;; test for marker starts. - (if (string-match "\032.*\\'" camldebug-filter-accumulator) - (progn - ;; Everything before the potential marker start can be output. - (setq output (concat output (substring camldebug-filter-accumulator - 0 (match-beginning 0)))) - - ;; Everything after, we save, to combine with later input. - (setq camldebug-filter-accumulator - (substring camldebug-filter-accumulator (match-beginning 0)))) - - (setq output (concat output camldebug-filter-accumulator) - camldebug-filter-accumulator "")) - - output)) - -(defun camldebug-filter (proc string) - (let ((output)) - (if (buffer-name (process-buffer proc)) - (let ((process-window)) - (save-excursion - (set-buffer (process-buffer proc)) - ;; If we have been so requested, delete the debugger prompt. - (if (marker-buffer camldebug-delete-prompt-marker) - (progn - (delete-region (process-mark proc) - camldebug-delete-prompt-marker) - (set-marker camldebug-delete-prompt-marker nil))) - (setq output (funcall camldebug-filter-function string)) - ;; Don't display the specified file unless - ;; (1) point is at or after the position where output appears - ;; and (2) this buffer is on the screen. - (setq process-window (and camldebug-track-frame - (not camldebug-last-frame-displayed-p) - (>= (point) (process-mark proc)) - (get-buffer-window (current-buffer)))) - ;; Insert the text, moving the process-marker. - (comint-output-filter proc output)) - (if process-window - (save-selected-window - (select-window process-window) - (camldebug-display-frame))))))) - -(defun camldebug-sentinel (proc msg) - (cond ((null (buffer-name (process-buffer proc))) - ;; buffer killed - ;; Stop displaying an arrow in a source file. - (camldebug-remove-current-event) - (set-process-buffer proc nil)) - ((memq (process-status proc) '(signal exit)) - ;; Stop displaying an arrow in a source file. - (camldebug-remove-current-event) - ;; Fix the mode line. - (setq mode-line-process - (concat ": " - (symbol-name (process-status proc)))) - (let* ((obuf (current-buffer))) - ;; save-excursion isn't the right thing if - ;; process-buffer is current-buffer - (unwind-protect - (progn - ;; Write something in *compilation* and hack its mode line, - (set-buffer (process-buffer proc)) - ;; Force mode line redisplay soon - (set-buffer-modified-p (buffer-modified-p)) - (if (eobp) - (insert ?\n mode-name " " msg) - (save-excursion - (goto-char (point-max)) - (insert ?\n mode-name " " msg))) - ;; If buffer and mode line will show that the process - ;; is dead, we can delete it now. Otherwise it - ;; will stay around until M-x list-processes. - (delete-process proc)) - ;; Restore old buffer, but don't restore old point - ;; if obuf is the cdb buffer. - (set-buffer obuf)))))) - - -(defun camldebug-refresh (&optional arg) - "Fix up a possibly garbled display, and redraw the mark." - (interactive "P") - (camldebug-display-frame) - (recenter arg)) - -(defun camldebug-display-frame () - "Find, obey and delete the last filename-and-line marker from CDB. -The marker looks like \\032\\032FILENAME:CHARACTER\\n. -Obeying it means displaying in another window the specified file and line." - (interactive) - (camldebug-set-buffer) - (if (not camldebug-last-frame) - (camldebug-remove-current-event) - (camldebug-display-line (car camldebug-last-frame) - (car (cdr camldebug-last-frame)) - (car (cdr (cdr camldebug-last-frame))))) - (setq camldebug-last-frame-displayed-p t)) - -;; Make sure the file named TRUE-FILE is in a buffer that appears on the screen -;; and that its character CHARACTER is visible. -;; Put the mark on this character in that buffer. - -(defun camldebug-display-line (true-file character kind) - (let* ((pre-display-buffer-function nil) ; screw it, put it all in one screen - (pop-up-windows t) - (buffer (find-file-noselect true-file)) - (window (display-buffer buffer t)) - (pos)) - (save-excursion - (set-buffer buffer) - (save-restriction - (widen) - (setq pos (+ (point-min) character)) - (camldebug-set-current-event pos (current-buffer) kind)) - (cond ((or (< pos (point-min)) (> pos (point-max))) - (widen) - (goto-char pos)))) - (set-window-point window pos))) - -;;; Events. - -(defun camldebug-remove-current-event () - (if window-system - (progn - (delete-overlay camldebug-overlay-event) - (delete-overlay camldebug-overlay-under)) - (setq overlay-arrow-position nil))) - -(defun camldebug-set-current-event (pos buffer before) - (if window-system - (if before - (progn - (move-overlay camldebug-overlay-event pos (1+ pos) buffer) - (move-overlay camldebug-overlay-under - (+ pos 1) (+ pos 3) buffer)) - (move-overlay camldebug-overlay-event (1- pos) pos buffer) - (move-overlay camldebug-overlay-under (- pos 3) (- pos 1) buffer)) - (save-excursion - (set-buffer buffer) - (goto-char pos) - (beginning-of-line) - (move-marker camldebug-event-marker (point)) - (setq overlay-arrow-position camldebug-event-marker)))) - -;;; Miscellaneous. - -(defun camldebug-module-name (filename) - (substring filename (string-match "\\([^/]*\\)\\.ml$" filename) (match-end 1))) - -;;; The camldebug-call function must do the right thing whether its -;;; invoking keystroke is from the camldebug buffer itself (via -;;; major-mode binding) or a caml buffer. In the former case, we want -;;; to supply data from camldebug-last-frame. Here's how we do it: - -(defun camldebug-format-command (str) - (let* ((insource (not (eq (current-buffer) current-camldebug-buffer))) - (frame (if insource nil camldebug-last-frame)) (result)) - (while (and str (string-match "\\([^%]*\\)%\\([mdcep]\\)" str)) - (let ((key (string-to-char (substring str (match-beginning 2)))) - (cmd (substring str (match-beginning 1) (match-end 1))) - (subst)) - (setq str (substring str (match-end 2))) - (cond - ((eq key ?m) - (setq subst (camldebug-module-name - (if insource (buffer-file-name) (nth 0 frame))))) - ((eq key ?d) - (setq subst (file-name-directory - (if insource (buffer-file-name) (nth 0 frame))))) - ((eq key ?c) - (setq subst (int-to-string - (if insource (1- (point)) (nth 1 frame))))) - ((eq key ?e) - (setq subst (thing-at-point 'symbol)))) - (setq result (concat result cmd subst)))) - ;; There might be text left in STR when the loop ends. - (concat result str))) - -(defun camldebug-call (command &optional fmt arg) - "Invoke camldebug COMMAND displaying source in other window. - -Certain %-escapes in FMT are interpreted specially if present. -These are: - - %m module name of current module. - %d directory of current source file. - %c number of current character position - %e text of the caml variable surrounding point. - - The `current' source file is the file of the current buffer (if -we're in a caml buffer) or the source file current at the last break -or step (if we're in the camldebug buffer), and the `current' module -name is the filename stripped of any *.ml* suffixes (this assumes the -usual correspondence between module and file naming is observed). The -`current' position is that of the current buffer (if we're in a source -file) or the position of the last break or step (if we're in the -camldebug buffer). - -If ARG is present, it overrides any FMT flags and its string -representation is simply concatenated with the COMMAND." - - ;; Make sure debugger buffer is displayed in a window. - (camldebug-set-buffer) - (message "Command: %s" (camldebug-call-1 command fmt arg))) - -(defun camldebug-call-1 (command &optional fmt arg) - - ;; Record info on the last prompt in the buffer and its position. - (save-excursion - (set-buffer current-camldebug-buffer) - (goto-char (process-mark (get-buffer-process current-camldebug-buffer))) - (let ((pt (point))) - (beginning-of-line) - (if (looking-at comint-prompt-regexp) - (set-marker camldebug-delete-prompt-marker (point))))) - (let ((cmd (cond - (arg (concat command " " (int-to-string arg))) - (fmt (camldebug-format-command - (concat command " " fmt))) - (command)))) - (process-send-string (get-buffer-process current-camldebug-buffer) - (concat cmd "\n")) - cmd)) - - -(provide 'camldebug) diff --git a/emacs/inf-caml.el b/emacs/inf-caml.el deleted file mode 100644 index f24a7a71fe..0000000000 --- a/emacs/inf-caml.el +++ /dev/null @@ -1,348 +0,0 @@ -;;; inf-caml.el --- run the Caml toplevel in an Emacs buffer - -;; Xavier Leroy, july 1993. - -;; modified by Jacques Garrigue, july 1997. - -(require 'comint) -(require 'caml) - -;; User modifiable variables - -;; Whether you want the output buffer to be diplayed when you send a phrase - -(defvar caml-display-when-eval t - "*If true, display the inferior caml buffer when evaluating expressions.") - - -;; End of User modifiable variables - - -(defvar inferior-caml-mode-map nil) -(if inferior-caml-mode-map nil - (setq inferior-caml-mode-map - (copy-keymap comint-mode-map))) - -;; Augment Caml mode, so you can process Caml code in the source files. - -(defvar inferior-caml-program "ocaml" - "*Program name for invoking an inferior Caml from Emacs.") - -(defun inferior-caml-mode () - "Major mode for interacting with an inferior Caml process. -Runs a Caml toplevel as a subprocess of Emacs, with I/O through an -Emacs buffer. A history of input phrases is maintained. Phrases can -be sent from another buffer in Caml mode. - -\\{inferior-caml-mode-map}" - (interactive) - (comint-mode) - (setq comint-prompt-regexp "^# ?") - (setq major-mode 'inferior-caml-mode) - (setq mode-name "Inferior Caml") - (make-local-variable 'paragraph-start) - (setq paragraph-start (concat "^$\\|" page-delimiter)) - (make-local-variable 'paragraph-separate) - (setq paragraph-separate paragraph-start) - (make-local-variable 'paragraph-ignore-fill-prefix) - (setq paragraph-ignore-fill-prefix t) - (make-local-variable 'require-final-newline) - (setq require-final-newline t) - (make-local-variable 'comment-start) - (setq comment-start "(*") - (make-local-variable 'comment-end) - (setq comment-end "*)") - (make-local-variable 'comment-column) - (setq comment-column 40) - (make-local-variable 'comment-start-skip) - (setq comment-start-skip "(\\*+ *") - (make-local-variable 'parse-sexp-ignore-comments) - (setq parse-sexp-ignore-comments nil) - (use-local-map inferior-caml-mode-map) - (run-hooks 'inferior-caml-mode-hooks)) - - -(defconst inferior-caml-buffer-subname "inferior-caml") -(defconst inferior-caml-buffer-name - (concat "*" inferior-caml-buffer-subname "*")) - -;; for compatibility with xemacs - -(defun caml-sit-for (second &optional mili redisplay) - (if (and (boundp 'running-xemacs) running-xemacs) - (sit-for (if mili (+ second (* mili 0.001)) second) redisplay) - (sit-for second mili redisplay))) - -;; To show result of evaluation at toplevel - -(defvar inferior-caml-output nil) -(defun inferior-caml-signal-output (s) - (if (string-match "[^ ]" s) (setq inferior-caml-output t))) - -(defun inferior-caml-mode-output-hook () - (setq comint-output-filter-functions - (list (function inferior-caml-signal-output)))) -(add-hook 'inferior-caml-mode-hooks 'inferior-caml-mode-output-hook) - -;; To launch ocaml whenever needed - -(defun caml-run-process-if-needed (&optional cmd) - (if (comint-check-proc inferior-caml-buffer-name) nil - (if (not cmd) - (if (comint-check-proc inferior-caml-buffer-name) - (setq cmd inferior-caml-program) - (setq cmd (read-from-minibuffer "Caml toplevel to run: " - inferior-caml-program)))) - (setq inferior-caml-program cmd) - (let ((cmdlist (inferior-caml-args-to-list cmd)) - (process-connection-type nil)) - (set-buffer (apply (function make-comint) - inferior-caml-buffer-subname - (car cmdlist) nil (cdr cmdlist))) - (inferior-caml-mode) - (display-buffer inferior-caml-buffer-name) - t) - (setq caml-shell-active t) - )) - -;; patched to from original run-caml sharing code with -;; caml-run-process-when-needed - -(defun run-caml (&optional cmd) - "Run an inferior Caml process. -Input and output via buffer `*inferior-caml*'." - (interactive - (list (if (not (comint-check-proc inferior-caml-buffer-name)) - (read-from-minibuffer "Caml toplevel to run: " - inferior-caml-program)))) - (caml-run-process-if-needed cmd) - (switch-to-buffer-other-window inferior-caml-buffer-name)) - - -(defun inferior-caml-args-to-list (string) - (let ((where (string-match "[ \t]" string))) - (cond ((null where) (list string)) - ((not (= where 0)) - (cons (substring string 0 where) - (inferior-caml-args-to-list (substring string (+ 1 where) - (length string))))) - (t (let ((pos (string-match "[^ \t]" string))) - (if (null pos) - nil - (inferior-caml-args-to-list (substring string pos - (length string))))))))) - -(defun inferior-caml-show-subshell () - (interactive) - (caml-run-process-if-needed) - (display-buffer inferior-caml-buffer-name) - ; Added by Didier to move the point of inferior-caml to end of buffer - (let ((buf (current-buffer)) - (caml-buf (get-buffer inferior-caml-buffer-name)) - (count 0)) - (while - (and (< count 10) - (not (equal (buffer-name (current-buffer)) - inferior-caml-buffer-name))) - (next-multiframe-window) - (setq count (+ count 1))) - (if (equal (buffer-name (current-buffer)) - inferior-caml-buffer-name) - (end-of-buffer)) - (while - (> count 0) - (previous-multiframe-window) - (setq count (- count 1))) - ) -) - -;; patched by Didier to move cursor after evaluation - -(defun inferior-caml-eval-region (start end) - "Send the current region to the inferior Caml process." - (interactive "r") - (save-excursion (caml-run-process-if-needed)) - (save-excursion - (goto-char end) - (caml-skip-comments-backward) - (comint-send-region inferior-caml-buffer-name start (point)) - ;; normally, ";;" are part of the region - (if (and (>= (point) 2) - (prog2 (backward-char 2) (looking-at ";;"))) - (comint-send-string inferior-caml-buffer-name "\n") - (comint-send-string inferior-caml-buffer-name ";;\n")) - ;; the user may not want to see the output buffer - (if caml-display-when-eval - (display-buffer inferior-caml-buffer-name t)))) - -;; jump to errors produced by ocaml compiler - -(defun inferior-caml-goto-error (start end) - "Jump to the location of the last error as indicated by inferior toplevel." - (interactive "r") - (let ((loc (+ start - (save-excursion - (set-buffer (get-buffer inferior-caml-buffer-name)) - (re-search-backward - (concat comint-prompt-regexp - "[ \t]*Characters[ \t]+\\([0-9]+\\)-[0-9]+:$")) - (string-to-int (match-string 1)))))) - (goto-char loc))) - - -;;; orgininal inf-caml.el ended here - -;; as eval-phrase, but ignores errors. - -(defun inferior-caml-just-eval-phrase (arg &optional min max) - "Send the phrase containing the point to the CAML process. -With prefix-arg send as many phrases as its numeric value, -ignoring possible errors during evaluation. - -Optional arguments min max defines a region within which the phrase -should lies." - (interactive "p") - (let ((beg)) - (while (> arg 0) - (setq arg (- arg 1)) - (setq beg (caml-find-phrase min max)) - (caml-eval-region beg (point))) - beg)) - -(defvar caml-previous-output nil - "tells the beginning of output in the shell-output buffer, so that the -output can be retreived later, asynchronously.") - -;; enriched version of eval-phrase, to repport errors. - -(defun inferior-caml-eval-phrase (arg &optional min max) - "Send the phrase containing the point to the CAML process. -With prefix-arg send as many phrases as its numeric value, -If an error occurs during evalutaion, stop at this phrase and -repport the error. - -Return nil if noerror and position of error if any. - -If arg's numeric value is zero or negative, evaluate the current phrase -or as many as prefix arg, ignoring evaluation errors. -This allows to jump other erroneous phrases. - -Optional arguments min max defines a region within which the phrase -should lies." - (interactive "p") - (if (save-excursion (caml-run-process-if-needed)) - (progn - (setq inferior-caml-output nil) - (caml-wait-output 10 1))) - (if (< arg 1) (inferior-caml-just-eval-phrase (max 1 (- 0 arg)) min max) - (let ((proc (get-buffer-process inferior-caml-buffer-name)) - (buf (current-buffer)) - previous-output orig beg end err) - (save-window-excursion - (while (and (> arg 0) (not err)) - (setq previous-output (marker-position (process-mark proc))) - (setq caml-previous-output previous-output) - (setq inferior-caml-output nil) - (setq orig (inferior-caml-just-eval-phrase 1 min max)) - (caml-wait-output) - (switch-to-buffer inferior-caml-buffer-name nil) - (goto-char previous-output) - (cond ((re-search-forward - " *Characters \\([01-9][01-9]*\\)-\\([1-9][01-9]*\\):\n[^W]" - (point-max) t) - (setq beg (string-to-int (caml-match-string 1))) - (setq end (string-to-int (caml-match-string 2))) - (switch-to-buffer buf) - (goto-char orig) - (forward-byte end) - (setq end (point)) - (goto-char orig) - (forward-byte beg) - (setq beg (point)) - (setq err beg) - ) - ((looking-at - "Toplevel input:\n[>]\\([^\n]*\\)\n[>]\\(\\( *\\)^*\\)\n") - (let ((expr (caml-match-string 1)) - (column (- (match-end 3) (match-beginning 3))) - (width (- (match-end 2) (match-end 3)))) - (if (string-match "^\\(.*\\)[<]EOF[>]$" expr) - (setq expr (substring expr (match-beginning 1) (match-end 1)))) - (switch-to-buffer buf) - (re-search-backward - (concat "^" (regexp-quote expr) "$") - (- orig 10)) - (goto-char (+ (match-beginning 0) column)) - (setq end (+ (point) width))) - (setq err beg)) - ((looking-at - "Toplevel input:\n>[.]*\\([^.].*\n\\)\\([>].*\n\\)*[>]\\(.*[^.]\\)[.]*\n") - (let* ((e1 (caml-match-string 1)) - (e2 (caml-match-string 3)) - (expr - (concat - (regexp-quote e1) "\\(.*\n\\)*" (regexp-quote e2)))) - (switch-to-buffer buf) - (re-search-backward expr orig 'move) - (setq end (match-end 0))) - (setq err beg)) - (t - (switch-to-buffer buf))) - (setq arg (- arg 1)) - ) - (pop-to-buffer inferior-caml-buffer-name) - (if err - (goto-char (point-max)) - (goto-char previous-output) - (goto-char (point-max))) - (pop-to-buffer buf)) - (if err (progn (beep) (caml-overlay-region (point) end)) - (if inferior-caml-output - (message "No error") - (message "No output yet...") - )) - err))) - -(defun caml-overlay-region (beg end &optional wait) - (interactive "%r") - (cond ((fboundp 'make-overlay) - (if caml-error-overlay () - (setq caml-error-overlay (make-overlay 1 1)) - (overlay-put caml-error-overlay 'face 'region)) - (unwind-protect - (progn - (move-overlay caml-error-overlay beg end (current-buffer)) - (beep) (if wait (read-event) (caml-sit-for 60))) - (delete-overlay caml-error-overlay))))) - -;; wait some amount for ouput, that is, until inferior-caml-output is set -;; to true. Hence, interleaves sitting for shorts delays and checking the -;; flag. Give up after some time. Typing into the source buffer will cancel -;; waiting, i.e. may report 'No result yet' - -(defun caml-wait-output (&optional before after) - (let ((c 1)) - (caml-sit-for 0 (or before 1)) - (let ((c 1)) - (while (and (not inferior-caml-output) (< c 99) (caml-sit-for 0 c t)) - (setq c (+ c 1)))) - (caml-sit-for (or after 0) 1))) - -;; To insert the last output from caml at point -(defun caml-insert-last-output () - "Insert the result of the evaluation of previous phrase" - (interactive) - (let ((pos (process-mark (get-buffer-process inferior-caml-buffer-name)))) - (insert-buffer-substring inferior-caml-buffer-name - caml-previous-output (- pos 2)))) - -;; additional bindings - -;(let ((map (lookup-key caml-mode-map [menu-bar caml]))) -; (define-key map [indent-buffer] '("Indent buffer" . caml-indent-buffer)) -; (define-key map [eval-buffer] '("Eval buffer" . caml-eval-buffer)) -;) -;(define-key caml-mode-map "\C-c\C-b" 'caml-eval-buffer) - - -(provide 'inf-caml) diff --git a/emacs/ocamltags.in b/emacs/ocamltags.in deleted file mode 100644 index a67565394e..0000000000 --- a/emacs/ocamltags.in +++ /dev/null @@ -1,128 +0,0 @@ -":" ; @EMACS@ -batch -l $0 "$@" ; status=$? ; : '--*-Emacs-Lisp-*--' <<';' - -;; Copyright (C) 1998 Ian Zimmerman -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2 of the -;; License, or (at your option) any later version. - -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. -;; $Id$ - -(require 'caml) - -;;itz Fri Oct 30 13:08:37 PST 1998 support for creating TAGS files -;; itz Sun Dec 27 10:26:08 PST 1998 adapted very slightly from -;; Jacques' caml-create-index-function -(defun caml-tags-create-index-function () - (let (all-alist index) - (goto-char (point-max)) - ;; collect definitions - (while (caml-prev-index-position-function) - (if (looking-at "[ \t]*val") nil - (setq index (cons (caml-match-string 5) (point))) - (setq all-alist (cons index all-alist)))) - all-alist)) - -(defun caml-tags-file (filename) - (let* ((output-buffer (current-buffer)) - (basename (file-name-nondirectory filename)) - (backpatch (prog2 - (insert " \n" basename) - (point)))) - (find-file-read-only filename) - (caml-mode) - (let ((all-alist (caml-tags-create-index-function)) - (done nil) - (current-line 1) - (last-point (point-min))) - (mapcar - (lambda (pair) - (let ((tag-name (car pair)) (tag-pos (cdr pair))) - (goto-char tag-pos) - (setq current-line - (+ current-line (count-lines last-point (point)))) - (setq last-point (point)) - (end-of-line 1) - (let ((output-line (format "%s%s%d,%d\n" - (buffer-substring last-point (point)) - tag-name current-line tag-pos))) - (save-excursion - (set-buffer output-buffer) - (insert output-line))))) - all-alist)) - (kill-buffer (current-buffer)) - (set-buffer output-buffer) - (let ((index-size (- (point) backpatch))) - (goto-char backpatch) - (insert "," (int-to-string index-size) "\n") - (goto-char (point-max))))) - -(defsubst prefix-p (prefix str) - (and (<= (length prefix) (length str)) - (string= prefix (substring str 0 (length prefix))))) - -(defsubst eat-args (n) - (setq command-line-args-left (nthcdr n command-line-args-left))) - -;; see Emacs source file print.c -(defun print-error-message (data) - (let ((errname (car data)) errmsg is-file-error tail i) - (if (eq errname 'error) - (progn - (setq data (cdr data)) - (if (not (consp data)) (setq data nil)) - (setq errmsg (car data)) - (setq is-file-error nil)) - (setq errmsg (get errname 'error-message)) - (setq is-file-error (memq 'file-error (get errname 'error-conditions)))) - (setq tail (cdr-safe data)) - (if (and is-file-error tail) - (setq errmsg (car tail) tail (cdr tail))) - (if (stringp errmsg) (princ errmsg) - (princ "peculiar error")) - (setq i 0) - (while (consp tail) - (princ (if (eq i 0) ": " ", ")) - (if is-file-error (princ (car tail)) - (prin1 (car tail))) - (setq tail (cdr tail) i (1+ i))) - (princ "\n"))) - - -(setq gc-cons-threshold 1000000) - -(setq output-file "TAGS") -(setq append-flag nil) -(setq status 0) - -(condition-case foobar - (progn - (while (and command-line-args-left - (let ((arg (car command-line-args-left))) - (cond - ((prefix-p arg "-output-file") - (setq output-file (nth 1 command-line-args-left)) - (eat-args 2) t) - ((prefix-p arg "-append") - (setq append-flag t) - (eat-args 1) t) - (t nil))))) - - (find-file output-file) - (if append-flag (goto-char (point-max)) - (erase-buffer)) - (while command-line-args-left - (caml-tags-file (car command-line-args-left)) - (setq command-line-args-left (cdr command-line-args-left))) - (save-buffer 0)) - (error (setq status 1) (print-error-message foobar))) - -(kill-emacs status) - -; - -":" ; exit $status diff --git a/lex/.cvsignore b/lex/.cvsignore deleted file mode 100644 index 9f4f308da4..0000000000 --- a/lex/.cvsignore +++ /dev/null @@ -1,6 +0,0 @@ -parser.ml -parser.mli -lexer.ml -ocamllex -ocamllex.opt -parser.output diff --git a/lex/.depend b/lex/.depend deleted file mode 100644 index b21bfd9361..0000000000 --- a/lex/.depend +++ /dev/null @@ -1,32 +0,0 @@ -common.cmi: lexgen.cmi syntax.cmi -compact.cmi: lexgen.cmi -lexer.cmi: parser.cmi -lexgen.cmi: syntax.cmi -output.cmi: common.cmi compact.cmi lexgen.cmi syntax.cmi -outputbis.cmi: common.cmi lexgen.cmi syntax.cmi -parser.cmi: syntax.cmi -syntax.cmi: cset.cmi -common.cmo: lexgen.cmi syntax.cmi common.cmi -common.cmx: lexgen.cmx syntax.cmx common.cmi -compact.cmo: lexgen.cmi table.cmi compact.cmi -compact.cmx: lexgen.cmx table.cmx compact.cmi -cset.cmo: cset.cmi -cset.cmx: cset.cmi -lexer.cmo: parser.cmi syntax.cmi lexer.cmi -lexer.cmx: parser.cmx syntax.cmx lexer.cmi -lexgen.cmo: cset.cmi syntax.cmi table.cmi lexgen.cmi -lexgen.cmx: cset.cmx syntax.cmx table.cmx lexgen.cmi -main.cmo: common.cmi compact.cmi lexer.cmi lexgen.cmi output.cmi \ - outputbis.cmi parser.cmi syntax.cmi -main.cmx: common.cmx compact.cmx lexer.cmx lexgen.cmx output.cmx \ - outputbis.cmx parser.cmx syntax.cmx -output.cmo: common.cmi compact.cmi lexgen.cmi syntax.cmi output.cmi -output.cmx: common.cmx compact.cmx lexgen.cmx syntax.cmx output.cmi -outputbis.cmo: common.cmi lexgen.cmi syntax.cmi outputbis.cmi -outputbis.cmx: common.cmx lexgen.cmx syntax.cmx outputbis.cmi -parser.cmo: cset.cmi syntax.cmi parser.cmi -parser.cmx: cset.cmx syntax.cmx parser.cmi -syntax.cmo: cset.cmi syntax.cmi -syntax.cmx: cset.cmx syntax.cmi -table.cmo: table.cmi -table.cmx: table.cmi diff --git a/lex/Makefile b/lex/Makefile deleted file mode 100644 index 2e593133f2..0000000000 --- a/lex/Makefile +++ /dev/null @@ -1,71 +0,0 @@ -######################################################################### -# # -# Objective Caml # -# # -# Xavier Leroy, projet Cristal, INRIA Rocquencourt # -# # -# Copyright 1999 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### - -# $Id$ - -# The lexer generator -CAMLC=../boot/ocamlrun ../boot/ocamlc -nostdlib -I ../boot -CAMLOPT=../boot/ocamlrun ../ocamlopt -nostdlib -I ../stdlib -COMPFLAGS=-warn-error A -CAMLYACC=../boot/ocamlyacc -YACCFLAGS=-v -CAMLLEX=../boot/ocamlrun ../boot/ocamllex -CAMLDEP=../boot/ocamlrun ../tools/ocamldep - - -OBJS=cset.cmo syntax.cmo parser.cmo lexer.cmo table.cmo lexgen.cmo compact.cmo common.cmo output.cmo outputbis.cmo main.cmo - -all: ocamllex -allopt: ocamllex.opt - -ocamllex: $(OBJS) - $(CAMLC) $(LINKFLAGS) -o ocamllex $(OBJS) - -ocamllex.opt: $(OBJS:.cmo=.cmx) - $(CAMLOPT) -o ocamllex.opt $(OBJS:.cmo=.cmx) - -clean:: - rm -f ocamllex ocamllex.opt - rm -f *.cmo *.cmi *.cmx *.o *~ - -parser.ml parser.mli: parser.mly - $(CAMLYACC) $(YACCFLAGS) parser.mly - -clean:: - rm -f parser.ml parser.mli parser.output - -beforedepend:: parser.ml parser.mli - -lexer.ml: lexer.mll - $(CAMLLEX) lexer.mll - -clean:: - rm -f lexer.ml - -beforedepend:: lexer.ml - -.SUFFIXES: -.SUFFIXES: .ml .cmo .mli .cmi .cmx - -.ml.cmo: - $(CAMLC) -c $(COMPFLAGS) $< - -.mli.cmi: - $(CAMLC) -c $(COMPFLAGS) $< - -.ml.cmx: - $(CAMLOPT) -c $(COMPFLAGS) $< - -depend: beforedepend - $(CAMLDEP) *.mli *.ml > .depend - -include .depend diff --git a/lex/Makefile.Mac b/lex/Makefile.Mac deleted file mode 100644 index 4640011d08..0000000000 --- a/lex/Makefile.Mac +++ /dev/null @@ -1,63 +0,0 @@ -######################################################################### -# # -# Objective Caml # -# # -# Damien Doligez, projet Para, INRIA Rocquencourt # -# # -# Copyright 1999 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### - -# $Id$ - -# The lexer generator - -CAMLC = ::boot:ocamlrun ::boot:ocamlc -I ::boot: -COMPFLAGS = -LINKFLAGS = -CAMLYACC = ::boot:ocamlyacc -YACCFLAGS = -CAMLLEX = ::boot:ocamlrun ::boot:ocamllex -CAMLDEP = ::boot:ocamlrun ::tools:ocamldep -DEPFLAGS = - -OBJS = parser.cmo lexer.cmo lexgen.cmo compact.cmo output.cmo main.cmo - -all Ä ocamllex - -ocamllex Ä {OBJS} - {CAMLC} {LINKFLAGS} -o ocamllex {OBJS} - -clean ÄÄ - delete -i ocamllex - delete -i Å.cm[io] || set status 0 - -parser.mli Ä parser.ml - echo -n - -parser.ml Ä parser.mly - {CAMLYACC} {YACCFLAGS} parser.mly - -clean ÄÄ - delete -i parser.ml parser.mli - -beforedepend ÄÄ parser.ml parser.mli - -lexer.ml Ä lexer.mll - {CAMLLEX} lexer.mll - -clean ÄÄ - delete -i lexer.ml - -beforedepend ÄÄ lexer.ml - -.cmo Ä .ml - {CAMLC} -c {COMPFLAGS} {default}.ml - -.cmi Ä .mli - {CAMLC} -c {COMPFLAGS} {default}.mli - -depend Ä beforedepend - {CAMLDEP} Å.mli Å.ml > Makefile.Mac.depend diff --git a/lex/Makefile.Mac.depend b/lex/Makefile.Mac.depend deleted file mode 100644 index 73e2f7f32e..0000000000 --- a/lex/Makefile.Mac.depend +++ /dev/null @@ -1,17 +0,0 @@ -compact.cmiÄ lexgen.cmi -lexer.cmiÄ parser.cmi -lexgen.cmiÄ syntax.cmi -output.cmiÄ compact.cmi lexgen.cmi syntax.cmi -parser.cmiÄ syntax.cmi -compact.cmoÄ lexgen.cmi compact.cmi -compact.cmxÄ lexgen.cmx compact.cmi -lexer.cmoÄ parser.cmi syntax.cmi lexer.cmi -lexer.cmxÄ parser.cmx syntax.cmi lexer.cmi -lexgen.cmoÄ syntax.cmi lexgen.cmi -lexgen.cmxÄ syntax.cmi lexgen.cmi -main.cmoÄ compact.cmi lexer.cmi lexgen.cmi output.cmi parser.cmi syntax.cmi -main.cmxÄ compact.cmx lexer.cmx lexgen.cmx output.cmx parser.cmx syntax.cmi -output.cmoÄ compact.cmi lexgen.cmi syntax.cmi output.cmi -output.cmxÄ compact.cmx lexgen.cmx syntax.cmi output.cmi -parser.cmoÄ syntax.cmi parser.cmi -parser.cmxÄ syntax.cmi parser.cmi diff --git a/lex/Makefile.nt b/lex/Makefile.nt deleted file mode 100644 index ab2a42a109..0000000000 --- a/lex/Makefile.nt +++ /dev/null @@ -1,73 +0,0 @@ -######################################################################### -# # -# Objective Caml # -# # -# Xavier Leroy, projet Cristal, INRIA Rocquencourt # -# # -# Copyright 1999 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### - -# $Id$ - -# The lexer generator - -CAMLC=../boot/ocamlrun ../boot/ocamlc -I ../boot -CAMLOPT=../boot/ocamlrun ../ocamlopt -I ../stdlib -COMPFLAGS=-warn-error A -LINKFLAGS= -CAMLYACC=../boot/ocamlyacc -YACCFLAGS=-v -CAMLLEX=../boot/ocamlrun ../boot/ocamllex -CAMLDEP=../boot/ocamlrun ../tools/ocamldep -DEPFLAGS= - -OBJS=cset.cmo syntax.cmo parser.cmo lexer.cmo table.cmo lexgen.cmo compact.cmo common.cmo output.cmo outputbis.cmo main.cmo - -all: ocamllex syntax.cmo -allopt: ocamllex.opt - -ocamllex: $(OBJS) - $(CAMLC) $(LINKFLAGS) -o ocamllex $(OBJS) - -ocamllex.opt: $(OBJS:.cmo=.cmx) - $(CAMLOPT) -o ocamllex.opt $(OBJS:.cmo=.cmx) - -clean:: - rm -f ocamllex ocamllex.opt - rm -f *.cmo *.cmi *.cmx *.$(O) - -parser.ml parser.mli: parser.mly - $(CAMLYACC) $(YACCFLAGS) parser.mly - -clean:: - rm -f parser.ml parser.mli - -beforedepend:: parser.ml parser.mli - -lexer.ml: lexer.mll - $(CAMLLEX) lexer.mll - -clean:: - rm -f lexer.ml - -beforedepend:: lexer.ml - -.SUFFIXES: -.SUFFIXES: .ml .cmo .mli .cmi .cmx - -.ml.cmo: - $(CAMLC) -c $(COMPFLAGS) $< - -.mli.cmi: - $(CAMLC) -c $(COMPFLAGS) $< - -.ml.cmx: - $(CAMLOPT) -c $(COMPFLAGS) $< - -depend: beforedepend - $(CAMLDEP) *.mli *.ml > .depend - -include .depend diff --git a/lex/common.ml b/lex/common.ml deleted file mode 100644 index f56e7a869d..0000000000 --- a/lex/common.ml +++ /dev/null @@ -1,153 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Luc Maranget, projet Moscova, *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -open Printf -open Syntax -open Lexgen - - -(* To copy the ML code fragments *) - -type line_tracker = { - file : string; - oc : out_channel; - ic : in_channel; - mutable cur_line : int; -};; - -let open_tracker file oc = { - file = file; - oc = oc; - ic = open_in_bin file; - cur_line = 1; -};; - -let close_tracker tr = close_in_noerr tr.ic;; - -let update_tracker tr = - fprintf tr.oc "\n"; - flush tr.oc; - let cr_seen = ref false in - try while true do - match input_char tr.ic with - | '\010' when not !cr_seen -> tr.cur_line <- tr.cur_line + 1; - | '\013' -> cr_seen := true; tr.cur_line <- tr.cur_line + 1; - | _ -> cr_seen := false; - done with End_of_file -> - fprintf tr.oc "# %d \"%s\"\n" (tr.cur_line+1) tr.file; -;; - -let copy_buffer = String.create 1024 - -let copy_chars_unix ic oc start stop = - let n = ref (stop - start) in - while !n > 0 do - let m = input ic copy_buffer 0 (min !n 1024) in - output oc copy_buffer 0 m; - n := !n - m - done - -let copy_chars_win32 ic oc start stop = - for i = start to stop - 1 do - let c = input_char ic in - if c <> '\r' then output_char oc c - done - -let copy_chars = - match Sys.os_type with - "Win32" | "Cygwin" -> copy_chars_win32 - | _ -> copy_chars_unix - -let copy_chunk sourcefile ic oc trl loc add_parens = - if loc.start_pos < loc.end_pos || add_parens then begin - fprintf oc "# %d \"%s\"\n" loc.start_line sourcefile; - if add_parens then begin - for i = 1 to loc.start_col - 1 do output_char oc ' ' done; - output_char oc '('; - end else begin - for i = 1 to loc.start_col do output_char oc ' ' done; - end; - seek_in ic loc.start_pos; - copy_chars ic oc loc.start_pos loc.end_pos; - if add_parens then output_char oc ')'; - update_tracker trl; - end - -(* Various memory actions *) - -let output_mem_access oc i = fprintf oc "lexbuf.Lexing.lex_mem.(%d)" i - -let output_memory_actions pref oc = function - | [] -> () - | mvs -> - output_string oc "(* " ; - fprintf oc "L=%d " (List.length mvs) ; - List.iter - (fun mv -> match mv with - | Copy (tgt, src) -> - fprintf oc "[%d] <- [%d] ;" tgt src - | Set tgt -> - fprintf oc "[%d] <- p ; " tgt) - mvs ; - output_string oc " *)\n" ; - List.iter - (fun mv -> match mv with - | Copy (tgt, src) -> - fprintf oc - "%s%a <- %a ;\n" - pref output_mem_access tgt output_mem_access src - | Set tgt -> - fprintf oc "%s%a <- lexbuf.Lexing.lex_curr_pos ;\n" - pref output_mem_access tgt) - mvs - -let output_base_mem oc = function - | Mem i -> output_mem_access oc i - | Start -> fprintf oc "lexbuf.Lexing.lex_start_pos" - | End -> fprintf oc "lexbuf.Lexing.lex_curr_pos" - -let output_tag_access oc = function - | Sum (a,0) -> - output_base_mem oc a - | Sum (a,i) -> - fprintf oc "(%a + %d)" output_base_mem a i - -let output_env oc env = - let pref = ref "let" in - match env with - | [] -> () - | _ -> - List.iter - (fun (x,v) -> - begin match v with - | Ident_string (o,nstart,nend) -> - fprintf oc - "\n %s %s = Lexing.sub_lexeme%s lexbuf %a %a" - !pref x (if o then "_opt" else "") - output_tag_access nstart output_tag_access nend - | Ident_char (o,nstart) -> - fprintf oc - "\n %s %s = Lexing.sub_lexeme_char%s lexbuf %a" - !pref x (if o then "_opt" else "") - output_tag_access nstart - end ; - pref := "and") - env ; - fprintf oc " in\n" - -(* Output the user arguments *) -let output_args oc args = - List.iter (fun x -> (output_string oc x; output_char oc ' ')) args - -(* quiet flag *) -let quiet_mode = ref false;; diff --git a/lex/common.mli b/lex/common.mli deleted file mode 100644 index 4210d21d88..0000000000 --- a/lex/common.mli +++ /dev/null @@ -1,25 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Damien Doligez, projet Moscova, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -type line_tracker;; -val open_tracker : string -> out_channel -> line_tracker -val close_tracker : line_tracker -> unit -val copy_chunk : - string -> - in_channel -> out_channel -> line_tracker -> Syntax.location -> bool -> unit -val output_mem_access : out_channel -> int -> unit -val output_memory_actions : - string -> out_channel -> Lexgen.memory_action list -> unit -val output_env : out_channel -> (string * Lexgen.ident_info) list -> unit -val output_args : out_channel -> string list -> unit - -val quiet_mode : bool ref;; diff --git a/lex/compact.ml b/lex/compact.ml deleted file mode 100644 index 9475ab6e57..0000000000 --- a/lex/compact.ml +++ /dev/null @@ -1,234 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* Compaction of an automata *) - -open Lexgen - -(* Code for memory actions *) -let code = Table.create 0 - -(* instructions are 2 8-bits integers, a 0xff byte means return *) - -let emit_int i = Table.emit code i - -let ins_mem i c = match i with - | Copy (dst, src) -> dst::src::c - | Set dst -> dst::0xff::c - - -let ins_tag i c = match i with - | SetTag (dst, src) -> dst::src::c - | EraseTag dst -> dst::0xff::c - - -let do_emit_code c = - let r = Table.size code in - List.iter emit_int c ; - emit_int 0xff ; - r - -let memory = Hashtbl.create 101 - -let mem_emit_code c = - try Hashtbl.find memory c with - | Not_found -> - let r = do_emit_code c in - Hashtbl.add memory c r ; - r - -(* Code address 0 is the empty code (ie do nothing) *) -let _ = mem_emit_code [] - -let emit_tag_code c = mem_emit_code (List.fold_right ins_tag c []) -and emit_mem_code c =mem_emit_code (List.fold_right ins_mem c []) - -(*******************************************) -(* Compact the transition and check arrays *) -(*******************************************) - - -(* Determine the integer occurring most frequently in an array *) - -let most_frequent_elt v = - let frequencies = Hashtbl.create 17 in - let max_freq = ref 0 in - let most_freq = ref (v.(0)) in - for i = 0 to Array.length v - 1 do - let e = v.(i) in - let r = - try - Hashtbl.find frequencies e - with Not_found -> - let r = ref 1 in Hashtbl.add frequencies e r; r in - incr r; - if !r > !max_freq then begin max_freq := !r; most_freq := e end - done; - !most_freq - -(* Transform an array into a list of (position, non-default element) *) - -let non_default_elements def v = - let rec nondef i = - if i >= Array.length v then [] else begin - let e = v.(i) in - if e = def then nondef(i+1) else (i, e) :: nondef(i+1) - end in - nondef 0 - - -type t_compact = - {mutable c_trans : int array ; - mutable c_check : int array ; - mutable c_last_used : int ; } - -let create_compact () = - { c_trans = Array.create 1024 0 ; - c_check = Array.create 1024 (-1) ; - c_last_used = 0 ; } - -let reset_compact c = - c.c_trans <- Array.create 1024 0 ; - c.c_check <- Array.create 1024 (-1) ; - c.c_last_used <- 0 - -(* One compacted table for transitions, one other for memory actions *) -let trans = create_compact () -and moves = create_compact () - - -let grow_compact c = - let old_trans = c.c_trans - and old_check = c.c_check in - let n = Array.length old_trans in - c.c_trans <- Array.create (2*n) 0; - Array.blit old_trans 0 c.c_trans 0 c.c_last_used; - c.c_check <- Array.create (2*n) (-1); - Array.blit old_check 0 c.c_check 0 c.c_last_used - -let do_pack state_num orig compact = - let default = most_frequent_elt orig in - let nondef = non_default_elements default orig in - let rec pack_from b = - while - b + 257 > Array.length compact.c_trans - do - grow_compact compact - done; - let rec try_pack = function - [] -> b - | (pos, v) :: rem -> - if compact.c_check.(b + pos) = -1 then - try_pack rem - else pack_from (b+1) in - try_pack nondef in - let base = pack_from 0 in - List.iter - (fun (pos, v) -> - compact.c_trans.(base + pos) <- v; - compact.c_check.(base + pos) <- state_num) - nondef; - if base + 257 > compact.c_last_used then - compact.c_last_used <- base + 257; - (base, default) - -let pack_moves state_num move_t = - let move_v = Array.create 257 0 - and move_m = Array.create 257 0 in - for i = 0 to 256 do - let act,c = move_t.(i) in - move_v.(i) <- (match act with Backtrack -> -1 | Goto n -> n) ; - move_m.(i) <- emit_mem_code c - done ; - let pk_trans = do_pack state_num move_v trans - and pk_moves = do_pack state_num move_m moves in - pk_trans, pk_moves - - -(* Build the tables *) - -type lex_tables = - { tbl_base: int array; (* Perform / Shift *) - tbl_backtrk: int array; (* No_remember / Remember *) - tbl_default: int array; (* Default transition *) - tbl_trans: int array; (* Transitions (compacted) *) - tbl_check: int array; (* Check (compacted) *) -(* code addresses are managed in a similar fashion as transitions *) - tbl_base_code : int array; (* code ptr / base for Shift *) - tbl_backtrk_code : int array; (* nothing / code when Remember *) -(* moves to execute before transitions (compacted) *) - tbl_default_code : int array; - tbl_trans_code : int array; - tbl_check_code : int array; -(* byte code itself *) - tbl_code: int array;} - - -let compact_tables state_v = - let n = Array.length state_v in - let base = Array.create n 0 - and backtrk = Array.create n (-1) - and default = Array.create n 0 - and base_code = Array.create n 0 - and backtrk_code = Array.create n 0 - and default_code = Array.create n 0 in - for i = 0 to n - 1 do - match state_v.(i) with - | Perform (n,c) -> - base.(i) <- -(n+1) ; - base_code.(i) <- emit_tag_code c - | Shift(trans, move) -> - begin match trans with - | No_remember -> () - | Remember (n,c) -> - backtrk.(i) <- n ; - backtrk_code.(i) <- emit_tag_code c - end; - let (b_trans, d_trans),(b_moves,d_moves) = pack_moves i move in - base.(i) <- b_trans; default.(i) <- d_trans ; - base_code.(i) <- b_moves; default_code.(i) <- d_moves ; - done; - let code = Table.trim code in - let tables = - if Array.length code > 1 then - { tbl_base = base; - tbl_backtrk = backtrk; - tbl_default = default; - tbl_trans = Array.sub trans.c_trans 0 trans.c_last_used; - tbl_check = Array.sub trans.c_check 0 trans.c_last_used; - tbl_base_code = base_code ; - tbl_backtrk_code = backtrk_code; - tbl_default_code = default_code; - tbl_trans_code = Array.sub moves.c_trans 0 moves.c_last_used; - tbl_check_code = Array.sub moves.c_check 0 moves.c_last_used; - tbl_code = code} - else (* when no memory moves, do not emit related tables *) - { tbl_base = base; - tbl_backtrk = backtrk; - tbl_default = default; - tbl_trans = Array.sub trans.c_trans 0 trans.c_last_used; - tbl_check = Array.sub trans.c_check 0 trans.c_last_used; - tbl_base_code = [||] ; - tbl_backtrk_code = [||]; - tbl_default_code = [||]; - tbl_trans_code = [||]; - tbl_check_code = [||]; - tbl_code = [||]} - in - reset_compact trans ; - reset_compact moves ; - tables - - - diff --git a/lex/compact.mli b/lex/compact.mli deleted file mode 100644 index e52dc7d2c8..0000000000 --- a/lex/compact.mli +++ /dev/null @@ -1,33 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* Compaction of an automata *) -type lex_tables = - { tbl_base: int array; (* Perform / Shift *) - tbl_backtrk: int array; (* No_remember / Remember *) - tbl_default: int array; (* Default transition *) - tbl_trans: int array; (* Transitions (compacted) *) - tbl_check: int array; (* Check (compacted) *) -(* code addresses are managed in a similar fashion as transitions *) - tbl_base_code : int array; (* code ptr / base for Shift *) - tbl_backtrk_code : int array; (* nothing / code when Remember *) -(* moves to execute before transitions (compacted) *) - tbl_default_code : int array; - tbl_trans_code : int array; - tbl_check_code : int array; -(* byte code itself *) - tbl_code: int array;} - - -val compact_tables: Lexgen.automata array -> lex_tables diff --git a/lex/cset.ml b/lex/cset.ml deleted file mode 100644 index 84c2a77142..0000000000 --- a/lex/cset.ml +++ /dev/null @@ -1,94 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Luc Maranget, Jerome Vouillon projet Cristal, *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -type t = (int * int) list - - -let empty = [] -let is_empty = function - | [] -> true - | _ -> false - -let singleton c = [c,c] - -let interval c1 c2 = - if c1 <= c2 then [c1,c2] - else [c2,c1] - - -let rec union s1 s2 = match s1,s2 with -| [],_ -> s2 -| _,[] -> s1 -| (c1,d1) as p1::r1, (c2,d2)::r2 -> - if c1 > c2 then - union s2 s1 - else begin (* c1 <= c2 *) - if d1+1 < c2 then - p1::union r1 s2 - else if d1 < d2 then - union ((c1,d2)::r2) r1 - else - union s1 r2 - end - -let rec inter l l' = match l, l' with - _, [] -> [] - | [], _ -> [] - | (c1, c2)::r, (c1', c2')::r' -> - if c2 < c1' then - inter r l' - else if c2' < c1 then - inter l r' - else if c2 < c2' then - (max c1 c1', c2)::inter r l' - else - (max c1 c1', c2')::inter l r' - -let rec diff l l' = match l, l' with - _, [] -> l - | [], _ -> [] - | (c1, c2)::r, (c1', c2')::r' -> - if c2 < c1' then - (c1, c2)::diff r l' - else if c2' < c1 then - diff l r' - else - let r'' = if c2' < c2 then (c2' + 1, c2) :: r else r in - if c1 < c1' then - (c1, c1' - 1)::diff r'' r' - else - diff r'' r' - - -let eof = singleton 256 -and all_chars = interval 0 255 -and all_chars_eof = interval 0 256 - -let complement s = diff all_chars s - -let env_to_array env = match env with -| [] -> assert false -| (_,x)::rem -> - let res = Array.create 257 x in - List.iter - (fun (c,y) -> - List.iter - (fun (i,j) -> - for k=i to j do - res.(k) <- y - done) - c) - rem ; - res - - diff --git a/lex/cset.mli b/lex/cset.mli deleted file mode 100644 index 0ebcac0e5f..0000000000 --- a/lex/cset.mli +++ /dev/null @@ -1,32 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Luc Maranget, Jerome Vouillon projet Cristal, *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* Set of characters encoded as list of intervals *) - -type t - -val empty : t -val is_empty : t -> bool -val all_chars : t -val all_chars_eof : t -val eof : t -val singleton : int -> t -val interval : int -> int -> t -val union : t -> t -> t -val inter : t -> t -> t -val diff : t -> t -> t -val complement : t -> t -val env_to_array : (t * 'a) list -> 'a array - - - diff --git a/lex/lexer.mli b/lex/lexer.mli deleted file mode 100644 index 569a5b266f..0000000000 --- a/lex/lexer.mli +++ /dev/null @@ -1,20 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -val main: Lexing.lexbuf -> Parser.token - -exception Lexical_error of string * int * int - -val line_num: int ref -val line_start_pos: int ref diff --git a/lex/lexer.mll b/lex/lexer.mll deleted file mode 100644 index 5249ca8bc0..0000000000 --- a/lex/lexer.mll +++ /dev/null @@ -1,273 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* The lexical analyzer for lexer definitions. Bootstrapped! *) - -{ -open Syntax -open Parser - -(* Auxiliaries for the lexical analyzer *) - -let brace_depth = ref 0 -and comment_depth = ref 0 - -let in_pattern () = !brace_depth = 0 && !comment_depth = 0 - -exception Lexical_error of string * int * int - -let string_buff = Buffer.create 256 - -let reset_string_buffer () = Buffer.clear string_buff - -let store_string_char c = Buffer.add_char string_buff c - -let get_stored_string () = Buffer.contents string_buff - -let char_for_backslash = function - 'n' -> '\n' - | 't' -> '\t' - | 'b' -> '\b' - | 'r' -> '\r' - | c -> c - - -let line_num = ref 1 -let line_start_pos = ref 0 - -let handle_lexical_error fn lexbuf = - let line = !line_num - and column = Lexing.lexeme_start lexbuf - !line_start_pos + 1 in - try - fn lexbuf - with Lexical_error (msg, 0, 0) -> - raise(Lexical_error(msg, line, column)) - -let get_input_name () = Sys.argv.(Array.length Sys.argv - 1) - -let warning lexbuf msg = - Printf.eprintf "ocamllex warning:\nFile \"%s\", line %d, character %d: %s.\n" - (get_input_name ()) !line_num - (Lexing.lexeme_start lexbuf - !line_start_pos+1) msg; - flush stderr - -let decimal_code c d u = - 100 * (Char.code c - 48) + 10 * (Char.code d - 48) + (Char.code u - 48) - -let char_for_hexadecimal_code d u = - let d1 = Char.code d in - let val1 = if d1 >= 97 then d1 - 87 - else if d1 >= 65 then d1 - 55 - else d1 - 48 - in - let d2 = Char.code u in - let val2 = if d2 >= 97 then d2 - 87 - else if d2 >= 65 then d2 - 55 - else d2 - 48 - in - Char.chr (val1 * 16 + val2) - -} - -let identstart = - ['A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255'] -let identbody = - ['A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255' '\'' '0'-'9'] -let backslash_escapes = - ['\\' '"' '\'' 'n' 't' 'b' 'r'] - -rule main = parse - [' ' '\013' '\009' '\012' ] + - { main lexbuf } - | '\010' - { line_start_pos := Lexing.lexeme_end lexbuf; - incr line_num; - main lexbuf } - | "(*" - { comment_depth := 1; - handle_lexical_error comment lexbuf; - main lexbuf } - | '_' { Tunderscore } - | identstart identbody * - { match Lexing.lexeme lexbuf with - "rule" -> Trule - | "parse" -> Tparse - | "shortest" -> Tparse_shortest - | "and" -> Tand - | "eof" -> Teof - | "let" -> Tlet - | "as" -> Tas - | s -> Tident s } - | '"' - { reset_string_buffer(); - handle_lexical_error string lexbuf; - Tstring(get_stored_string()) } -(* note: ''' is a valid character literall (by contrast with the compiler) *) - | "'" [^ '\\'] "'" - { Tchar(Char.code(Lexing.lexeme_char lexbuf 1)) } - | "'" '\\' backslash_escapes "'" - { Tchar(Char.code(char_for_backslash (Lexing.lexeme_char lexbuf 2))) } - | "'" '\\' (['0'-'9'] as c) (['0'-'9'] as d) (['0'-'9'] as u)"'" - { let v = decimal_code c d u in - if v > 255 then - raise - (Lexical_error - (Printf.sprintf "illegal escape sequence \\%c%c%c" c d u, - !line_num, Lexing.lexeme_start lexbuf - !line_start_pos+1)) - else - Tchar v } - | "'" '\\' 'x' - (['0'-'9' 'a'-'f' 'A'-'F'] as d) (['0'-'9' 'a'-'f' 'A'-'F'] as u) "'" - { Tchar(Char.code(char_for_hexadecimal_code d u)) } - | "'" '\\' (_ as c) - { raise - (Lexical_error - (Printf.sprintf "illegal escape sequence \\%c" c, - !line_num, Lexing.lexeme_start lexbuf - !line_start_pos+1)) - } - | '{' - { let n1 = Lexing.lexeme_end lexbuf - and l1 = !line_num - and s1 = !line_start_pos in - brace_depth := 1; - let n2 = handle_lexical_error action lexbuf in - Taction({start_pos = n1; end_pos = n2; - start_line = l1; start_col = n1 - s1}) } - | '=' { Tequal } - | '|' { Tor } - | '[' { Tlbracket } - | ']' { Trbracket } - | '*' { Tstar } - | '?' { Tmaybe } - | '+' { Tplus } - | '(' { Tlparen } - | ')' { Trparen } - | '^' { Tcaret } - | '-' { Tdash } - | eof { Tend } - | _ - { raise(Lexical_error - ("illegal character " ^ String.escaped(Lexing.lexeme lexbuf), - !line_num, Lexing.lexeme_start lexbuf - !line_start_pos+1)) } - - -(* String parsing comes from the compiler lexer *) -and string = parse - '"' - { () } - | '\\' ("\010" | "\013" | "\013\010") [' ' '\009'] * - { line_start_pos := Lexing.lexeme_end lexbuf; - incr line_num; - string lexbuf } - | '\\' (backslash_escapes as c) - { store_string_char(char_for_backslash c); - string lexbuf } - | '\\' (['0'-'9'] as c) (['0'-'9'] as d) (['0'-'9'] as u) - { let v = decimal_code c d u in - if in_pattern () && v > 255 then - warning lexbuf - (Printf.sprintf - "illegal backslash escape in string: `\\%c%c%c'" c d u) ; - store_string_char (Char.chr v); - string lexbuf } - | '\\' 'x' (['0'-'9' 'a'-'f' 'A'-'F'] as d) (['0'-'9' 'a'-'f' 'A'-'F'] as u) - { store_string_char (char_for_hexadecimal_code d u) ; - string lexbuf } - | '\\' (_ as c) - {if in_pattern () then - warning lexbuf - (Printf.sprintf "illegal backslash escape in string: `\\%c'" c) ; - store_string_char '\\' ; - store_string_char c ; - string lexbuf } - | eof - { raise(Lexical_error("unterminated string", 0, 0)) } - | '\010' - { store_string_char '\010'; - line_start_pos := Lexing.lexeme_end lexbuf; - incr line_num; - string lexbuf } - | _ as c - { store_string_char c; - string lexbuf } - -(* - Lexers comment and action are quite similar, - they should lex both strings and characters, - in order not to be confused by what is inside then -*) - -and comment = parse - "(*" - { incr comment_depth; comment lexbuf } - | "*)" - { decr comment_depth; - if !comment_depth = 0 then () else comment lexbuf } - | '"' - { reset_string_buffer(); - string lexbuf; - reset_string_buffer(); - comment lexbuf } - | "'" - { skip_char lexbuf ; - comment lexbuf } - | eof - { raise(Lexical_error("unterminated comment", 0, 0)) } - | '\010' - { line_start_pos := Lexing.lexeme_end lexbuf; - incr line_num; - comment lexbuf } - | _ - { comment lexbuf } - -and action = parse - '{' - { incr brace_depth; - action lexbuf } - | '}' - { decr brace_depth; - if !brace_depth = 0 then Lexing.lexeme_start lexbuf else action lexbuf } - | '"' - { reset_string_buffer(); - handle_lexical_error string lexbuf; - reset_string_buffer(); - action lexbuf } - | "'" - { skip_char lexbuf ; - action lexbuf } - | "(*" - { comment_depth := 1; - comment lexbuf; - action lexbuf } - | eof - { raise (Lexical_error("unterminated action", 0, 0)) } - | '\010' - { line_start_pos := Lexing.lexeme_end lexbuf; - incr line_num; - action lexbuf } - | _ - { action lexbuf } - -and skip_char = parse - | '\\'? '\010' "'" - { line_start_pos := Lexing.lexeme_end lexbuf; - incr line_num } - | [^ '\\' '\''] "'" (* regular character *) -(* one character and numeric escape sequences *) - | '\\' _ "'" - | '\\' ['0'-'9'] ['0'-'9'] ['0'-'9'] "'" - | '\\' 'x' ['0'-'9' 'a'-'f' 'A'-'F'] ['0'-'9' 'a'-'f' 'A'-'F'] "'" - {()} -(* A dieu va ! *) - | "" {()} diff --git a/lex/lexgen.ml b/lex/lexgen.ml deleted file mode 100644 index ccd82d95a0..0000000000 --- a/lex/lexgen.ml +++ /dev/null @@ -1,1174 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Xavier Leroy, projet Cristal, *) -(* Luc Maranget, projet Moscova, *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* Compiling a lexer definition *) - -open Syntax -open Printf - -exception Memory_overflow - -(* Deep abstract syntax for regular expressions *) - -type tag_info = {id : string ; start : bool ; action : int} - -type regexp = - Empty - | Chars of int * bool - | Action of int - | Tag of tag_info - | Seq of regexp * regexp - | Alt of regexp * regexp - | Star of regexp - -type tag_base = Start | End | Mem of int -type tag_addr = Sum of (tag_base * int) -type ident_info = - | Ident_string of bool * tag_addr * tag_addr - | Ident_char of bool * tag_addr -type t_env = (string * ident_info) list - -type ('args,'action) lexer_entry = - { lex_name: string; - lex_regexp: regexp; - lex_mem_tags: int ; - lex_actions: (int * t_env * 'action) list } - - -type automata = - Perform of int * tag_action list - | Shift of automata_trans * (automata_move * memory_action list) array - -and automata_trans = - No_remember - | Remember of int * tag_action list - -and automata_move = - Backtrack - | Goto of int - -and memory_action = - | Copy of int * int - | Set of int - -and tag_action = SetTag of int * int | EraseTag of int - -(* Representation of entry points *) - -type ('args,'action) automata_entry = - { auto_name: string; - auto_args: 'args ; - auto_mem_size : int ; - auto_initial_state: int * memory_action list; - auto_actions: (int * t_env * 'action) list } - - -(* A lot of sets and map structures *) - -module Ints = Set.Make(struct type t = int let compare = compare end) - -module Tags = Set.Make(struct type t = tag_info let compare = compare end) - -module TagMap = - Map.Make (struct type t = tag_info let compare = compare end) - -module StringSet = - Set.Make (struct type t = string let compare = Pervasives.compare end) -module StringMap = - Map.Make (struct type t = string let compare = Pervasives.compare end) - -(*********************) -(* Variable cleaning *) -(*********************) - -(* Silently eliminate nested variables *) - -let rec do_remove_nested to_remove = function - | Bind (e,x) -> - if StringSet.mem x to_remove then - do_remove_nested to_remove e - else - Bind (do_remove_nested (StringSet.add x to_remove) e, x) - | Epsilon|Eof|Characters _ as e -> e - | Sequence (e1, e2) -> - Sequence - (do_remove_nested to_remove e1, do_remove_nested to_remove e2) - | Alternative (e1, e2) -> - Alternative - (do_remove_nested to_remove e1, do_remove_nested to_remove e2) - | Repetition e -> - Repetition (do_remove_nested to_remove e) - -let remove_nested_as e = do_remove_nested StringSet.empty e - -(*********************) -(* Variable analysis *) -(*********************) - -(* - Optional variables. - A variable is optional when matching of regexp does not - implies it binds. - The typical case is: - ("" | 'a' as x) -> optional - ("" as x | 'a' as x) -> non-optional -*) - -let stringset_delta s1 s2 = - StringSet.union - (StringSet.diff s1 s2) - (StringSet.diff s2 s1) - -let rec find_all_vars = function - | Characters _|Epsilon|Eof -> - StringSet.empty - | Bind (e,x) -> - StringSet.add x (find_all_vars e) - | Sequence (e1,e2)|Alternative (e1,e2) -> - StringSet.union (find_all_vars e1) (find_all_vars e2) - | Repetition e -> find_all_vars e - - -let rec do_find_opt = function - | Characters _|Epsilon|Eof -> StringSet.empty, StringSet.empty - | Bind (e,x) -> - let opt,all = do_find_opt e in - opt, StringSet.add x all - | Sequence (e1,e2) -> - let opt1,all1 = do_find_opt e1 - and opt2,all2 = do_find_opt e2 in - StringSet.union opt1 opt2, StringSet.union all1 all2 - | Alternative (e1,e2) -> - let opt1,all1 = do_find_opt e1 - and opt2,all2 = do_find_opt e2 in - StringSet.union - (stringset_delta opt1 opt2) - (stringset_delta all1 all2), - StringSet.union all1 all2 - | Repetition e -> - let r = find_all_vars e in - r,r - -let find_optional e = - let r,_ = do_find_opt e in r - -(* - Double variables - A variable is double when it can be bound more than once - in a single matching - The typical case is: - (e1 as x) (e2 as x) - -*) - -let rec do_find_double = function - | Characters _|Epsilon|Eof -> StringSet.empty, StringSet.empty - | Bind (e,x) -> - let dbl,all = do_find_double e in - (if StringSet.mem x all then - StringSet.add x dbl - else - dbl), - StringSet.add x all - | Sequence (e1,e2) -> - let dbl1, all1 = do_find_double e1 - and dbl2, all2 = do_find_double e2 in - StringSet.union - (StringSet.inter all1 all2) - (StringSet.union dbl1 dbl2), - StringSet.union all1 all2 - | Alternative (e1,e2) -> - let dbl1, all1 = do_find_double e1 - and dbl2, all2 = do_find_double e2 in - StringSet.union dbl1 dbl2, - StringSet.union all1 all2 - | Repetition e -> - let r = find_all_vars e in - r,r - -let find_double e = do_find_double e - -(* - Type of variables: - A variable is bound to a char when all its occurences - bind a pattern of length 1. - The typical case is: - (_ as x) -> char -*) - -let add_some x = function - | Some i -> Some (x+i) - | None -> None - -let add_some_some x y = match x,y with -| Some i, Some j -> Some (i+j) -| _,_ -> None - -let rec do_find_chars sz = function - | Epsilon|Eof -> StringSet.empty, StringSet.empty, sz - | Characters _ -> StringSet.empty, StringSet.empty, add_some 1 sz - | Bind (e,x) -> - let c,s,e_sz = do_find_chars (Some 0) e in - begin match e_sz with - | Some 1 -> - StringSet.add x c,s,add_some 1 sz - | _ -> - c, StringSet.add x s, add_some_some sz e_sz - end - | Sequence (e1,e2) -> - let c1,s1,sz1 = do_find_chars sz e1 in - let c2,s2,sz2 = do_find_chars sz1 e2 in - StringSet.union c1 c2, - StringSet.union s1 s2, - sz2 - | Alternative (e1,e2) -> - let c1,s1,sz1 = do_find_chars sz e1 - and c2,s2,sz2 = do_find_chars sz e2 in - StringSet.union c1 c2, - StringSet.union s1 s2, - (if sz1 = sz2 then sz1 else None) - | Repetition e -> do_find_chars None e - - - -let find_chars e = - let c,s,_ = do_find_chars (Some 0) e in - StringSet.diff c s - -(*******************************) -(* From shallow to deep syntax *) -(*******************************) - -let chars = ref ([] : Cset.t list) -let chars_count = ref 0 - - -let rec encode_regexp char_vars act = function - Epsilon -> Empty - | Characters cl -> - let n = !chars_count in - chars := cl :: !chars; - incr chars_count; - Chars(n,false) - | Eof -> - let n = !chars_count in - chars := Cset.eof :: !chars; - incr chars_count; - Chars(n,true) - | Sequence(r1,r2) -> - let r1 = encode_regexp char_vars act r1 in - let r2 = encode_regexp char_vars act r2 in - Seq (r1, r2) - | Alternative(r1,r2) -> - let r1 = encode_regexp char_vars act r1 in - let r2 = encode_regexp char_vars act r2 in - Alt(r1, r2) - | Repetition r -> - let r = encode_regexp char_vars act r in - Star r - | Bind (r,x) -> - let r = encode_regexp char_vars act r in - if StringSet.mem x char_vars then - Seq (Tag {id=x ; start=true ; action=act},r) - else - Seq (Tag {id=x ; start=true ; action=act}, - Seq (r, Tag {id=x ; start=false ; action=act})) - - -(* Optimisation, - Static optimization : - Replace tags by offsets relative to the beginning - or end of matched string. - Dynamic optimization: - Replace some non-optional, non-double tags by offsets w.r.t - a previous similar tag. -*) - -let incr_pos = function - | None -> None - | Some i -> Some (i+1) - -let decr_pos = function - | None -> None - | Some i -> Some (i-1) - - -let opt = true - -let mk_seq r1 r2 = match r1,r2 with -| Empty,_ -> r2 -| _,Empty -> r1 -| _,_ -> Seq (r1,r2) - -let add_pos p i = match p with -| Some (Sum (a,n)) -> Some (Sum (a,n+i)) -| None -> None - -let opt_regexp all_vars char_vars optional_vars double_vars r = - -(* From removed tags to their addresses *) - let env = Hashtbl.create 17 in - -(* First static optimizations, from start position *) - let rec size_forward pos = function - | Empty|Chars (_,true)|Tag _ -> Some pos - | Chars (_,false) -> Some (pos+1) - | Seq (r1,r2) -> - begin match size_forward pos r1 with - | None -> None - | Some pos -> size_forward pos r2 - end - | Alt (r1,r2) -> - let pos1 = size_forward pos r1 - and pos2 = size_forward pos r2 in - if pos1=pos2 then pos1 else None - | Star _ -> None - | Action _ -> assert false in - - let rec simple_forward pos r = match r with - | Tag n -> - if StringSet.mem n.id double_vars then - r,Some pos - else begin - Hashtbl.add env (n.id,n.start) (Sum (Start, pos)) ; - Empty,Some pos - end - | Empty -> r, Some pos - | Chars (_,is_eof) -> - r,Some (if is_eof then pos else pos+1) - | Seq (r1,r2) -> - let r1,pos = simple_forward pos r1 in - begin match pos with - | None -> mk_seq r1 r2,None - | Some pos -> - let r2,pos = simple_forward pos r2 in - mk_seq r1 r2,pos - end - | Alt (r1,r2) -> - let pos1 = size_forward pos r1 - and pos2 = size_forward pos r2 in - r,(if pos1=pos2 then pos1 else None) - | Star _ -> r,None - | Action _ -> assert false in - -(* Then static optimizations, from end position *) - let rec size_backward pos = function - | Empty|Chars (_,true)|Tag _ -> Some pos - | Chars (_,false) -> Some (pos-1) - | Seq (r1,r2) -> - begin match size_backward pos r2 with - | None -> None - | Some pos -> size_backward pos r1 - end - | Alt (r1,r2) -> - let pos1 = size_backward pos r1 - and pos2 = size_backward pos r2 in - if pos1=pos2 then pos1 else None - | Star _ -> None - | Action _ -> assert false in - - - let rec simple_backward pos r = match r with - | Tag n -> - if StringSet.mem n.id double_vars then - r,Some pos - else begin - Hashtbl.add env (n.id,n.start) (Sum (End, pos)) ; - Empty,Some pos - end - | Empty -> r,Some pos - | Chars (_,is_eof) -> - r,Some (if is_eof then pos else pos-1) - | Seq (r1,r2) -> - let r2,pos = simple_backward pos r2 in - begin match pos with - | None -> mk_seq r1 r2,None - | Some pos -> - let r1,pos = simple_backward pos r1 in - mk_seq r1 r2,pos - end - | Alt (r1,r2) -> - let pos1 = size_backward pos r1 - and pos2 = size_backward pos r2 in - r,(if pos1=pos2 then pos1 else None) - | Star _ -> r,None - | Action _ -> assert false in - - let r = - if opt then - let r,_ = simple_forward 0 r in - let r,_ = simple_backward 0 r in - r - else - r in - - let loc_count = ref 0 in - let get_tag_addr t = - try - Hashtbl.find env t - with - | Not_found -> - let n = !loc_count in - incr loc_count ; - Hashtbl.add env t (Sum (Mem n,0)) ; - Sum (Mem n,0) in - - let rec alloc_exp pos r = match r with - | Tag n -> - if StringSet.mem n.id double_vars then - r,pos - else begin match pos with - | Some a -> - Hashtbl.add env (n.id,n.start) a ; - Empty,pos - | None -> - let a = get_tag_addr (n.id,n.start) in - r,Some a - end - - | Empty -> r,pos - | Chars (_,is_eof) -> r,(if is_eof then pos else add_pos pos 1) - | Seq (r1,r2) -> - let r1,pos = alloc_exp pos r1 in - let r2,pos = alloc_exp pos r2 in - mk_seq r1 r2,pos - | Alt (_,_) -> - let off = size_forward 0 r in - begin match off with - | Some i -> r,add_pos pos i - | None -> r,None - end - | Star _ -> r,None - | Action _ -> assert false in - - let r,_ = alloc_exp None r in - let m = - StringSet.fold - (fun x r -> - let v = - if StringSet.mem x char_vars then - Ident_char - (StringSet.mem x optional_vars, get_tag_addr (x,true)) - else - Ident_string - (StringSet.mem x optional_vars, - get_tag_addr (x,true), - get_tag_addr (x,false)) in - (x,v)::r) - all_vars [] in - m,r, !loc_count - - - -let encode_casedef casedef = - let r = - List.fold_left - (fun (reg,actions,count,ntags) (expr, act) -> - let expr = remove_nested_as expr in - let char_vars = find_chars expr in - let r = encode_regexp char_vars count expr - and opt_vars = find_optional expr - and double_vars,all_vars = find_double expr in - let m,r,loc_ntags = - opt_regexp all_vars char_vars opt_vars double_vars r in - Alt(reg, Seq(r, Action count)), - (count, m ,act) :: actions, - (succ count), - max loc_ntags ntags) - (Empty, [], 0, 0) - casedef in - r - -let encode_lexdef def = - chars := []; - chars_count := 0; - let entry_list = - List.map - (fun {name=entry_name ; args=args ; shortest=shortest ; clauses= casedef} -> - let (re,actions,_,ntags) = encode_casedef casedef in - { lex_name = entry_name; - lex_regexp = re; - lex_mem_tags = ntags ; - lex_actions = List.rev actions },args,shortest) - def in - let chr = Array.of_list (List.rev !chars) in - chars := []; - (chr, entry_list) - -(* To generate directly a NFA from a regular expression. - Confer Aho-Sethi-Ullman, dragon book, chap. 3 - Extension to tagged automata. - Confer - Ville Larikari - ``NFAs with Tagged Transitions, their Conversion to Deterministic - Automata and Application to Regular Expressions''. - Symposium on String Processing and Information Retrieval (SPIRE 2000), - http://kouli.iki.fi/~vlaurika/spire2000-tnfa.ps -(See also) - http://kouli.iki.fi/~vlaurika/regex-submatch.ps.gz -*) - -type t_transition = - OnChars of int - | ToAction of int - -type transition = t_transition * Tags.t - -let compare_trans (t1,tags1) (t2,tags2) = - match Pervasives.compare t1 t2 with - | 0 -> Tags.compare tags1 tags2 - | r -> r - - -module TransSet = - Set.Make(struct type t = transition let compare = compare end) - -let rec nullable = function - | Empty|Tag _ -> true - | Chars (_,_)|Action _ -> false - | Seq(r1,r2) -> nullable r1 && nullable r2 - | Alt(r1,r2) -> nullable r1 || nullable r2 - | Star r -> true - -let rec emptymatch = function - | Empty | Chars (_,_) | Action _ -> Tags.empty - | Tag t -> Tags.add t Tags.empty - | Seq (r1,r2) -> Tags.union (emptymatch r1) (emptymatch r2) - | Alt(r1,r2) -> - if nullable r1 then - emptymatch r1 - else - emptymatch r2 - | Star r -> - if nullable r then - emptymatch r - else - Tags.empty - -let addtags transs tags = - TransSet.fold - (fun (t,tags_t) r -> TransSet.add (t, Tags.union tags tags_t) r) - transs TransSet.empty - - -let rec firstpos = function - Empty|Tag _ -> TransSet.empty - | Chars (pos,_) -> TransSet.add (OnChars pos,Tags.empty) TransSet.empty - | Action act -> TransSet.add (ToAction act,Tags.empty) TransSet.empty - | Seq(r1,r2) -> - if nullable r1 then - TransSet.union (firstpos r1) (addtags (firstpos r2) (emptymatch r1)) - else - firstpos r1 - | Alt(r1,r2) -> TransSet.union (firstpos r1) (firstpos r2) - | Star r -> firstpos r - - -(* Berry-sethi followpos *) -let followpos size entry_list = - let v = Array.create size TransSet.empty in - let rec fill s = function - | Empty|Action _|Tag _ -> () - | Chars (n,_) -> v.(n) <- s - | Alt (r1,r2) -> - fill s r1 ; fill s r2 - | Seq (r1,r2) -> - fill - (if nullable r2 then - TransSet.union (firstpos r2) (addtags s (emptymatch r2)) - else - (firstpos r2)) - r1 ; - fill s r2 - | Star r -> - fill (TransSet.union (firstpos r) s) r in - List.iter (fun (entry,_,_) -> fill TransSet.empty entry.lex_regexp) entry_list ; - v - -(************************) -(* The algorithm itself *) -(************************) - -let no_action = max_int - -module StateSet = - Set.Make (struct type t = t_transition let compare = Pervasives.compare end) - - -module MemMap = - Map.Make (struct type t = int let compare = Pervasives.compare end) - -type 'a dfa_state = - {final : int * ('a * int TagMap.t) ; - others : ('a * int TagMap.t) MemMap.t} - -(* -let dtag oc t = - fprintf oc "%s<%s>" t.id (if t.start then "s" else "e") - -let dmem_map dp ds m = - MemMap.iter - (fun k x -> - eprintf "%d -> " k ; dp x ; ds ()) - m - -and dtag_map dp ds m = - TagMap.iter - (fun t x -> - dtag stderr t ; eprintf " -> " ; dp x ; ds ()) - m - -let dstate {final=(act,(_,m)) ; others=o} = - if act <> no_action then begin - eprintf "final=%d " act ; - dtag_map (fun x -> eprintf "%d" x) (fun () -> prerr_string " ,") m ; - prerr_endline "" - end ; - dmem_map - (fun (_,m) -> - dtag_map (fun x -> eprintf "%d" x) (fun () -> prerr_string " ,") m) - (fun () -> prerr_endline "") - o -*) - -let dfa_state_empty = - {final=(no_action, (max_int,TagMap.empty)) ; - others=MemMap.empty} - -and dfa_state_is_empty {final=(act,_) ; others=o} = - act = no_action && - o = MemMap.empty - - -(* A key is an abstraction on a dfa state, - two states with the same key can be made the same by - copying some memory cells into others *) - - -module StateSetSet = - Set.Make (struct type t = StateSet.t let compare = StateSet.compare end) - -type t_equiv = {tag:tag_info ; equiv:StateSetSet.t} - -module MemKey = - Set.Make - (struct - type t = t_equiv - - let compare e1 e2 = match Pervasives.compare e1.tag e2.tag with - | 0 -> StateSetSet.compare e1.equiv e2.equiv - | r -> r - end) - -type dfa_key = {kstate : StateSet.t ; kmem : MemKey.t} - -(* Map a state to its key *) -let env_to_class m = - let env1 = - MemMap.fold - (fun _ (tag,s) r -> - try - let ss = TagMap.find tag r in - let r = TagMap.remove tag r in - TagMap.add tag (StateSetSet.add s ss) r - with - | Not_found -> - TagMap.add tag (StateSetSet.add s StateSetSet.empty) r) - m TagMap.empty in - TagMap.fold - (fun tag ss r -> MemKey.add {tag=tag ; equiv=ss} r) - env1 MemKey.empty - - -(* trans is nfa_state, m is associated memory map *) -let inverse_mem_map trans m r = - TagMap.fold - (fun tag addr r -> - try - let otag,s = MemMap.find addr r in - assert (tag = otag) ; - let r = MemMap.remove addr r in - MemMap.add addr (tag,StateSet.add trans s) r - with - | Not_found -> - MemMap.add addr (tag,StateSet.add trans StateSet.empty) r) - m r - -let inverse_mem_map_other n (_,m) r = inverse_mem_map (OnChars n) m r - -let get_key {final=(act,(_,m_act)) ; others=o} = - let env = - MemMap.fold inverse_mem_map_other - o - (if act = no_action then MemMap.empty - else inverse_mem_map (ToAction act) m_act MemMap.empty) in - let state_key = - MemMap.fold (fun n _ r -> StateSet.add (OnChars n) r) o - (if act=no_action then StateSet.empty - else StateSet.add (ToAction act) StateSet.empty) in - let mem_key = env_to_class env in - {kstate = state_key ; kmem = mem_key} - - -let key_compare k1 k2 = match StateSet.compare k1.kstate k2.kstate with -| 0 -> MemKey.compare k1.kmem k2.kmem -| r -> r - -(* Association dfa_state -> state_num *) - -module StateMap = - Map.Make(struct type t = dfa_key let compare = key_compare end) - -let state_map = ref (StateMap.empty : int StateMap.t) -let todo = Stack.create() -let next_state_num = ref 0 -let next_mem_cell = ref 0 -let temp_pending = ref false -let tag_cells = Hashtbl.create 17 -let state_table = Table.create dfa_state_empty - - -let reset_state_mem () = - state_map := StateMap.empty; - Stack.clear todo; - next_state_num := 0 ; - let _ = Table.trim state_table in - () - -(* Allocation of memory cells *) -let reset_cell_mem ntags = - next_mem_cell := ntags ; - Hashtbl.clear tag_cells ; - temp_pending := false - -let do_alloc_temp () = - temp_pending := true ; - let n = !next_mem_cell in - n - -let do_alloc_cell used t = - let available = - try Hashtbl.find tag_cells t with Not_found -> Ints.empty in - try - Ints.choose (Ints.diff available used) - with - | Not_found -> - temp_pending := false ; - let n = !next_mem_cell in - if n >= 255 then raise Memory_overflow ; - Hashtbl.replace tag_cells t (Ints.add n available) ; - incr next_mem_cell ; - n - -let is_old_addr a = a >= 0 -and is_new_addr a = a < 0 - -let old_in_map m r = - TagMap.fold - (fun _ addr r -> - if is_old_addr addr then - Ints.add addr r - else - r) - m r - -let alloc_map used m mvs = - TagMap.fold - (fun tag a (r,mvs) -> - let a,mvs = - if is_new_addr a then - let a = do_alloc_cell used tag in - a,Ints.add a mvs - else a,mvs in - TagMap.add tag a r,mvs) - m (TagMap.empty,mvs) - -let create_new_state {final=(act,(_,m_act)) ; others=o} = - let used = - MemMap.fold (fun _ (_,m) r -> old_in_map m r) - o (old_in_map m_act Ints.empty) in - - let new_m_act,mvs = alloc_map used m_act Ints.empty in - let new_o,mvs = - MemMap.fold (fun k (x,m) (r,mvs) -> - let m,mvs = alloc_map used m mvs in - MemMap.add k (x,m) r,mvs) - o (MemMap.empty,mvs) in - {final=(act,(0,new_m_act)) ; others=new_o}, - Ints.fold (fun x r -> Set x::r) mvs [] - -type new_addr_gen = {mutable count : int ; mutable env : int TagMap.t} - -let create_new_addr_gen () = {count = -1 ; env = TagMap.empty} - -let alloc_new_addr tag r = - try - TagMap.find tag r.env - with - | Not_found -> - let a = r.count in - r.count <- a-1 ; - r.env <- TagMap.add tag a r.env ; - a - - -let create_mem_map tags gen = - Tags.fold - (fun tag r -> TagMap.add tag (alloc_new_addr tag gen) r) - tags TagMap.empty - -let create_init_state pos = - let gen = create_new_addr_gen () in - let st = - TransSet.fold - (fun (t,tags) st -> - match t with - | ToAction n -> - let on,otags = st.final in - if n < on then - {st with final = (n, (0,create_mem_map tags gen))} - else - st - | OnChars n -> - try - let _ = MemMap.find n st.others in assert false - with - | Not_found -> - {st with others = - MemMap.add n (0,create_mem_map tags gen) st.others}) - pos dfa_state_empty in - st - - -let get_map t st = match t with -| ToAction _ -> let _,(_,m) = st.final in m -| OnChars n -> - let (_,m) = MemMap.find n st.others in - m - -let dest = function | Copy (d,_) | Set d -> d -and orig = function | Copy (_,o) -> o | Set _ -> -1 - -let pmv oc mv = fprintf oc "%d <- %d" (dest mv) (orig mv) -let pmvs oc mvs = - List.iter (fun mv -> fprintf oc "%a " pmv mv) mvs ; - output_char oc '\n' ; flush oc - - -(* Topological sort << a la louche >> *) -let sort_mvs mvs = - let rec do_rec r mvs = match mvs with - | [] -> r - | _ -> - let dests = - List.fold_left - (fun r mv -> Ints.add (dest mv) r) - Ints.empty mvs in - let rem,here = - List.partition - (fun mv -> Ints.mem (orig mv) dests) - mvs in - match here with - | [] -> - begin match rem with - | Copy (d,_)::_ -> - let d' = do_alloc_temp () in - Copy (d',d):: - do_rec r - (List.map - (fun mv -> - if orig mv = d then - Copy (dest mv,d') - else - mv) - rem) - | _ -> assert false - end - | _ -> do_rec (here@r) rem in - do_rec [] mvs - -let move_to mem_key src tgt = - let mvs = - MemKey.fold - (fun {tag=tag ; equiv=m} r -> - StateSetSet.fold - (fun s r -> - try - let t = StateSet.choose s in - let src = TagMap.find tag (get_map t src) - and tgt = TagMap.find tag (get_map t tgt) in - if src <> tgt then begin - if is_new_addr src then - Set tgt::r - else - Copy (tgt, src)::r - end else - r - with - | Not_found -> assert false) - m r) - mem_key [] in -(* Moves are topologically sorted *) - sort_mvs mvs - - -let get_state st = - let key = get_key st in - try - let num = StateMap.find key !state_map in - num,move_to key.kmem st (Table.get state_table num) - with Not_found -> - let num = !next_state_num in - incr next_state_num; - let st,mvs = create_new_state st in - Table.emit state_table st ; - state_map := StateMap.add key num !state_map; - Stack.push (st, num) todo; - num,mvs - -let map_on_all_states f old_res = - let res = ref old_res in - begin try - while true do - let (st, i) = Stack.pop todo in - let r = f st in - res := (r, i) :: !res - done - with Stack.Empty -> () - end; - !res - -let goto_state st = - if - dfa_state_is_empty st - then - Backtrack,[] - else - let n,moves = get_state st in - Goto n,moves - -(****************************) -(* compute reachable states *) -(****************************) - -let add_tags_to_map gen tags m = - Tags.fold - (fun tag m -> - let m = TagMap.remove tag m in - TagMap.add tag (alloc_new_addr tag gen) m) - tags m - -let apply_transition gen r pri m = function - | ToAction n,tags -> - let on,(opri,_) = r.final in - if n < on || (on=n && pri < opri) then - let m = add_tags_to_map gen tags m in - {r with final=n,(pri,m)} - else r - | OnChars n,tags -> - try - let (opri,_) = MemMap.find n r.others in - if pri < opri then - let m = add_tags_to_map gen tags m in - {r with others=MemMap.add n (pri,m) (MemMap.remove n r.others)} - else - r - with - | Not_found -> - let m = add_tags_to_map gen tags m in - {r with others=MemMap.add n (pri,m) r.others} - -(* add transitions ts to new state r - transitions in ts start from state pri and memory map m -*) -let apply_transitions gen r pri m ts = - TransSet.fold - (fun t r -> apply_transition gen r pri m t) - ts r - - -(* For a given nfa_state pos, refine char partition *) -let rec split_env gen follow pos m s = function - | [] -> assert false - | (s1,st1) as p::rem -> - let here = Cset.inter s s1 in - if Cset.is_empty here then - p::split_env gen follow pos m s rem - else - let rest = Cset.diff s here in - let rem = - if Cset.is_empty rest then - rem - else - split_env gen follow pos m rest rem - and new_st = apply_transitions gen st1 pos m follow in - let stay = Cset.diff s1 here in - if Cset.is_empty stay then - (here, new_st)::rem - else - (stay, st1)::(here, new_st)::rem - - -(* For all nfa_state pos in a dfa state st *) -let comp_shift gen chars follow st = - MemMap.fold - (fun pos (_,m) env -> split_env gen follow.(pos) pos m chars.(pos) env) - st [Cset.all_chars_eof,dfa_state_empty] - - -let reachs chars follow st = - let gen = create_new_addr_gen () in -(* build a association list (char set -> new state) *) - let env = comp_shift gen chars follow st in -(* change it into (char set -> new state_num) *) - let env = - List.map - (fun (s,dfa_state) -> s,goto_state dfa_state) env in -(* finally build the char indexed array -> new state num *) - let shift = Cset.env_to_array env in - shift - - -let get_tag_mem n env t = - try - TagMap.find t env.(n) - with - | Not_found -> assert false - -let do_tag_actions n env m = - - let used,r = - TagMap.fold (fun t m (used,r) -> - let a = get_tag_mem n env t in - Ints.add a used,SetTag (a,m)::r) m (Ints.empty,[]) in - let _,r = - TagMap.fold - (fun tag m (used,r) -> - if not (Ints.mem m used) && tag.start then - Ints.add m used, EraseTag m::r - else - used,r) - env.(n) (used,r) in - r - - -let translate_state shortest_match tags chars follow st = - let (n,(_,m)) = st.final in - if MemMap.empty = st.others then - Perform (n,do_tag_actions n tags m) - else if shortest_match then begin - if n=no_action then - Shift (No_remember,reachs chars follow st.others) - else - Perform(n, do_tag_actions n tags m) - end else begin - Shift ( - (if n = no_action then - No_remember - else - Remember (n,do_tag_actions n tags m)), - reachs chars follow st.others) - end - -(* -let dtags chan tags = - Tags.iter - (fun t -> fprintf chan " %a" dtag t) - tags - -let dtransset s = - TransSet.iter - (fun trans -> match trans with - | OnChars i,tags -> - eprintf " (-> %d,%a)" i dtags tags - | ToAction i,tags -> - eprintf " ([%d],%a)" i dtags tags) - s - -let dfollow t = - eprintf "follow=[" ; - for i = 0 to Array.length t-1 do - eprintf "%d:" i ; - dtransset t.(i) - done ; - prerr_endline "]" -*) - -let make_tag_entry id start act a r = match a with - | Sum (Mem m,0) -> - TagMap.add {id=id ; start=start ; action=act} m r - | _ -> r - -let extract_tags l = - let envs = Array.create (List.length l) TagMap.empty in - List.iter - (fun (act,m,_) -> - envs.(act) <- - List.fold_right - (fun (x,v) r -> match v with - | Ident_char (_,t) -> make_tag_entry x true act t r - | Ident_string (_,t1,t2) -> - make_tag_entry x true act t1 - (make_tag_entry x false act t2 r)) - m TagMap.empty) - l ; - envs - - -let make_dfa lexdef = - let (chars, entry_list) = encode_lexdef lexdef in - let follow = followpos (Array.length chars) entry_list in -(* - dfollow follow ; -*) - reset_state_mem () ; - let r_states = ref [] in - let initial_states = - List.map - (fun (le,args,shortest) -> - let tags = extract_tags le.lex_actions in - reset_cell_mem le.lex_mem_tags ; - let pos_set = firstpos le.lex_regexp in -(* - prerr_string "trans={" ; dtransset pos_set ; prerr_endline "}" ; -*) - let init_state = create_init_state pos_set in - let init_num = get_state init_state in - r_states := - map_on_all_states - (translate_state shortest tags chars follow) !r_states ; - { auto_name = le.lex_name; - auto_args = args ; - auto_mem_size = - (if !temp_pending then !next_mem_cell+1 else !next_mem_cell) ; - auto_initial_state = init_num ; - auto_actions = le.lex_actions }) - entry_list in - let states = !r_states in -(* - prerr_endline "** states **" ; - for i = 0 to !next_state_num-1 do - eprintf "+++ %d +++\n" i ; - dstate (Table.get state_table i) ; - prerr_endline "" - done ; - eprintf "%d states\n" !next_state_num ; -*) - let actions = Array.create !next_state_num (Perform (0,[])) in - List.iter (fun (act, i) -> actions.(i) <- act) states; - reset_state_mem () ; - reset_cell_mem 0 ; - (initial_states, actions) diff --git a/lex/lexgen.mli b/lex/lexgen.mli deleted file mode 100644 index cd7f6474a8..0000000000 --- a/lex/lexgen.mli +++ /dev/null @@ -1,59 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - - -(* raised when there are too many bindings (>= 254 memory cells) *) -exception Memory_overflow - - -(* Representation of automata *) - - -type automata = - Perform of int * tag_action list - | Shift of automata_trans * (automata_move * memory_action list) array -and automata_trans = - No_remember - | Remember of int * tag_action list -and automata_move = - Backtrack - | Goto of int -and memory_action = - | Copy of int * int - | Set of int - -and tag_action = SetTag of int * int | EraseTag of int - - -(* Representation of entry points *) -type tag_base = Start | End | Mem of int -type tag_addr = Sum of (tag_base * int) -type ident_info = - | Ident_string of bool * tag_addr * tag_addr - | Ident_char of bool * tag_addr -type t_env = (string * ident_info) list - -type ('args,'action) automata_entry = - { auto_name: string; - auto_args: 'args ; - auto_mem_size : int ; - auto_initial_state: int * memory_action list ; - auto_actions: (int * t_env * 'action) list } - -(* The entry point *) - -val make_dfa : - ('args, 'action) Syntax.entry list -> - ('args, 'action) automata_entry list * automata array - diff --git a/lex/main.ml b/lex/main.ml deleted file mode 100644 index d97820151f..0000000000 --- a/lex/main.ml +++ /dev/null @@ -1,102 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* The lexer generator. Command-line parsing. *) - -open Syntax -open Lexgen - -let ml_automata = ref false -let source_name = ref None -let output_name = ref None - -let usage = "usage: ocamlex [options] sourcefile" - -let specs = - ["-ml", Arg.Set ml_automata, - " Output code that does not use the Lexing module built-in automata interpreter"; - "-o", Arg.String (fun x -> output_name := Some x), - " Set output file name to "; - "-q", Arg.Set Common.quiet_mode, " Do not display informational messages"; - ] - -let _ = - Arg.parse - specs - (fun name -> source_name := Some name) - usage - - -let main () = - - let source_name = match !source_name with - | None -> Arg.usage specs usage ; exit 2 - | Some name -> name in - let dest_name = match !output_name with - | Some name -> name - | None -> - if Filename.check_suffix source_name ".mll" then - Filename.chop_suffix source_name ".mll" ^ ".ml" - else - source_name ^ ".ml" in - - let ic = open_in_bin source_name in - let oc = open_out dest_name in - let tr = Common.open_tracker dest_name oc in - let lexbuf = Lexing.from_channel ic in - try - let def = Parser.lexer_definition Lexer.main lexbuf in - let (entries, transitions) = Lexgen.make_dfa def.entrypoints in - if !ml_automata then begin - Outputbis.output_lexdef - source_name ic oc tr - def.header entries transitions def.trailer - end else begin - let tables = Compact.compact_tables transitions in - Output.output_lexdef source_name ic oc tr - def.header tables entries def.trailer - end; - close_in ic; - close_out oc; - Common.close_tracker tr; - with exn -> - close_in ic; - close_out oc; - Common.close_tracker tr; - Sys.remove dest_name; - begin match exn with - Parsing.Parse_error -> - Printf.fprintf stderr - "File \"%s\", line %d, character %d: syntax error.\n" - source_name !Lexer.line_num - (Lexing.lexeme_start lexbuf - !Lexer.line_start_pos) - | Lexer.Lexical_error(msg, line, col) -> - Printf.fprintf stderr - "File \"%s\", line %d, character %d: %s.\n" - source_name line col msg - | Lexgen.Memory_overflow -> - Printf.fprintf stderr - "File \"%s\":\n Position memory overflow, too many bindings\n" - source_name - | Output.Table_overflow -> - Printf.fprintf stderr - "File \"%s\":\ntransition table overflow, automaton is too big\n" - source_name - | _ -> - raise exn - end; - exit 3 - -let _ = (* Printexc.catch *) main (); exit 0 - diff --git a/lex/output.ml b/lex/output.ml deleted file mode 100644 index c01b76ff03..0000000000 --- a/lex/output.ml +++ /dev/null @@ -1,140 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* Output the DFA tables and its entry points *) - -open Printf -open Syntax -open Lexgen -open Compact -open Common - -(* To output an array of short ints, encoded as a string *) - -let output_byte oc b = - output_char oc '\\'; - output_char oc (Char.chr(48 + b / 100)); - output_char oc (Char.chr(48 + (b / 10) mod 10)); - output_char oc (Char.chr(48 + b mod 10)) - -let output_array oc v = - output_string oc " \""; - for i = 0 to Array.length v - 1 do - output_byte oc (v.(i) land 0xFF); - output_byte oc ((v.(i) asr 8) land 0xFF); - if i land 7 = 7 then output_string oc "\\\n " - done; - output_string oc "\"" - -let output_byte_array oc v = - output_string oc " \""; - for i = 0 to Array.length v - 1 do - output_byte oc (v.(i) land 0xFF); - if i land 15 = 15 then output_string oc "\\\n " - done; - output_string oc "\"" - -(* Output the tables *) - -let output_tables oc tbl = - output_string oc "let __ocaml_lex_tables = {\n"; - - fprintf oc " Lexing.lex_base = \n%a;\n" output_array tbl.tbl_base; - fprintf oc " Lexing.lex_backtrk = \n%a;\n" output_array tbl.tbl_backtrk; - fprintf oc " Lexing.lex_default = \n%a;\n" output_array tbl.tbl_default; - fprintf oc " Lexing.lex_trans = \n%a;\n" output_array tbl.tbl_trans; - fprintf oc " Lexing.lex_check = \n%a;\n" output_array tbl.tbl_check; - fprintf oc " Lexing.lex_base_code = \n%a;\n" output_array tbl.tbl_base_code; - - fprintf oc " Lexing.lex_backtrk_code = \n%a;\n" - output_array tbl.tbl_backtrk_code; - fprintf oc " Lexing.lex_default_code = \n%a;\n" - output_array tbl.tbl_default_code; - fprintf oc " Lexing.lex_trans_code = \n%a;\n" - output_array tbl.tbl_trans_code; - fprintf oc " Lexing.lex_check_code = \n%a;\n" - output_array tbl.tbl_check_code; - fprintf oc " Lexing.lex_code = \n%a;\n" output_byte_array tbl.tbl_code; - - output_string oc "}\n\n" - - -(* Output the entries *) - -let output_entry sourcefile ic oc oci e = - let init_num, init_moves = e.auto_initial_state in - fprintf oc "%s %alexbuf = - %a%a __ocaml_lex_%s_rec %alexbuf %d\n" - e.auto_name - output_args e.auto_args - (fun oc x -> - if x > 0 then - fprintf oc "lexbuf.Lexing.lex_mem <- Array.create %d (-1) ; " x) - e.auto_mem_size - (output_memory_actions " ") init_moves - e.auto_name - output_args e.auto_args - init_num; - fprintf oc "and __ocaml_lex_%s_rec %alexbuf __ocaml_lex_state =\n" - e.auto_name output_args e.auto_args ; - fprintf oc " match Lexing.%sengine" - (if e.auto_mem_size == 0 then "" else "new_"); - fprintf oc " __ocaml_lex_tables __ocaml_lex_state lexbuf with\n "; - List.iter - (fun (num, env, loc) -> - fprintf oc " | "; - fprintf oc "%d ->\n" num; - output_env oc env; - copy_chunk sourcefile ic oc oci loc true; - fprintf oc "\n") - e.auto_actions; - fprintf oc " | n -> lexbuf.Lexing.refill_buff lexbuf; \ - __ocaml_lex_%s_rec %alexbuf n\n\n" - e.auto_name output_args e.auto_args - -(* Main output function *) - -exception Table_overflow - -let output_lexdef sourcefile ic oc oci header tables entry_points trailer = - if not !Common.quiet_mode then - Printf.printf "%d states, %d transitions, table size %d bytes\n" - (Array.length tables.tbl_base) - (Array.length tables.tbl_trans) - (2 * (Array.length tables.tbl_base + Array.length tables.tbl_backtrk + - Array.length tables.tbl_default + Array.length tables.tbl_trans + - Array.length tables.tbl_check)); - let size_groups = - (2 * (Array.length tables.tbl_base_code + - Array.length tables.tbl_backtrk_code + - Array.length tables.tbl_default_code + - Array.length tables.tbl_trans_code + - Array.length tables.tbl_check_code) + - Array.length tables.tbl_code) in - if size_groups > 0 && not !Common.quiet_mode then - Printf.printf "%d additional bytes used for bindings\n" size_groups ; - flush stdout; - if Array.length tables.tbl_trans > 0x8000 then raise Table_overflow; - copy_chunk sourcefile ic oc oci header false; - output_tables oc tables; - begin match entry_points with - [] -> () - | entry1 :: entries -> - output_string oc "let rec "; output_entry sourcefile ic oc oci entry1; - List.iter - (fun e -> output_string oc "and "; output_entry sourcefile ic oc oci e) - entries; - output_string oc ";;\n\n"; - end; - copy_chunk sourcefile ic oc oci trailer false diff --git a/lex/output.mli b/lex/output.mli deleted file mode 100644 index 85f89b30ce..0000000000 --- a/lex/output.mli +++ /dev/null @@ -1,25 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* Output the DFA tables and its entry points *) - -val output_lexdef: - string -> in_channel -> out_channel -> Common.line_tracker -> - Syntax.location -> - Compact.lex_tables -> - (string list, Syntax.location) Lexgen.automata_entry list -> - Syntax.location -> - unit - -exception Table_overflow diff --git a/lex/outputbis.ml b/lex/outputbis.ml deleted file mode 100644 index be1c6af5d5..0000000000 --- a/lex/outputbis.ml +++ /dev/null @@ -1,193 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* Output the DFA tables and its entry points *) - -open Printf -open Syntax -open Lexgen -open Common - -let output_auto_defs oc = - fprintf oc "let __ocaml_lex_init_lexbuf lexbuf mem_size = - let pos = lexbuf.Lexing.lex_curr_pos in - lexbuf.Lexing.lex_mem <- Array.create mem_size (-1) ; - lexbuf.Lexing.lex_start_pos <- pos ; - lexbuf.Lexing.lex_last_pos <- pos ; - lexbuf.Lexing.lex_last_action <- -1 - -" ; - - output_string oc - "let rec __ocaml_lex_next_char lexbuf = - if lexbuf.Lexing.lex_curr_pos >= lexbuf.Lexing.lex_buffer_len then begin - if lexbuf.Lexing.lex_eof_reached then - 256 - else begin - lexbuf.Lexing.refill_buff lexbuf ; - __ocaml_lex_next_char lexbuf - end - end else begin - let i = lexbuf.Lexing.lex_curr_pos in - let c = lexbuf.Lexing.lex_buffer.[i] in - lexbuf.Lexing.lex_curr_pos <- i+1 ; - Char.code c - end - -" - - -let output_pats oc pats = List.iter (fun p -> fprintf oc "|%d" p) pats - -let output_action oc mems r = - output_memory_actions " " oc mems ; - match r with - | Backtrack -> - fprintf oc - " lexbuf.Lexing.lex_curr_pos <- lexbuf.Lexing.lex_last_pos ;\n" ; - fprintf oc " lexbuf.Lexing.lex_last_action\n" - | Goto n -> - fprintf oc " __ocaml_lex_state%d lexbuf\n" n - -let output_pat oc i = - if i >= 256 then - fprintf oc "|eof" - else - fprintf oc "|'%s'" (Char.escaped (Char.chr i)) - -let output_clause oc pats mems r = - fprintf oc "(* " ; - List.iter (output_pat oc) pats ; - fprintf oc " *)\n" ; - fprintf oc " %a ->\n" output_pats pats ; output_action oc mems r - -let output_default_clause oc mems r = - fprintf oc " | _ ->\n" ; output_action oc mems r - - -let output_moves oc moves = - let t = Hashtbl.create 17 in - let add_move i (m,mems) = - let mems,r = try Hashtbl.find t m with Not_found -> mems,[] in - Hashtbl.replace t m (mems,(i::r)) in - - for i = 0 to 256 do - add_move i moves.(i) - done ; - - let most_frequent = ref Backtrack - and most_mems = ref [] - and size = ref 0 in - Hashtbl.iter - (fun m (mems,pats) -> - let size_m = List.length pats in - if size_m > !size then begin - most_frequent := m ; - most_mems := mems ; - size := size_m - end) - t ; - Hashtbl.iter - (fun m (mems,pats) -> - if m <> !most_frequent then output_clause oc (List.rev pats) mems m) - t ; - output_default_clause oc !most_mems !most_frequent - - -let output_tag_actions pref oc mvs = - output_string oc "(*" ; - List.iter - (fun i -> match i with - | SetTag (t,m) -> fprintf oc " t%d <- [%d] ;" t m - | EraseTag t -> fprintf oc " t%d <- -1 ;" t) - mvs ; - output_string oc " *)\n" ; - List.iter - (fun i -> match i with - | SetTag (t,m) -> - fprintf oc "%s%a <- %a ;\n" - pref output_mem_access t output_mem_access m - | EraseTag t -> - fprintf oc "%s%a <- -1 ;\n" - pref output_mem_access t) - mvs - -let output_trans pref oc i trans = - fprintf oc "%s __ocaml_lex_state%d lexbuf = " pref i ; - match trans with - | Perform (n,mvs) -> - output_tag_actions " " oc mvs ; - fprintf oc " %d\n" n - | Shift (trans, move) -> - begin match trans with - | Remember (n,mvs) -> - output_tag_actions " " oc mvs ; - fprintf oc - " lexbuf.Lexing.lex_last_pos <- lexbuf.Lexing.lex_curr_pos ;\n" ; - fprintf oc " lexbuf.Lexing.lex_last_action <- %d ;\n" n - | No_remember -> () - end ; - fprintf oc " match __ocaml_lex_next_char lexbuf with\n" ; - output_moves oc move - -let output_automata oc auto = - output_auto_defs oc ; - let n = Array.length auto in - output_trans "let rec" oc 0 auto.(0) ; - for i = 1 to n-1 do - output_trans "\nand" oc i auto.(i) - done ; - output_char oc '\n' - - -(* Output the entries *) - -let output_entry sourcefile ic oc tr e = - let init_num, init_moves = e.auto_initial_state in - fprintf oc "%s %alexbuf = - __ocaml_lex_init_lexbuf lexbuf %d; %a - let __ocaml_lex_result = __ocaml_lex_state%d lexbuf in - lexbuf.Lexing.lex_start_p <- lexbuf.Lexing.lex_curr_p; - lexbuf.Lexing.lex_curr_p <- {lexbuf.Lexing.lex_curr_p with - Lexing.pos_cnum = lexbuf.Lexing.lex_abs_pos + lexbuf.Lexing.lex_curr_pos}; - match __ocaml_lex_result with\n" - e.auto_name output_args e.auto_args - e.auto_mem_size (output_memory_actions " ") init_moves init_num ; - List.iter - (fun (num, env, loc) -> - fprintf oc " | "; - fprintf oc "%d ->\n" num; - output_env oc env ; - copy_chunk sourcefile ic oc tr loc true; - fprintf oc "\n") - e.auto_actions; - fprintf oc " | _ -> raise (Failure \"lexing: empty token\")\n\n\n" - - -(* Main output function *) - -let output_lexdef sourcefile ic oc tr header entry_points transitions trailer = - - copy_chunk sourcefile ic oc tr header false; - output_automata oc transitions ; - begin match entry_points with - [] -> () - | entry1 :: entries -> - output_string oc "let rec "; output_entry sourcefile ic oc tr entry1; - List.iter - (fun e -> output_string oc "and "; output_entry sourcefile ic oc tr e) - entries; - output_string oc ";;\n\n"; - end; - copy_chunk sourcefile ic oc tr trailer false diff --git a/lex/outputbis.mli b/lex/outputbis.mli deleted file mode 100644 index 76f00672bf..0000000000 --- a/lex/outputbis.mli +++ /dev/null @@ -1,21 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Luc Maranget projet Moscova INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) -val output_lexdef : - string -> - in_channel -> - out_channel -> - Common.line_tracker -> - Syntax.location -> - (string list, Syntax.location) Lexgen.automata_entry list -> - Lexgen.automata array -> Syntax.location -> unit diff --git a/lex/parser.mly b/lex/parser.mly deleted file mode 100644 index a1921309b2..0000000000 --- a/lex/parser.mly +++ /dev/null @@ -1,174 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 1996 Institut National de Recherche en Informatique et */ -/* en Automatique. All rights reserved. This file is distributed */ -/* under the terms of the Q Public License version 1.0. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -/* The grammar for lexer definitions */ - -%{ -open Syntax - -(* Auxiliaries for the parser. *) - -let named_regexps = - (Hashtbl.create 13 : (string, regular_expression) Hashtbl.t) - -let regexp_for_string s = - let rec re_string n = - if n >= String.length s then Epsilon - else if succ n = String.length s then - Characters (Cset.singleton (Char.code s.[n])) - else - Sequence - (Characters(Cset.singleton (Char.code s.[n])), - re_string (succ n)) - in re_string 0 - -let rec remove_as = function - | Bind (e,_) -> remove_as e - | Epsilon|Eof|Characters _ as e -> e - | Sequence (e1, e2) -> Sequence (remove_as e1, remove_as e2) - | Alternative (e1, e2) -> Alternative (remove_as e1, remove_as e2) - | Repetition e -> Repetition (remove_as e) - -%} - -%token Tident -%token Tchar -%token Tstring -%token Taction -%token Trule Tparse Tparse_shortest Tand Tequal Tend Tor Tunderscore Teof Tlbracket Trbracket -%token Tstar Tmaybe Tplus Tlparen Trparen Tcaret Tdash Tlet Tas - -%right Tas -%left Tor -%nonassoc CONCAT -%nonassoc Tmaybe Tstar Tplus - Tident Tchar Tstring Tunderscore Teof Tlbracket Tlparen - -%start lexer_definition -%type lexer_definition - -%% - -lexer_definition: - header named_regexps Trule definition other_definitions header Tend - { {header = $1; - entrypoints = $4 :: List.rev $5; - trailer = $6} } -; -header: - Taction - { $1 } - | /*epsilon*/ - { { start_pos = 0; end_pos = 0; start_line = 1; start_col = 0 } } -; -named_regexps: - named_regexps Tlet Tident Tequal regexp - { Hashtbl.add named_regexps $3 $5 } - | /*epsilon*/ - { () } -; -other_definitions: - other_definitions Tand definition - { $3::$1 } - | /*epsilon*/ - { [] } -; -definition: - Tident arguments Tequal Tparse entry - { {name=$1 ; shortest=false ; args=$2 ; clauses=$5} } - | Tident arguments Tequal Tparse_shortest entry - { {name=$1 ; shortest=true ; args=$2 ; clauses=$5} } -; - -arguments: - Tident arguments { $1::$2 } -| /*epsilon*/ { [] } -; - - -entry: - case rest_of_entry - { $1::List.rev $2 } -| Tor case rest_of_entry - { $2::List.rev $3 } -; - -rest_of_entry: - rest_of_entry Tor case - { $3::$1 } - | - { [] } -; -case: - regexp Taction - { ($1,$2) } -; -regexp: - Tunderscore - { Characters Cset.all_chars } - | Teof - { Eof } - | Tchar - { Characters (Cset.singleton $1) } - | Tstring - { regexp_for_string $1 } - | Tlbracket char_class Trbracket - { Characters $2 } - | regexp Tstar - { Repetition $1 } - | regexp Tmaybe - { Alternative(Epsilon, $1) } - | regexp Tplus - { Sequence(Repetition (remove_as $1), $1) } - | regexp Tor regexp - { Alternative($1,$3) } - | regexp regexp %prec CONCAT - { Sequence($1,$2) } - | Tlparen regexp Trparen - { $2 } - | Tident - { try - Hashtbl.find named_regexps $1 - with Not_found -> - prerr_string "Reference to unbound regexp name `"; - prerr_string $1; - prerr_string "' at char "; - prerr_int (Parsing.symbol_start()); - prerr_newline(); - exit 2 } - | regexp Tas ident - {Bind ($1, $3)} -; - -ident: - Tident {$1} -; - -char_class: - Tcaret char_class1 - { Cset.complement $2 } - | char_class1 - { $1 } -; -char_class1: - Tchar Tdash Tchar - { Cset.interval $1 $3 } - | Tchar - { Cset.singleton $1 } - | char_class1 char_class1 %prec CONCAT - { Cset.union $1 $2 } -; - -%% - diff --git a/lex/syntax.ml b/lex/syntax.ml deleted file mode 100644 index e5b3f219b9..0000000000 --- a/lex/syntax.ml +++ /dev/null @@ -1,44 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* This apparently useless implmentation file is in fact required - by the pa_ocamllex syntax extension *) - -(* The shallow abstract syntax *) - -type location = - { start_pos: int; - end_pos: int; - start_line: int; - start_col: int } - -type regular_expression = - Epsilon - | Characters of Cset.t - | Eof - | Sequence of regular_expression * regular_expression - | Alternative of regular_expression * regular_expression - | Repetition of regular_expression - | Bind of regular_expression * string - -type ('arg,'action) entry = - {name:string ; - shortest : bool ; - args : 'arg ; - clauses : (regular_expression * 'action) list} - -type lexer_definition = - { header: location; - entrypoints: ((string list, location) entry) list; - trailer: location } diff --git a/lex/syntax.mli b/lex/syntax.mli deleted file mode 100644 index 368a5d0ba8..0000000000 --- a/lex/syntax.mli +++ /dev/null @@ -1,41 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* The shallow abstract syntax *) - -type location = - { start_pos: int; - end_pos: int; - start_line: int; - start_col: int } - -type regular_expression = - Epsilon - | Characters of Cset.t - | Eof - | Sequence of regular_expression * regular_expression - | Alternative of regular_expression * regular_expression - | Repetition of regular_expression - | Bind of regular_expression * string - -type ('arg,'action) entry = - {name:string ; - shortest : bool ; - args : 'arg ; - clauses : (regular_expression * 'action) list} - -type lexer_definition = - { header: location; - entrypoints: ((string list, location) entry) list; - trailer: location } diff --git a/lex/table.ml b/lex/table.ml deleted file mode 100644 index 402f52be8b..0000000000 --- a/lex/table.ml +++ /dev/null @@ -1,56 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Luc Maranget, projet Moscova, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -type 'a t = {mutable next : int ; mutable data : 'a array} - -let default_size = 32 -;; - -let create x = {next = 0 ; data = Array.create default_size x} -and reset t = t.next <- 0 -;; - -let incr_table table new_size = - let t = Array.create new_size table.data.(0) in - Array.blit table.data 0 t 0 (Array.length table.data) ; - table.data <- t - -let emit table i = - let size = Array.length table.data in - if table.next >= size then - incr_table table (2*size); - table.data.(table.next) <- i ; - table.next <- table.next + 1 -;; - - -exception Error - -let get t i = - if 0 <= i && i < t.next then - t.data.(i) - else - raise Error - -let trim t = - let r = Array.sub t.data 0 t.next in - reset t ; - r - -let iter t f = - let size = t.next - and data = t.data in - for i = 0 to size-1 do - f data.(i) - done - -let size t = t.next diff --git a/lex/table.mli b/lex/table.mli deleted file mode 100644 index e5d55f9652..0000000000 --- a/lex/table.mli +++ /dev/null @@ -1,33 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Luc Maranget, projet Moscova, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* Table used for code emission, ie extensible arrays *) -type 'a t - -val create : 'a -> 'a t - -val emit : 'a t -> 'a -> unit - -val iter : 'a t -> ('a -> unit) -> unit - -val trim : 'a t -> 'a array - - -exception Error - -val get : 'a t -> int -> 'a - - - -val size : 'a t -> int - - diff --git a/maccaml/.cvsignore b/maccaml/.cvsignore deleted file mode 100644 index efe28a120b..0000000000 --- a/maccaml/.cvsignore +++ /dev/null @@ -1,12 +0,0 @@ -stdlib -*.c.x -*.cp.x -*.xcoff -*.dbg -appliprims -appli -prims.c -Objective*Caml -OCaml.68k -OCaml.PPC -dummy_fragment diff --git a/maccaml/Makefile.Mac b/maccaml/Makefile.Mac deleted file mode 100644 index c9b0f0e9a4..0000000000 --- a/maccaml/Makefile.Mac +++ /dev/null @@ -1,121 +0,0 @@ -######################################################################### -# # -# Objective Caml # -# # -# Damien Doligez, projet Para, INRIA Rocquencourt # -# # -# Copyright 1999 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### - -# $Id$ - -VERSIONSTR = ¶ - "¶"{OCAMLMAJOR}.{OCAMLMINOR}/Mac{MAJOR}.{MINOR}.{BUGFIX}{STAGE}{REV}¶"" - -COPYRIGHTSTR = "¶"Copyright 1991-2001 INRIA¶"" - -XIncludes = -i ::byterun:,::config: ¶ - -i ":WASTE:WASTE 1.3 Distribution:WASTE C/C++ Headers:" - -PPCC = mrc -proto strict -w 6,35 -PPCCplus = mrcpp -PPCCOptions = {XIncludes} {cdbgflag} -PPCLinkOptions = -d {ldbgflag} -PPCCamlrunLibs = ::otherlibs:num:libnums.x ¶ - ::otherlibs:bigarray:libbigarray.x ¶ - ::byterun:libcamlrun-gui.x ¶ - ::otherlibs:str:libstr.x -PPCWELibs = ":WASTE:WASTE 1.3 Distribution:WASTELib.x" -PPCSysLibs = "{PPCLibraries}MrCPlusLib.o" ¶ - "{PPCLibraries}PPCStdCLib.o" ¶ - "{PPCLibraries}StdCRuntime.o" ¶ - "{PPCLibraries}PPCCRuntime.o" ¶ - "{PPCLibraries}PPCToolLibs.o" ¶ - "{SharedLibraries}InterfaceLib" ¶ - "{SharedLibraries}StdCLib" ¶ - "{sharedlibraries}MathLib" ¶ - "{sharedlibraries}DragLib" -PPCLibs = {ppccamlrunlibs} {ppcwelibs} {ppcsyslibs} - -camllibs = ::otherlibs:graph:graphics.cma ¶ - ::otherlibs:num:nums.cma ¶ - ::otherlibs:bigarray:bigarray.cma ¶ - -primfiles = ::byterun:primitives prim_bigarray prim_graph prim_num prim_str - -RezDefs = -d MAJORVNUM={MAJOR} -d MINORVNUM=0x{MINOR}{BUGFIX} ¶ - -d STAGE={STAGE} -d DEVVNUM={REV} ¶ - -d VERSIONSTR={VERSIONSTR} -d COPYRIGHTSTR={COPYRIGHTSTR} - -PPCOBJS = aboutbox.c.x appleevents.c.x clipboard.c.x ¶ - drag.c.x errors.c.x ¶ - events.c.x files.c.x glue.c.x ¶ - graph.c.x lcontrols.c.x lib.c.x main.c.x mcmemory.c.x ¶ - menus.c.x mcmisc.c.x modalfilter.c.x prefs.c.x prims.c.x ¶ - print.c.x scroll.c.x windows.c.x - -all Ä appli appliprims ocamlconstants.h appli.r "Objective Caml" - set status 0 - -appliprims Ä {primfiles} - catenate {primfiles} > appliprims - -prims.c Ä appliprims - begin - echo '#include "mlvalues.h"' - echo '#include "prims.h"' - streamedit -e '1,$ change "extern value " . "();"' appliprims - echo 'c_primitive builtin_cprim [] = {' - streamedit -e '1,$ change " " . ","' appliprims - echo '0 };' - echo 'char * names_of_builtin_cprim [] = {' - streamedit -e '1,$ change " ¶"" . "¶","' appliprims - echo '0 };' - end > prims.c - -OCaml.PPC Ä {PPCOBJS} {ppccamlrunlibs} - ppclink -o OCaml.PPC {ppclinkoptions} {PPCOBJS} {ppclibs} - rename -y OCaml.PPC.xcoff "Objective Caml.xcoff" || set status 0 - -dummy_fragment Ä dummy_fragment.c.x - ppclink -xm l -o dummy_fragment {ppclinkoptions} dummy_fragment.c.x - -appli ÄÄ OCaml.PPC dummy_fragment - delete -i appli - mergefragment -a OCaml.PPC appli - mergefragment dummy_fragment appli - -"Objective Caml" Ä appliprims appli.r ocamlconstants.h appli ¶ - ::toplevellib.cma {camllibs} ::toplevel:topmain.cmo - :ocamlmkappli ¶ - -ocamlc "::boot:ocamlrun ::boot:ocamlc -I ::stdlib: -linkall" ¶ - {rezdefs} -lib : -name "Objective Caml" -r ocaml.r ¶ - -creator Caml -prefsize 5000 -minsize 3000 ¶ - ::toplevellib.cma {camllibs} ::toplevel:topmain.cmo - -install Ä appli appli.r appliprims ocamlconstants.h ocamlmkappli ¶ - "Objective Caml" - duplicate -y "Objective Caml" ¶ - `exists "objective caml.xcoff" ¶ - "::test:Moretest:graph_example.ml" ¶ - ` ¶ - "{APPLIDIR}" - duplicate -y appli appli.r appliprims ocamlconstants.h "{LIBDIR}" - duplicate -y ocamlmkappli "{BINDIR}" - -partialclean Ä - delete -i "Objective Caml" - -clean Ä - delete -i -y {OBJS} {PPCOBJS} OCaml.68k OCaml.PPC ¶ - "Objective Caml" appliprims prims.c null :config ¶ - dummy_fragment dummy_fragment.c.x dummy_fragment.xcoff ¶ - "Objective Caml.xcoff" "Objective Caml.dbg" - -depend Ä prims.c - begin - makedepend -w -objext .x Å.c - end | streamedit -e "/¶t/ replace // ' ' -c °" > Makefile.Mac.depend diff --git a/maccaml/Makefile.Mac.depend b/maccaml/Makefile.Mac.depend deleted file mode 100644 index b225a6e065..0000000000 --- a/maccaml/Makefile.Mac.depend +++ /dev/null @@ -1,2032 +0,0 @@ -#*** Dependencies: Cut here *** -# These dependencies were produced at 20:33:24 on Tue, Aug 21, 2001 by MakeDepend - -:aboutbox.c.x Ä ¶ - :aboutbox.c ¶ - :main.h ¶ - "{CIncludes}"limits.h ¶ - "{CIncludes}"signal.h ¶ - "{CIncludes}"stdio.h ¶ - "{CIncludes}"stdlib.h ¶ - "{CIncludes}"string.h ¶ - "{CIncludes}"AERegistry.h ¶ - "{CIncludes}"AppleEvents.h ¶ - "{CIncludes}"ControlDefinitions.h ¶ - "{CIncludes}"Controls.h ¶ - "{CIncludes}"Devices.h ¶ - "{CIncludes}"Dialogs.h ¶ - "{CIncludes}"DiskInit.h ¶ - "{CIncludes}"Drag.h ¶ - "{CIncludes}"Finder.h ¶ - "{CIncludes}"FixMath.h ¶ - "{CIncludes}"Folders.h ¶ - "{CIncludes}"Fonts.h ¶ - "{CIncludes}"Gestalt.h ¶ - "{CIncludes}"LowMem.h ¶ - "{CIncludes}"MacTypes.h ¶ - "{CIncludes}"MacWindows.h ¶ - "{CIncludes}"Menus.h ¶ - "{CIncludes}"Power.h ¶ - "{CIncludes}"Printing.h ¶ - "{CIncludes}"Processes.h ¶ - "{CIncludes}"QDOffscreen.h ¶ - "{CIncludes}"QuickDraw.h ¶ - "{CIncludes}"Resources.h ¶ - "{CIncludes}"Scrap.h ¶ - "{CIncludes}"Script.h ¶ - "{CIncludes}"SegLoad.h ¶ - "{CIncludes}"Sound.h ¶ - "{CIncludes}"StandardFile.h ¶ - "{CIncludes}"Strings.h ¶ - "{CIncludes}"TextUtils.h ¶ - "{CIncludes}"ToolUtils.h ¶ - ::byterun:rotatecursor.h ¶ - :ocamlconstants.h ¶ - "{CIncludes}"NullDef.h ¶ - "{CIncludes}"SizeTDef.h ¶ - "{CIncludes}"SeekDefs.h ¶ - "{CIncludes}"VaListTDef.h ¶ - "{CIncludes}"WCharTDef.h ¶ - "{CIncludes}"MacErrors.h ¶ - "{CIncludes}"MixedMode.h ¶ - "{CIncludes}"AEDataModel.h ¶ - "{CIncludes}"AEInteraction.h ¶ - "{CIncludes}"Appearance.h ¶ - "{CIncludes}"CarbonEvents.h ¶ - "{CIncludes}"Lists.h ¶ - "{CIncludes}"MacHelp.h ¶ - "{CIncludes}"CFString.h ¶ - "{CIncludes}"TextEdit.h ¶ - "{CIncludes}"Icons.h ¶ - "{CIncludes}"Collections.h ¶ - "{CIncludes}"OSUtils.h ¶ - "{CIncludes}"Files.h ¶ - "{CIncludes}"NameRegistry.h ¶ - "{CIncludes}"CodeFragments.h ¶ - "{CIncludes}"Multiprocessing.h ¶ - "{CIncludes}"DriverFamilyMatching.h ¶ - "{CIncludes}"Disks.h ¶ - "{CIncludes}"Events.h ¶ - "{CIncludes}"ATSTypes.h ¶ - "{CIncludes}"TextCommon.h ¶ - "{CIncludes}"MacMemory.h ¶ - "{CIncludes}"ConditionalMacros.h ¶ - "{CIncludes}"Aliases.h ¶ - "{CIncludes}"Components.h ¶ - "{CIncludes}"QuickdrawText.h ¶ - "{CIncludes}"CGContext.h ¶ - "{CIncludes}"IntlResources.h ¶ - "{CIncludes}"NumberFormatting.h ¶ - "{CIncludes}"StringCompare.h ¶ - "{CIncludes}"DateTimeUtils.h ¶ - "{CIncludes}"Notification.h ¶ - "{CIncludes}"Balloons.h ¶ - "{CIncludes}"CFBase.h ¶ - "{CIncludes}"CFArray.h ¶ - "{CIncludes}"CFData.h ¶ - "{CIncludes}"CFDictionary.h ¶ - "{CIncludes}"stdarg.h ¶ - "{CIncludes}"Patches.h ¶ - "{CIncludes}"Endian.h ¶ - "{CIncludes}"UTCUtils.h ¶ - "{CIncludes}"CFBundle.h ¶ - "{CIncludes}"CGBase.h ¶ - "{CIncludes}"CGAffineTransform.h ¶ - "{CIncludes}"CGColorSpace.h ¶ - "{CIncludes}"CGFont.h ¶ - "{CIncludes}"CGImage.h ¶ - "{CIncludes}"CGPDFDocument.h ¶ - "{CIncludes}"TypeSelect.h ¶ - "{CIncludes}"CFURL.h ¶ - "{CIncludes}"stddef.h ¶ - "{CIncludes}"CGGeometry.h ¶ - "{CIncludes}"CGDataProvider.h - -:appleevents.c.x Ä ¶ - :appleevents.c ¶ - :main.h ¶ - "{CIncludes}"limits.h ¶ - "{CIncludes}"signal.h ¶ - "{CIncludes}"stdio.h ¶ - "{CIncludes}"stdlib.h ¶ - "{CIncludes}"string.h ¶ - "{CIncludes}"AERegistry.h ¶ - "{CIncludes}"AppleEvents.h ¶ - "{CIncludes}"ControlDefinitions.h ¶ - "{CIncludes}"Controls.h ¶ - "{CIncludes}"Devices.h ¶ - "{CIncludes}"Dialogs.h ¶ - "{CIncludes}"DiskInit.h ¶ - "{CIncludes}"Drag.h ¶ - "{CIncludes}"Finder.h ¶ - "{CIncludes}"FixMath.h ¶ - "{CIncludes}"Folders.h ¶ - "{CIncludes}"Fonts.h ¶ - "{CIncludes}"Gestalt.h ¶ - "{CIncludes}"LowMem.h ¶ - "{CIncludes}"MacTypes.h ¶ - "{CIncludes}"MacWindows.h ¶ - "{CIncludes}"Menus.h ¶ - "{CIncludes}"Power.h ¶ - "{CIncludes}"Printing.h ¶ - "{CIncludes}"Processes.h ¶ - "{CIncludes}"QDOffscreen.h ¶ - "{CIncludes}"QuickDraw.h ¶ - "{CIncludes}"Resources.h ¶ - "{CIncludes}"Scrap.h ¶ - "{CIncludes}"Script.h ¶ - "{CIncludes}"SegLoad.h ¶ - "{CIncludes}"Sound.h ¶ - "{CIncludes}"StandardFile.h ¶ - "{CIncludes}"Strings.h ¶ - "{CIncludes}"TextUtils.h ¶ - "{CIncludes}"ToolUtils.h ¶ - ::byterun:rotatecursor.h ¶ - :ocamlconstants.h ¶ - "{CIncludes}"NullDef.h ¶ - "{CIncludes}"SizeTDef.h ¶ - "{CIncludes}"SeekDefs.h ¶ - "{CIncludes}"VaListTDef.h ¶ - "{CIncludes}"WCharTDef.h ¶ - "{CIncludes}"MacErrors.h ¶ - "{CIncludes}"MixedMode.h ¶ - "{CIncludes}"AEDataModel.h ¶ - "{CIncludes}"AEInteraction.h ¶ - "{CIncludes}"Appearance.h ¶ - "{CIncludes}"CarbonEvents.h ¶ - "{CIncludes}"Lists.h ¶ - "{CIncludes}"MacHelp.h ¶ - "{CIncludes}"CFString.h ¶ - "{CIncludes}"TextEdit.h ¶ - "{CIncludes}"Icons.h ¶ - "{CIncludes}"Collections.h ¶ - "{CIncludes}"OSUtils.h ¶ - "{CIncludes}"Files.h ¶ - "{CIncludes}"NameRegistry.h ¶ - "{CIncludes}"CodeFragments.h ¶ - "{CIncludes}"Multiprocessing.h ¶ - "{CIncludes}"DriverFamilyMatching.h ¶ - "{CIncludes}"Disks.h ¶ - "{CIncludes}"Events.h ¶ - "{CIncludes}"ATSTypes.h ¶ - "{CIncludes}"TextCommon.h ¶ - "{CIncludes}"MacMemory.h ¶ - "{CIncludes}"ConditionalMacros.h ¶ - "{CIncludes}"Aliases.h ¶ - "{CIncludes}"Components.h ¶ - "{CIncludes}"QuickdrawText.h ¶ - "{CIncludes}"CGContext.h ¶ - "{CIncludes}"IntlResources.h ¶ - "{CIncludes}"NumberFormatting.h ¶ - "{CIncludes}"StringCompare.h ¶ - "{CIncludes}"DateTimeUtils.h ¶ - "{CIncludes}"Notification.h ¶ - "{CIncludes}"Balloons.h ¶ - "{CIncludes}"CFBase.h ¶ - "{CIncludes}"CFArray.h ¶ - "{CIncludes}"CFData.h ¶ - "{CIncludes}"CFDictionary.h ¶ - "{CIncludes}"stdarg.h ¶ - "{CIncludes}"Patches.h ¶ - "{CIncludes}"Endian.h ¶ - "{CIncludes}"UTCUtils.h ¶ - "{CIncludes}"CFBundle.h ¶ - "{CIncludes}"CGBase.h ¶ - "{CIncludes}"CGAffineTransform.h ¶ - "{CIncludes}"CGColorSpace.h ¶ - "{CIncludes}"CGFont.h ¶ - "{CIncludes}"CGImage.h ¶ - "{CIncludes}"CGPDFDocument.h ¶ - "{CIncludes}"TypeSelect.h ¶ - "{CIncludes}"CFURL.h ¶ - "{CIncludes}"stddef.h ¶ - "{CIncludes}"CGGeometry.h ¶ - "{CIncludes}"CGDataProvider.h - -:clipboard.c.x Ä ¶ - :clipboard.c ¶ - :main.h ¶ - "{CIncludes}"limits.h ¶ - "{CIncludes}"signal.h ¶ - "{CIncludes}"stdio.h ¶ - "{CIncludes}"stdlib.h ¶ - "{CIncludes}"string.h ¶ - "{CIncludes}"AERegistry.h ¶ - "{CIncludes}"AppleEvents.h ¶ - "{CIncludes}"ControlDefinitions.h ¶ - "{CIncludes}"Controls.h ¶ - "{CIncludes}"Devices.h ¶ - "{CIncludes}"Dialogs.h ¶ - "{CIncludes}"DiskInit.h ¶ - "{CIncludes}"Drag.h ¶ - "{CIncludes}"Finder.h ¶ - "{CIncludes}"FixMath.h ¶ - "{CIncludes}"Folders.h ¶ - "{CIncludes}"Fonts.h ¶ - "{CIncludes}"Gestalt.h ¶ - "{CIncludes}"LowMem.h ¶ - "{CIncludes}"MacTypes.h ¶ - "{CIncludes}"MacWindows.h ¶ - "{CIncludes}"Menus.h ¶ - "{CIncludes}"Power.h ¶ - "{CIncludes}"Printing.h ¶ - "{CIncludes}"Processes.h ¶ - "{CIncludes}"QDOffscreen.h ¶ - "{CIncludes}"QuickDraw.h ¶ - "{CIncludes}"Resources.h ¶ - "{CIncludes}"Scrap.h ¶ - "{CIncludes}"Script.h ¶ - "{CIncludes}"SegLoad.h ¶ - "{CIncludes}"Sound.h ¶ - "{CIncludes}"StandardFile.h ¶ - "{CIncludes}"Strings.h ¶ - "{CIncludes}"TextUtils.h ¶ - "{CIncludes}"ToolUtils.h ¶ - ::byterun:rotatecursor.h ¶ - :ocamlconstants.h ¶ - "{CIncludes}"NullDef.h ¶ - "{CIncludes}"SizeTDef.h ¶ - "{CIncludes}"SeekDefs.h ¶ - "{CIncludes}"VaListTDef.h ¶ - "{CIncludes}"WCharTDef.h ¶ - "{CIncludes}"MacErrors.h ¶ - "{CIncludes}"MixedMode.h ¶ - "{CIncludes}"AEDataModel.h ¶ - "{CIncludes}"AEInteraction.h ¶ - "{CIncludes}"Appearance.h ¶ - "{CIncludes}"CarbonEvents.h ¶ - "{CIncludes}"Lists.h ¶ - "{CIncludes}"MacHelp.h ¶ - "{CIncludes}"CFString.h ¶ - "{CIncludes}"TextEdit.h ¶ - "{CIncludes}"Icons.h ¶ - "{CIncludes}"Collections.h ¶ - "{CIncludes}"OSUtils.h ¶ - "{CIncludes}"Files.h ¶ - "{CIncludes}"NameRegistry.h ¶ - "{CIncludes}"CodeFragments.h ¶ - "{CIncludes}"Multiprocessing.h ¶ - "{CIncludes}"DriverFamilyMatching.h ¶ - "{CIncludes}"Disks.h ¶ - "{CIncludes}"Events.h ¶ - "{CIncludes}"ATSTypes.h ¶ - "{CIncludes}"TextCommon.h ¶ - "{CIncludes}"MacMemory.h ¶ - "{CIncludes}"ConditionalMacros.h ¶ - "{CIncludes}"Aliases.h ¶ - "{CIncludes}"Components.h ¶ - "{CIncludes}"QuickdrawText.h ¶ - "{CIncludes}"CGContext.h ¶ - "{CIncludes}"IntlResources.h ¶ - "{CIncludes}"NumberFormatting.h ¶ - "{CIncludes}"StringCompare.h ¶ - "{CIncludes}"DateTimeUtils.h ¶ - "{CIncludes}"Notification.h ¶ - "{CIncludes}"Balloons.h ¶ - "{CIncludes}"CFBase.h ¶ - "{CIncludes}"CFArray.h ¶ - "{CIncludes}"CFData.h ¶ - "{CIncludes}"CFDictionary.h ¶ - "{CIncludes}"stdarg.h ¶ - "{CIncludes}"Patches.h ¶ - "{CIncludes}"Endian.h ¶ - "{CIncludes}"UTCUtils.h ¶ - "{CIncludes}"CFBundle.h ¶ - "{CIncludes}"CGBase.h ¶ - "{CIncludes}"CGAffineTransform.h ¶ - "{CIncludes}"CGColorSpace.h ¶ - "{CIncludes}"CGFont.h ¶ - "{CIncludes}"CGImage.h ¶ - "{CIncludes}"CGPDFDocument.h ¶ - "{CIncludes}"TypeSelect.h ¶ - "{CIncludes}"CFURL.h ¶ - "{CIncludes}"stddef.h ¶ - "{CIncludes}"CGGeometry.h ¶ - "{CIncludes}"CGDataProvider.h - -:drag.c.x Ä ¶ - :drag.c ¶ - :main.h ¶ - "{CIncludes}"limits.h ¶ - "{CIncludes}"signal.h ¶ - "{CIncludes}"stdio.h ¶ - "{CIncludes}"stdlib.h ¶ - "{CIncludes}"string.h ¶ - "{CIncludes}"AERegistry.h ¶ - "{CIncludes}"AppleEvents.h ¶ - "{CIncludes}"ControlDefinitions.h ¶ - "{CIncludes}"Controls.h ¶ - "{CIncludes}"Devices.h ¶ - "{CIncludes}"Dialogs.h ¶ - "{CIncludes}"DiskInit.h ¶ - "{CIncludes}"Drag.h ¶ - "{CIncludes}"Finder.h ¶ - "{CIncludes}"FixMath.h ¶ - "{CIncludes}"Folders.h ¶ - "{CIncludes}"Fonts.h ¶ - "{CIncludes}"Gestalt.h ¶ - "{CIncludes}"LowMem.h ¶ - "{CIncludes}"MacTypes.h ¶ - "{CIncludes}"MacWindows.h ¶ - "{CIncludes}"Menus.h ¶ - "{CIncludes}"Power.h ¶ - "{CIncludes}"Printing.h ¶ - "{CIncludes}"Processes.h ¶ - "{CIncludes}"QDOffscreen.h ¶ - "{CIncludes}"QuickDraw.h ¶ - "{CIncludes}"Resources.h ¶ - "{CIncludes}"Scrap.h ¶ - "{CIncludes}"Script.h ¶ - "{CIncludes}"SegLoad.h ¶ - "{CIncludes}"Sound.h ¶ - "{CIncludes}"StandardFile.h ¶ - "{CIncludes}"Strings.h ¶ - "{CIncludes}"TextUtils.h ¶ - "{CIncludes}"ToolUtils.h ¶ - ::byterun:rotatecursor.h ¶ - :ocamlconstants.h ¶ - "{CIncludes}"NullDef.h ¶ - "{CIncludes}"SizeTDef.h ¶ - "{CIncludes}"SeekDefs.h ¶ - "{CIncludes}"VaListTDef.h ¶ - "{CIncludes}"WCharTDef.h ¶ - "{CIncludes}"MacErrors.h ¶ - "{CIncludes}"MixedMode.h ¶ - "{CIncludes}"AEDataModel.h ¶ - "{CIncludes}"AEInteraction.h ¶ - "{CIncludes}"Appearance.h ¶ - "{CIncludes}"CarbonEvents.h ¶ - "{CIncludes}"Lists.h ¶ - "{CIncludes}"MacHelp.h ¶ - "{CIncludes}"CFString.h ¶ - "{CIncludes}"TextEdit.h ¶ - "{CIncludes}"Icons.h ¶ - "{CIncludes}"Collections.h ¶ - "{CIncludes}"OSUtils.h ¶ - "{CIncludes}"Files.h ¶ - "{CIncludes}"NameRegistry.h ¶ - "{CIncludes}"CodeFragments.h ¶ - "{CIncludes}"Multiprocessing.h ¶ - "{CIncludes}"DriverFamilyMatching.h ¶ - "{CIncludes}"Disks.h ¶ - "{CIncludes}"Events.h ¶ - "{CIncludes}"ATSTypes.h ¶ - "{CIncludes}"TextCommon.h ¶ - "{CIncludes}"MacMemory.h ¶ - "{CIncludes}"ConditionalMacros.h ¶ - "{CIncludes}"Aliases.h ¶ - "{CIncludes}"Components.h ¶ - "{CIncludes}"QuickdrawText.h ¶ - "{CIncludes}"CGContext.h ¶ - "{CIncludes}"IntlResources.h ¶ - "{CIncludes}"NumberFormatting.h ¶ - "{CIncludes}"StringCompare.h ¶ - "{CIncludes}"DateTimeUtils.h ¶ - "{CIncludes}"Notification.h ¶ - "{CIncludes}"Balloons.h ¶ - "{CIncludes}"CFBase.h ¶ - "{CIncludes}"CFArray.h ¶ - "{CIncludes}"CFData.h ¶ - "{CIncludes}"CFDictionary.h ¶ - "{CIncludes}"stdarg.h ¶ - "{CIncludes}"Patches.h ¶ - "{CIncludes}"Endian.h ¶ - "{CIncludes}"UTCUtils.h ¶ - "{CIncludes}"CFBundle.h ¶ - "{CIncludes}"CGBase.h ¶ - "{CIncludes}"CGAffineTransform.h ¶ - "{CIncludes}"CGColorSpace.h ¶ - "{CIncludes}"CGFont.h ¶ - "{CIncludes}"CGImage.h ¶ - "{CIncludes}"CGPDFDocument.h ¶ - "{CIncludes}"TypeSelect.h ¶ - "{CIncludes}"CFURL.h ¶ - "{CIncludes}"stddef.h ¶ - "{CIncludes}"CGGeometry.h ¶ - "{CIncludes}"CGDataProvider.h - -:dummy_fragment.c.x Ä ¶ - :dummy_fragment.c - -:errors.c.x Ä ¶ - :errors.c ¶ - :main.h ¶ - "{CIncludes}"limits.h ¶ - "{CIncludes}"signal.h ¶ - "{CIncludes}"stdio.h ¶ - "{CIncludes}"stdlib.h ¶ - "{CIncludes}"string.h ¶ - "{CIncludes}"AERegistry.h ¶ - "{CIncludes}"AppleEvents.h ¶ - "{CIncludes}"ControlDefinitions.h ¶ - "{CIncludes}"Controls.h ¶ - "{CIncludes}"Devices.h ¶ - "{CIncludes}"Dialogs.h ¶ - "{CIncludes}"DiskInit.h ¶ - "{CIncludes}"Drag.h ¶ - "{CIncludes}"Finder.h ¶ - "{CIncludes}"FixMath.h ¶ - "{CIncludes}"Folders.h ¶ - "{CIncludes}"Fonts.h ¶ - "{CIncludes}"Gestalt.h ¶ - "{CIncludes}"LowMem.h ¶ - "{CIncludes}"MacTypes.h ¶ - "{CIncludes}"MacWindows.h ¶ - "{CIncludes}"Menus.h ¶ - "{CIncludes}"Power.h ¶ - "{CIncludes}"Printing.h ¶ - "{CIncludes}"Processes.h ¶ - "{CIncludes}"QDOffscreen.h ¶ - "{CIncludes}"QuickDraw.h ¶ - "{CIncludes}"Resources.h ¶ - "{CIncludes}"Scrap.h ¶ - "{CIncludes}"Script.h ¶ - "{CIncludes}"SegLoad.h ¶ - "{CIncludes}"Sound.h ¶ - "{CIncludes}"StandardFile.h ¶ - "{CIncludes}"Strings.h ¶ - "{CIncludes}"TextUtils.h ¶ - "{CIncludes}"ToolUtils.h ¶ - ::byterun:rotatecursor.h ¶ - :ocamlconstants.h ¶ - "{CIncludes}"NullDef.h ¶ - "{CIncludes}"SizeTDef.h ¶ - "{CIncludes}"SeekDefs.h ¶ - "{CIncludes}"VaListTDef.h ¶ - "{CIncludes}"WCharTDef.h ¶ - "{CIncludes}"MacErrors.h ¶ - "{CIncludes}"MixedMode.h ¶ - "{CIncludes}"AEDataModel.h ¶ - "{CIncludes}"AEInteraction.h ¶ - "{CIncludes}"Appearance.h ¶ - "{CIncludes}"CarbonEvents.h ¶ - "{CIncludes}"Lists.h ¶ - "{CIncludes}"MacHelp.h ¶ - "{CIncludes}"CFString.h ¶ - "{CIncludes}"TextEdit.h ¶ - "{CIncludes}"Icons.h ¶ - "{CIncludes}"Collections.h ¶ - "{CIncludes}"OSUtils.h ¶ - "{CIncludes}"Files.h ¶ - "{CIncludes}"NameRegistry.h ¶ - "{CIncludes}"CodeFragments.h ¶ - "{CIncludes}"Multiprocessing.h ¶ - "{CIncludes}"DriverFamilyMatching.h ¶ - "{CIncludes}"Disks.h ¶ - "{CIncludes}"Events.h ¶ - "{CIncludes}"ATSTypes.h ¶ - "{CIncludes}"TextCommon.h ¶ - "{CIncludes}"MacMemory.h ¶ - "{CIncludes}"ConditionalMacros.h ¶ - "{CIncludes}"Aliases.h ¶ - "{CIncludes}"Components.h ¶ - "{CIncludes}"QuickdrawText.h ¶ - "{CIncludes}"CGContext.h ¶ - "{CIncludes}"IntlResources.h ¶ - "{CIncludes}"NumberFormatting.h ¶ - "{CIncludes}"StringCompare.h ¶ - "{CIncludes}"DateTimeUtils.h ¶ - "{CIncludes}"Notification.h ¶ - "{CIncludes}"Balloons.h ¶ - "{CIncludes}"CFBase.h ¶ - "{CIncludes}"CFArray.h ¶ - "{CIncludes}"CFData.h ¶ - "{CIncludes}"CFDictionary.h ¶ - "{CIncludes}"stdarg.h ¶ - "{CIncludes}"Patches.h ¶ - "{CIncludes}"Endian.h ¶ - "{CIncludes}"UTCUtils.h ¶ - "{CIncludes}"CFBundle.h ¶ - "{CIncludes}"CGBase.h ¶ - "{CIncludes}"CGAffineTransform.h ¶ - "{CIncludes}"CGColorSpace.h ¶ - "{CIncludes}"CGFont.h ¶ - "{CIncludes}"CGImage.h ¶ - "{CIncludes}"CGPDFDocument.h ¶ - "{CIncludes}"TypeSelect.h ¶ - "{CIncludes}"CFURL.h ¶ - "{CIncludes}"stddef.h ¶ - "{CIncludes}"CGGeometry.h ¶ - "{CIncludes}"CGDataProvider.h - -:events.c.x Ä ¶ - :events.c ¶ - :main.h ¶ - "{CIncludes}"limits.h ¶ - "{CIncludes}"signal.h ¶ - "{CIncludes}"stdio.h ¶ - "{CIncludes}"stdlib.h ¶ - "{CIncludes}"string.h ¶ - "{CIncludes}"AERegistry.h ¶ - "{CIncludes}"AppleEvents.h ¶ - "{CIncludes}"ControlDefinitions.h ¶ - "{CIncludes}"Controls.h ¶ - "{CIncludes}"Devices.h ¶ - "{CIncludes}"Dialogs.h ¶ - "{CIncludes}"DiskInit.h ¶ - "{CIncludes}"Drag.h ¶ - "{CIncludes}"Finder.h ¶ - "{CIncludes}"FixMath.h ¶ - "{CIncludes}"Folders.h ¶ - "{CIncludes}"Fonts.h ¶ - "{CIncludes}"Gestalt.h ¶ - "{CIncludes}"LowMem.h ¶ - "{CIncludes}"MacTypes.h ¶ - "{CIncludes}"MacWindows.h ¶ - "{CIncludes}"Menus.h ¶ - "{CIncludes}"Power.h ¶ - "{CIncludes}"Printing.h ¶ - "{CIncludes}"Processes.h ¶ - "{CIncludes}"QDOffscreen.h ¶ - "{CIncludes}"QuickDraw.h ¶ - "{CIncludes}"Resources.h ¶ - "{CIncludes}"Scrap.h ¶ - "{CIncludes}"Script.h ¶ - "{CIncludes}"SegLoad.h ¶ - "{CIncludes}"Sound.h ¶ - "{CIncludes}"StandardFile.h ¶ - "{CIncludes}"Strings.h ¶ - "{CIncludes}"TextUtils.h ¶ - "{CIncludes}"ToolUtils.h ¶ - ::byterun:rotatecursor.h ¶ - :ocamlconstants.h ¶ - "{CIncludes}"NullDef.h ¶ - "{CIncludes}"SizeTDef.h ¶ - "{CIncludes}"SeekDefs.h ¶ - "{CIncludes}"VaListTDef.h ¶ - "{CIncludes}"WCharTDef.h ¶ - "{CIncludes}"MacErrors.h ¶ - "{CIncludes}"MixedMode.h ¶ - "{CIncludes}"AEDataModel.h ¶ - "{CIncludes}"AEInteraction.h ¶ - "{CIncludes}"Appearance.h ¶ - "{CIncludes}"CarbonEvents.h ¶ - "{CIncludes}"Lists.h ¶ - "{CIncludes}"MacHelp.h ¶ - "{CIncludes}"CFString.h ¶ - "{CIncludes}"TextEdit.h ¶ - "{CIncludes}"Icons.h ¶ - "{CIncludes}"Collections.h ¶ - "{CIncludes}"OSUtils.h ¶ - "{CIncludes}"Files.h ¶ - "{CIncludes}"NameRegistry.h ¶ - "{CIncludes}"CodeFragments.h ¶ - "{CIncludes}"Multiprocessing.h ¶ - "{CIncludes}"DriverFamilyMatching.h ¶ - "{CIncludes}"Disks.h ¶ - "{CIncludes}"Events.h ¶ - "{CIncludes}"ATSTypes.h ¶ - "{CIncludes}"TextCommon.h ¶ - "{CIncludes}"MacMemory.h ¶ - "{CIncludes}"ConditionalMacros.h ¶ - "{CIncludes}"Aliases.h ¶ - "{CIncludes}"Components.h ¶ - "{CIncludes}"QuickdrawText.h ¶ - "{CIncludes}"CGContext.h ¶ - "{CIncludes}"IntlResources.h ¶ - "{CIncludes}"NumberFormatting.h ¶ - "{CIncludes}"StringCompare.h ¶ - "{CIncludes}"DateTimeUtils.h ¶ - "{CIncludes}"Notification.h ¶ - "{CIncludes}"Balloons.h ¶ - "{CIncludes}"CFBase.h ¶ - "{CIncludes}"CFArray.h ¶ - "{CIncludes}"CFData.h ¶ - "{CIncludes}"CFDictionary.h ¶ - "{CIncludes}"stdarg.h ¶ - "{CIncludes}"Patches.h ¶ - "{CIncludes}"Endian.h ¶ - "{CIncludes}"UTCUtils.h ¶ - "{CIncludes}"CFBundle.h ¶ - "{CIncludes}"CGBase.h ¶ - "{CIncludes}"CGAffineTransform.h ¶ - "{CIncludes}"CGColorSpace.h ¶ - "{CIncludes}"CGFont.h ¶ - "{CIncludes}"CGImage.h ¶ - "{CIncludes}"CGPDFDocument.h ¶ - "{CIncludes}"TypeSelect.h ¶ - "{CIncludes}"CFURL.h ¶ - "{CIncludes}"stddef.h ¶ - "{CIncludes}"CGGeometry.h ¶ - "{CIncludes}"CGDataProvider.h - -:files.c.x Ä ¶ - :files.c ¶ - :main.h ¶ - "{CIncludes}"limits.h ¶ - "{CIncludes}"signal.h ¶ - "{CIncludes}"stdio.h ¶ - "{CIncludes}"stdlib.h ¶ - "{CIncludes}"string.h ¶ - "{CIncludes}"AERegistry.h ¶ - "{CIncludes}"AppleEvents.h ¶ - "{CIncludes}"ControlDefinitions.h ¶ - "{CIncludes}"Controls.h ¶ - "{CIncludes}"Devices.h ¶ - "{CIncludes}"Dialogs.h ¶ - "{CIncludes}"DiskInit.h ¶ - "{CIncludes}"Drag.h ¶ - "{CIncludes}"Finder.h ¶ - "{CIncludes}"FixMath.h ¶ - "{CIncludes}"Folders.h ¶ - "{CIncludes}"Fonts.h ¶ - "{CIncludes}"Gestalt.h ¶ - "{CIncludes}"LowMem.h ¶ - "{CIncludes}"MacTypes.h ¶ - "{CIncludes}"MacWindows.h ¶ - "{CIncludes}"Menus.h ¶ - "{CIncludes}"Power.h ¶ - "{CIncludes}"Printing.h ¶ - "{CIncludes}"Processes.h ¶ - "{CIncludes}"QDOffscreen.h ¶ - "{CIncludes}"QuickDraw.h ¶ - "{CIncludes}"Resources.h ¶ - "{CIncludes}"Scrap.h ¶ - "{CIncludes}"Script.h ¶ - "{CIncludes}"SegLoad.h ¶ - "{CIncludes}"Sound.h ¶ - "{CIncludes}"StandardFile.h ¶ - "{CIncludes}"Strings.h ¶ - "{CIncludes}"TextUtils.h ¶ - "{CIncludes}"ToolUtils.h ¶ - ::byterun:rotatecursor.h ¶ - :ocamlconstants.h ¶ - "{CIncludes}"NullDef.h ¶ - "{CIncludes}"SizeTDef.h ¶ - "{CIncludes}"SeekDefs.h ¶ - "{CIncludes}"VaListTDef.h ¶ - "{CIncludes}"WCharTDef.h ¶ - "{CIncludes}"MacErrors.h ¶ - "{CIncludes}"MixedMode.h ¶ - "{CIncludes}"AEDataModel.h ¶ - "{CIncludes}"AEInteraction.h ¶ - "{CIncludes}"Appearance.h ¶ - "{CIncludes}"CarbonEvents.h ¶ - "{CIncludes}"Lists.h ¶ - "{CIncludes}"MacHelp.h ¶ - "{CIncludes}"CFString.h ¶ - "{CIncludes}"TextEdit.h ¶ - "{CIncludes}"Icons.h ¶ - "{CIncludes}"Collections.h ¶ - "{CIncludes}"OSUtils.h ¶ - "{CIncludes}"Files.h ¶ - "{CIncludes}"NameRegistry.h ¶ - "{CIncludes}"CodeFragments.h ¶ - "{CIncludes}"Multiprocessing.h ¶ - "{CIncludes}"DriverFamilyMatching.h ¶ - "{CIncludes}"Disks.h ¶ - "{CIncludes}"Events.h ¶ - "{CIncludes}"ATSTypes.h ¶ - "{CIncludes}"TextCommon.h ¶ - "{CIncludes}"MacMemory.h ¶ - "{CIncludes}"ConditionalMacros.h ¶ - "{CIncludes}"Aliases.h ¶ - "{CIncludes}"Components.h ¶ - "{CIncludes}"QuickdrawText.h ¶ - "{CIncludes}"CGContext.h ¶ - "{CIncludes}"IntlResources.h ¶ - "{CIncludes}"NumberFormatting.h ¶ - "{CIncludes}"StringCompare.h ¶ - "{CIncludes}"DateTimeUtils.h ¶ - "{CIncludes}"Notification.h ¶ - "{CIncludes}"Balloons.h ¶ - "{CIncludes}"CFBase.h ¶ - "{CIncludes}"CFArray.h ¶ - "{CIncludes}"CFData.h ¶ - "{CIncludes}"CFDictionary.h ¶ - "{CIncludes}"stdarg.h ¶ - "{CIncludes}"Patches.h ¶ - "{CIncludes}"Endian.h ¶ - "{CIncludes}"UTCUtils.h ¶ - "{CIncludes}"CFBundle.h ¶ - "{CIncludes}"CGBase.h ¶ - "{CIncludes}"CGAffineTransform.h ¶ - "{CIncludes}"CGColorSpace.h ¶ - "{CIncludes}"CGFont.h ¶ - "{CIncludes}"CGImage.h ¶ - "{CIncludes}"CGPDFDocument.h ¶ - "{CIncludes}"TypeSelect.h ¶ - "{CIncludes}"CFURL.h ¶ - "{CIncludes}"stddef.h ¶ - "{CIncludes}"CGGeometry.h ¶ - "{CIncludes}"CGDataProvider.h - -:glue.c.x Ä ¶ - :glue.c ¶ - "{CIncludes}"CursorCtl.h ¶ - "{CIncludes}"fcntl.h ¶ - "{CIncludes}"signal.h ¶ - "{CIncludes}"stdlib.h ¶ - :main.h ¶ - "{CIncludes}"SeekDefs.h ¶ - "{CIncludes}"SizeTDef.h ¶ - "{CIncludes}"NullDef.h ¶ - "{CIncludes}"WCharTDef.h ¶ - "{CIncludes}"limits.h ¶ - "{CIncludes}"stdio.h ¶ - "{CIncludes}"string.h ¶ - "{CIncludes}"AERegistry.h ¶ - "{CIncludes}"AppleEvents.h ¶ - "{CIncludes}"ControlDefinitions.h ¶ - "{CIncludes}"Controls.h ¶ - "{CIncludes}"Devices.h ¶ - "{CIncludes}"Dialogs.h ¶ - "{CIncludes}"DiskInit.h ¶ - "{CIncludes}"Drag.h ¶ - "{CIncludes}"Finder.h ¶ - "{CIncludes}"FixMath.h ¶ - "{CIncludes}"Folders.h ¶ - "{CIncludes}"Fonts.h ¶ - "{CIncludes}"Gestalt.h ¶ - "{CIncludes}"LowMem.h ¶ - "{CIncludes}"MacTypes.h ¶ - "{CIncludes}"MacWindows.h ¶ - "{CIncludes}"Menus.h ¶ - "{CIncludes}"Power.h ¶ - "{CIncludes}"Printing.h ¶ - "{CIncludes}"Processes.h ¶ - "{CIncludes}"QDOffscreen.h ¶ - "{CIncludes}"QuickDraw.h ¶ - "{CIncludes}"Resources.h ¶ - "{CIncludes}"Scrap.h ¶ - "{CIncludes}"Script.h ¶ - "{CIncludes}"SegLoad.h ¶ - "{CIncludes}"Sound.h ¶ - "{CIncludes}"StandardFile.h ¶ - "{CIncludes}"Strings.h ¶ - "{CIncludes}"TextUtils.h ¶ - "{CIncludes}"ToolUtils.h ¶ - ::byterun:rotatecursor.h ¶ - :ocamlconstants.h ¶ - "{CIncludes}"VaListTDef.h ¶ - "{CIncludes}"MacErrors.h ¶ - "{CIncludes}"MixedMode.h ¶ - "{CIncludes}"AEDataModel.h ¶ - "{CIncludes}"AEInteraction.h ¶ - "{CIncludes}"Appearance.h ¶ - "{CIncludes}"CarbonEvents.h ¶ - "{CIncludes}"Lists.h ¶ - "{CIncludes}"MacHelp.h ¶ - "{CIncludes}"CFString.h ¶ - "{CIncludes}"TextEdit.h ¶ - "{CIncludes}"Icons.h ¶ - "{CIncludes}"Collections.h ¶ - "{CIncludes}"OSUtils.h ¶ - "{CIncludes}"Files.h ¶ - "{CIncludes}"NameRegistry.h ¶ - "{CIncludes}"CodeFragments.h ¶ - "{CIncludes}"Multiprocessing.h ¶ - "{CIncludes}"DriverFamilyMatching.h ¶ - "{CIncludes}"Disks.h ¶ - "{CIncludes}"Events.h ¶ - "{CIncludes}"ATSTypes.h ¶ - "{CIncludes}"TextCommon.h ¶ - "{CIncludes}"MacMemory.h ¶ - "{CIncludes}"ConditionalMacros.h ¶ - "{CIncludes}"Aliases.h ¶ - "{CIncludes}"Components.h ¶ - "{CIncludes}"QuickdrawText.h ¶ - "{CIncludes}"CGContext.h ¶ - "{CIncludes}"IntlResources.h ¶ - "{CIncludes}"NumberFormatting.h ¶ - "{CIncludes}"StringCompare.h ¶ - "{CIncludes}"DateTimeUtils.h ¶ - "{CIncludes}"Notification.h ¶ - "{CIncludes}"Balloons.h ¶ - "{CIncludes}"CFBase.h ¶ - "{CIncludes}"CFArray.h ¶ - "{CIncludes}"CFData.h ¶ - "{CIncludes}"CFDictionary.h ¶ - "{CIncludes}"stdarg.h ¶ - "{CIncludes}"Patches.h ¶ - "{CIncludes}"Endian.h ¶ - "{CIncludes}"UTCUtils.h ¶ - "{CIncludes}"CFBundle.h ¶ - "{CIncludes}"CGBase.h ¶ - "{CIncludes}"CGAffineTransform.h ¶ - "{CIncludes}"CGColorSpace.h ¶ - "{CIncludes}"CGFont.h ¶ - "{CIncludes}"CGImage.h ¶ - "{CIncludes}"CGPDFDocument.h ¶ - "{CIncludes}"TypeSelect.h ¶ - "{CIncludes}"CFURL.h ¶ - "{CIncludes}"stddef.h ¶ - "{CIncludes}"CGGeometry.h ¶ - "{CIncludes}"CGDataProvider.h - -:graph.c.x Ä ¶ - :graph.c ¶ - "{CIncludes}"memory.h ¶ - :main.h ¶ - "{CIncludes}"ConditionalMacros.h ¶ - "{CIncludes}"MacMemory.h ¶ - "{CIncludes}"limits.h ¶ - "{CIncludes}"signal.h ¶ - "{CIncludes}"stdio.h ¶ - "{CIncludes}"stdlib.h ¶ - "{CIncludes}"string.h ¶ - "{CIncludes}"AERegistry.h ¶ - "{CIncludes}"AppleEvents.h ¶ - "{CIncludes}"ControlDefinitions.h ¶ - "{CIncludes}"Controls.h ¶ - "{CIncludes}"Devices.h ¶ - "{CIncludes}"Dialogs.h ¶ - "{CIncludes}"DiskInit.h ¶ - "{CIncludes}"Drag.h ¶ - "{CIncludes}"Finder.h ¶ - "{CIncludes}"FixMath.h ¶ - "{CIncludes}"Folders.h ¶ - "{CIncludes}"Fonts.h ¶ - "{CIncludes}"Gestalt.h ¶ - "{CIncludes}"LowMem.h ¶ - "{CIncludes}"MacTypes.h ¶ - "{CIncludes}"MacWindows.h ¶ - "{CIncludes}"Menus.h ¶ - "{CIncludes}"Power.h ¶ - "{CIncludes}"Printing.h ¶ - "{CIncludes}"Processes.h ¶ - "{CIncludes}"QDOffscreen.h ¶ - "{CIncludes}"QuickDraw.h ¶ - "{CIncludes}"Resources.h ¶ - "{CIncludes}"Scrap.h ¶ - "{CIncludes}"Script.h ¶ - "{CIncludes}"SegLoad.h ¶ - "{CIncludes}"Sound.h ¶ - "{CIncludes}"StandardFile.h ¶ - "{CIncludes}"Strings.h ¶ - "{CIncludes}"TextUtils.h ¶ - "{CIncludes}"ToolUtils.h ¶ - ::byterun:rotatecursor.h ¶ - :ocamlconstants.h ¶ - "{CIncludes}"MixedMode.h ¶ - "{CIncludes}"NullDef.h ¶ - "{CIncludes}"SizeTDef.h ¶ - "{CIncludes}"SeekDefs.h ¶ - "{CIncludes}"VaListTDef.h ¶ - "{CIncludes}"WCharTDef.h ¶ - "{CIncludes}"MacErrors.h ¶ - "{CIncludes}"AEDataModel.h ¶ - "{CIncludes}"AEInteraction.h ¶ - "{CIncludes}"Appearance.h ¶ - "{CIncludes}"CarbonEvents.h ¶ - "{CIncludes}"Lists.h ¶ - "{CIncludes}"MacHelp.h ¶ - "{CIncludes}"CFString.h ¶ - "{CIncludes}"TextEdit.h ¶ - "{CIncludes}"Icons.h ¶ - "{CIncludes}"Collections.h ¶ - "{CIncludes}"OSUtils.h ¶ - "{CIncludes}"Files.h ¶ - "{CIncludes}"NameRegistry.h ¶ - "{CIncludes}"CodeFragments.h ¶ - "{CIncludes}"Multiprocessing.h ¶ - "{CIncludes}"DriverFamilyMatching.h ¶ - "{CIncludes}"Disks.h ¶ - "{CIncludes}"Events.h ¶ - "{CIncludes}"ATSTypes.h ¶ - "{CIncludes}"TextCommon.h ¶ - "{CIncludes}"Aliases.h ¶ - "{CIncludes}"Components.h ¶ - "{CIncludes}"QuickdrawText.h ¶ - "{CIncludes}"CGContext.h ¶ - "{CIncludes}"IntlResources.h ¶ - "{CIncludes}"NumberFormatting.h ¶ - "{CIncludes}"StringCompare.h ¶ - "{CIncludes}"DateTimeUtils.h ¶ - "{CIncludes}"Notification.h ¶ - "{CIncludes}"Balloons.h ¶ - "{CIncludes}"CFBase.h ¶ - "{CIncludes}"CFArray.h ¶ - "{CIncludes}"CFData.h ¶ - "{CIncludes}"CFDictionary.h ¶ - "{CIncludes}"stdarg.h ¶ - "{CIncludes}"Patches.h ¶ - "{CIncludes}"Endian.h ¶ - "{CIncludes}"UTCUtils.h ¶ - "{CIncludes}"CFBundle.h ¶ - "{CIncludes}"CGBase.h ¶ - "{CIncludes}"CGAffineTransform.h ¶ - "{CIncludes}"CGColorSpace.h ¶ - "{CIncludes}"CGFont.h ¶ - "{CIncludes}"CGImage.h ¶ - "{CIncludes}"CGPDFDocument.h ¶ - "{CIncludes}"TypeSelect.h ¶ - "{CIncludes}"CFURL.h ¶ - "{CIncludes}"stddef.h ¶ - "{CIncludes}"CGGeometry.h ¶ - "{CIncludes}"CGDataProvider.h - -:lcontrols.c.x Ä ¶ - :lcontrols.c ¶ - "{CIncludes}"Controls.h ¶ - "{CIncludes}"FixMath.h ¶ - "{CIncludes}"ToolUtils.h ¶ - :main.h ¶ - "{CIncludes}"MacTypes.h ¶ - "{CIncludes}"QuickDraw.h ¶ - "{CIncludes}"Menus.h ¶ - "{CIncludes}"TextEdit.h ¶ - "{CIncludes}"Drag.h ¶ - "{CIncludes}"Icons.h ¶ - "{CIncludes}"Collections.h ¶ - "{CIncludes}"MacErrors.h ¶ - "{CIncludes}"TextUtils.h ¶ - "{CIncludes}"limits.h ¶ - "{CIncludes}"signal.h ¶ - "{CIncludes}"stdio.h ¶ - "{CIncludes}"stdlib.h ¶ - "{CIncludes}"string.h ¶ - "{CIncludes}"AERegistry.h ¶ - "{CIncludes}"AppleEvents.h ¶ - "{CIncludes}"ControlDefinitions.h ¶ - "{CIncludes}"Devices.h ¶ - "{CIncludes}"Dialogs.h ¶ - "{CIncludes}"DiskInit.h ¶ - "{CIncludes}"Finder.h ¶ - "{CIncludes}"Folders.h ¶ - "{CIncludes}"Fonts.h ¶ - "{CIncludes}"Gestalt.h ¶ - "{CIncludes}"LowMem.h ¶ - "{CIncludes}"MacWindows.h ¶ - "{CIncludes}"Power.h ¶ - "{CIncludes}"Printing.h ¶ - "{CIncludes}"Processes.h ¶ - "{CIncludes}"QDOffscreen.h ¶ - "{CIncludes}"Resources.h ¶ - "{CIncludes}"Scrap.h ¶ - "{CIncludes}"Script.h ¶ - "{CIncludes}"SegLoad.h ¶ - "{CIncludes}"Sound.h ¶ - "{CIncludes}"StandardFile.h ¶ - "{CIncludes}"Strings.h ¶ - ::byterun:rotatecursor.h ¶ - :ocamlconstants.h ¶ - "{CIncludes}"ConditionalMacros.h ¶ - "{CIncludes}"Components.h ¶ - "{CIncludes}"MixedMode.h ¶ - "{CIncludes}"QuickdrawText.h ¶ - "{CIncludes}"CGContext.h ¶ - "{CIncludes}"Events.h ¶ - "{CIncludes}"TextCommon.h ¶ - "{CIncludes}"CFString.h ¶ - "{CIncludes}"Files.h ¶ - "{CIncludes}"CodeFragments.h ¶ - "{CIncludes}"NumberFormatting.h ¶ - "{CIncludes}"StringCompare.h ¶ - "{CIncludes}"DateTimeUtils.h ¶ - "{CIncludes}"NullDef.h ¶ - "{CIncludes}"SizeTDef.h ¶ - "{CIncludes}"SeekDefs.h ¶ - "{CIncludes}"VaListTDef.h ¶ - "{CIncludes}"WCharTDef.h ¶ - "{CIncludes}"AEDataModel.h ¶ - "{CIncludes}"AEInteraction.h ¶ - "{CIncludes}"Appearance.h ¶ - "{CIncludes}"CarbonEvents.h ¶ - "{CIncludes}"Lists.h ¶ - "{CIncludes}"MacHelp.h ¶ - "{CIncludes}"OSUtils.h ¶ - "{CIncludes}"NameRegistry.h ¶ - "{CIncludes}"Multiprocessing.h ¶ - "{CIncludes}"DriverFamilyMatching.h ¶ - "{CIncludes}"Disks.h ¶ - "{CIncludes}"ATSTypes.h ¶ - "{CIncludes}"MacMemory.h ¶ - "{CIncludes}"Aliases.h ¶ - "{CIncludes}"IntlResources.h ¶ - "{CIncludes}"CGBase.h ¶ - "{CIncludes}"CGAffineTransform.h ¶ - "{CIncludes}"CGColorSpace.h ¶ - "{CIncludes}"CGFont.h ¶ - "{CIncludes}"CGImage.h ¶ - "{CIncludes}"CGPDFDocument.h ¶ - "{CIncludes}"Endian.h ¶ - "{CIncludes}"CFBase.h ¶ - "{CIncludes}"CFArray.h ¶ - "{CIncludes}"CFData.h ¶ - "{CIncludes}"CFDictionary.h ¶ - "{CIncludes}"stdarg.h ¶ - "{CIncludes}"UTCUtils.h ¶ - "{CIncludes}"CFBundle.h ¶ - "{CIncludes}"TypeSelect.h ¶ - "{CIncludes}"Notification.h ¶ - "{CIncludes}"Balloons.h ¶ - "{CIncludes}"Patches.h ¶ - "{CIncludes}"stddef.h ¶ - "{CIncludes}"CGGeometry.h ¶ - "{CIncludes}"CGDataProvider.h ¶ - "{CIncludes}"CFURL.h - -:lib.c.x Ä ¶ - :lib.c ¶ - :main.h ¶ - "{CIncludes}"limits.h ¶ - "{CIncludes}"signal.h ¶ - "{CIncludes}"stdio.h ¶ - "{CIncludes}"stdlib.h ¶ - "{CIncludes}"string.h ¶ - "{CIncludes}"AERegistry.h ¶ - "{CIncludes}"AppleEvents.h ¶ - "{CIncludes}"ControlDefinitions.h ¶ - "{CIncludes}"Controls.h ¶ - "{CIncludes}"Devices.h ¶ - "{CIncludes}"Dialogs.h ¶ - "{CIncludes}"DiskInit.h ¶ - "{CIncludes}"Drag.h ¶ - "{CIncludes}"Finder.h ¶ - "{CIncludes}"FixMath.h ¶ - "{CIncludes}"Folders.h ¶ - "{CIncludes}"Fonts.h ¶ - "{CIncludes}"Gestalt.h ¶ - "{CIncludes}"LowMem.h ¶ - "{CIncludes}"MacTypes.h ¶ - "{CIncludes}"MacWindows.h ¶ - "{CIncludes}"Menus.h ¶ - "{CIncludes}"Power.h ¶ - "{CIncludes}"Printing.h ¶ - "{CIncludes}"Processes.h ¶ - "{CIncludes}"QDOffscreen.h ¶ - "{CIncludes}"QuickDraw.h ¶ - "{CIncludes}"Resources.h ¶ - "{CIncludes}"Scrap.h ¶ - "{CIncludes}"Script.h ¶ - "{CIncludes}"SegLoad.h ¶ - "{CIncludes}"Sound.h ¶ - "{CIncludes}"StandardFile.h ¶ - "{CIncludes}"Strings.h ¶ - "{CIncludes}"TextUtils.h ¶ - "{CIncludes}"ToolUtils.h ¶ - ::byterun:rotatecursor.h ¶ - :ocamlconstants.h ¶ - "{CIncludes}"NullDef.h ¶ - "{CIncludes}"SizeTDef.h ¶ - "{CIncludes}"SeekDefs.h ¶ - "{CIncludes}"VaListTDef.h ¶ - "{CIncludes}"WCharTDef.h ¶ - "{CIncludes}"MacErrors.h ¶ - "{CIncludes}"MixedMode.h ¶ - "{CIncludes}"AEDataModel.h ¶ - "{CIncludes}"AEInteraction.h ¶ - "{CIncludes}"Appearance.h ¶ - "{CIncludes}"CarbonEvents.h ¶ - "{CIncludes}"Lists.h ¶ - "{CIncludes}"MacHelp.h ¶ - "{CIncludes}"CFString.h ¶ - "{CIncludes}"TextEdit.h ¶ - "{CIncludes}"Icons.h ¶ - "{CIncludes}"Collections.h ¶ - "{CIncludes}"OSUtils.h ¶ - "{CIncludes}"Files.h ¶ - "{CIncludes}"NameRegistry.h ¶ - "{CIncludes}"CodeFragments.h ¶ - "{CIncludes}"Multiprocessing.h ¶ - "{CIncludes}"DriverFamilyMatching.h ¶ - "{CIncludes}"Disks.h ¶ - "{CIncludes}"Events.h ¶ - "{CIncludes}"ATSTypes.h ¶ - "{CIncludes}"TextCommon.h ¶ - "{CIncludes}"MacMemory.h ¶ - "{CIncludes}"ConditionalMacros.h ¶ - "{CIncludes}"Aliases.h ¶ - "{CIncludes}"Components.h ¶ - "{CIncludes}"QuickdrawText.h ¶ - "{CIncludes}"CGContext.h ¶ - "{CIncludes}"IntlResources.h ¶ - "{CIncludes}"NumberFormatting.h ¶ - "{CIncludes}"StringCompare.h ¶ - "{CIncludes}"DateTimeUtils.h ¶ - "{CIncludes}"Notification.h ¶ - "{CIncludes}"Balloons.h ¶ - "{CIncludes}"CFBase.h ¶ - "{CIncludes}"CFArray.h ¶ - "{CIncludes}"CFData.h ¶ - "{CIncludes}"CFDictionary.h ¶ - "{CIncludes}"stdarg.h ¶ - "{CIncludes}"Patches.h ¶ - "{CIncludes}"Endian.h ¶ - "{CIncludes}"UTCUtils.h ¶ - "{CIncludes}"CFBundle.h ¶ - "{CIncludes}"CGBase.h ¶ - "{CIncludes}"CGAffineTransform.h ¶ - "{CIncludes}"CGColorSpace.h ¶ - "{CIncludes}"CGFont.h ¶ - "{CIncludes}"CGImage.h ¶ - "{CIncludes}"CGPDFDocument.h ¶ - "{CIncludes}"TypeSelect.h ¶ - "{CIncludes}"CFURL.h ¶ - "{CIncludes}"stddef.h ¶ - "{CIncludes}"CGGeometry.h ¶ - "{CIncludes}"CGDataProvider.h - -:main.c.x Ä ¶ - :main.c ¶ - :main.h ¶ - "{CIncludes}"limits.h ¶ - "{CIncludes}"signal.h ¶ - "{CIncludes}"stdio.h ¶ - "{CIncludes}"stdlib.h ¶ - "{CIncludes}"string.h ¶ - "{CIncludes}"AERegistry.h ¶ - "{CIncludes}"AppleEvents.h ¶ - "{CIncludes}"ControlDefinitions.h ¶ - "{CIncludes}"Controls.h ¶ - "{CIncludes}"Devices.h ¶ - "{CIncludes}"Dialogs.h ¶ - "{CIncludes}"DiskInit.h ¶ - "{CIncludes}"Drag.h ¶ - "{CIncludes}"Finder.h ¶ - "{CIncludes}"FixMath.h ¶ - "{CIncludes}"Folders.h ¶ - "{CIncludes}"Fonts.h ¶ - "{CIncludes}"Gestalt.h ¶ - "{CIncludes}"LowMem.h ¶ - "{CIncludes}"MacTypes.h ¶ - "{CIncludes}"MacWindows.h ¶ - "{CIncludes}"Menus.h ¶ - "{CIncludes}"Power.h ¶ - "{CIncludes}"Printing.h ¶ - "{CIncludes}"Processes.h ¶ - "{CIncludes}"QDOffscreen.h ¶ - "{CIncludes}"QuickDraw.h ¶ - "{CIncludes}"Resources.h ¶ - "{CIncludes}"Scrap.h ¶ - "{CIncludes}"Script.h ¶ - "{CIncludes}"SegLoad.h ¶ - "{CIncludes}"Sound.h ¶ - "{CIncludes}"StandardFile.h ¶ - "{CIncludes}"Strings.h ¶ - "{CIncludes}"TextUtils.h ¶ - "{CIncludes}"ToolUtils.h ¶ - ::byterun:rotatecursor.h ¶ - :ocamlconstants.h ¶ - "{CIncludes}"NullDef.h ¶ - "{CIncludes}"SizeTDef.h ¶ - "{CIncludes}"SeekDefs.h ¶ - "{CIncludes}"VaListTDef.h ¶ - "{CIncludes}"WCharTDef.h ¶ - "{CIncludes}"MacErrors.h ¶ - "{CIncludes}"MixedMode.h ¶ - "{CIncludes}"AEDataModel.h ¶ - "{CIncludes}"AEInteraction.h ¶ - "{CIncludes}"Appearance.h ¶ - "{CIncludes}"CarbonEvents.h ¶ - "{CIncludes}"Lists.h ¶ - "{CIncludes}"MacHelp.h ¶ - "{CIncludes}"CFString.h ¶ - "{CIncludes}"TextEdit.h ¶ - "{CIncludes}"Icons.h ¶ - "{CIncludes}"Collections.h ¶ - "{CIncludes}"OSUtils.h ¶ - "{CIncludes}"Files.h ¶ - "{CIncludes}"NameRegistry.h ¶ - "{CIncludes}"CodeFragments.h ¶ - "{CIncludes}"Multiprocessing.h ¶ - "{CIncludes}"DriverFamilyMatching.h ¶ - "{CIncludes}"Disks.h ¶ - "{CIncludes}"Events.h ¶ - "{CIncludes}"ATSTypes.h ¶ - "{CIncludes}"TextCommon.h ¶ - "{CIncludes}"MacMemory.h ¶ - "{CIncludes}"ConditionalMacros.h ¶ - "{CIncludes}"Aliases.h ¶ - "{CIncludes}"Components.h ¶ - "{CIncludes}"QuickdrawText.h ¶ - "{CIncludes}"CGContext.h ¶ - "{CIncludes}"IntlResources.h ¶ - "{CIncludes}"NumberFormatting.h ¶ - "{CIncludes}"StringCompare.h ¶ - "{CIncludes}"DateTimeUtils.h ¶ - "{CIncludes}"Notification.h ¶ - "{CIncludes}"Balloons.h ¶ - "{CIncludes}"CFBase.h ¶ - "{CIncludes}"CFArray.h ¶ - "{CIncludes}"CFData.h ¶ - "{CIncludes}"CFDictionary.h ¶ - "{CIncludes}"stdarg.h ¶ - "{CIncludes}"Patches.h ¶ - "{CIncludes}"Endian.h ¶ - "{CIncludes}"UTCUtils.h ¶ - "{CIncludes}"CFBundle.h ¶ - "{CIncludes}"CGBase.h ¶ - "{CIncludes}"CGAffineTransform.h ¶ - "{CIncludes}"CGColorSpace.h ¶ - "{CIncludes}"CGFont.h ¶ - "{CIncludes}"CGImage.h ¶ - "{CIncludes}"CGPDFDocument.h ¶ - "{CIncludes}"TypeSelect.h ¶ - "{CIncludes}"CFURL.h ¶ - "{CIncludes}"stddef.h ¶ - "{CIncludes}"CGGeometry.h ¶ - "{CIncludes}"CGDataProvider.h - -:mcmemory.c.x Ä ¶ - :mcmemory.c ¶ - :main.h ¶ - "{CIncludes}"limits.h ¶ - "{CIncludes}"signal.h ¶ - "{CIncludes}"stdio.h ¶ - "{CIncludes}"stdlib.h ¶ - "{CIncludes}"string.h ¶ - "{CIncludes}"AERegistry.h ¶ - "{CIncludes}"AppleEvents.h ¶ - "{CIncludes}"ControlDefinitions.h ¶ - "{CIncludes}"Controls.h ¶ - "{CIncludes}"Devices.h ¶ - "{CIncludes}"Dialogs.h ¶ - "{CIncludes}"DiskInit.h ¶ - "{CIncludes}"Drag.h ¶ - "{CIncludes}"Finder.h ¶ - "{CIncludes}"FixMath.h ¶ - "{CIncludes}"Folders.h ¶ - "{CIncludes}"Fonts.h ¶ - "{CIncludes}"Gestalt.h ¶ - "{CIncludes}"LowMem.h ¶ - "{CIncludes}"MacTypes.h ¶ - "{CIncludes}"MacWindows.h ¶ - "{CIncludes}"Menus.h ¶ - "{CIncludes}"Power.h ¶ - "{CIncludes}"Printing.h ¶ - "{CIncludes}"Processes.h ¶ - "{CIncludes}"QDOffscreen.h ¶ - "{CIncludes}"QuickDraw.h ¶ - "{CIncludes}"Resources.h ¶ - "{CIncludes}"Scrap.h ¶ - "{CIncludes}"Script.h ¶ - "{CIncludes}"SegLoad.h ¶ - "{CIncludes}"Sound.h ¶ - "{CIncludes}"StandardFile.h ¶ - "{CIncludes}"Strings.h ¶ - "{CIncludes}"TextUtils.h ¶ - "{CIncludes}"ToolUtils.h ¶ - ::byterun:rotatecursor.h ¶ - :ocamlconstants.h ¶ - "{CIncludes}"NullDef.h ¶ - "{CIncludes}"SizeTDef.h ¶ - "{CIncludes}"SeekDefs.h ¶ - "{CIncludes}"VaListTDef.h ¶ - "{CIncludes}"WCharTDef.h ¶ - "{CIncludes}"MacErrors.h ¶ - "{CIncludes}"MixedMode.h ¶ - "{CIncludes}"AEDataModel.h ¶ - "{CIncludes}"AEInteraction.h ¶ - "{CIncludes}"Appearance.h ¶ - "{CIncludes}"CarbonEvents.h ¶ - "{CIncludes}"Lists.h ¶ - "{CIncludes}"MacHelp.h ¶ - "{CIncludes}"CFString.h ¶ - "{CIncludes}"TextEdit.h ¶ - "{CIncludes}"Icons.h ¶ - "{CIncludes}"Collections.h ¶ - "{CIncludes}"OSUtils.h ¶ - "{CIncludes}"Files.h ¶ - "{CIncludes}"NameRegistry.h ¶ - "{CIncludes}"CodeFragments.h ¶ - "{CIncludes}"Multiprocessing.h ¶ - "{CIncludes}"DriverFamilyMatching.h ¶ - "{CIncludes}"Disks.h ¶ - "{CIncludes}"Events.h ¶ - "{CIncludes}"ATSTypes.h ¶ - "{CIncludes}"TextCommon.h ¶ - "{CIncludes}"MacMemory.h ¶ - "{CIncludes}"ConditionalMacros.h ¶ - "{CIncludes}"Aliases.h ¶ - "{CIncludes}"Components.h ¶ - "{CIncludes}"QuickdrawText.h ¶ - "{CIncludes}"CGContext.h ¶ - "{CIncludes}"IntlResources.h ¶ - "{CIncludes}"NumberFormatting.h ¶ - "{CIncludes}"StringCompare.h ¶ - "{CIncludes}"DateTimeUtils.h ¶ - "{CIncludes}"Notification.h ¶ - "{CIncludes}"Balloons.h ¶ - "{CIncludes}"CFBase.h ¶ - "{CIncludes}"CFArray.h ¶ - "{CIncludes}"CFData.h ¶ - "{CIncludes}"CFDictionary.h ¶ - "{CIncludes}"stdarg.h ¶ - "{CIncludes}"Patches.h ¶ - "{CIncludes}"Endian.h ¶ - "{CIncludes}"UTCUtils.h ¶ - "{CIncludes}"CFBundle.h ¶ - "{CIncludes}"CGBase.h ¶ - "{CIncludes}"CGAffineTransform.h ¶ - "{CIncludes}"CGColorSpace.h ¶ - "{CIncludes}"CGFont.h ¶ - "{CIncludes}"CGImage.h ¶ - "{CIncludes}"CGPDFDocument.h ¶ - "{CIncludes}"TypeSelect.h ¶ - "{CIncludes}"CFURL.h ¶ - "{CIncludes}"stddef.h ¶ - "{CIncludes}"CGGeometry.h ¶ - "{CIncludes}"CGDataProvider.h - -:mcmisc.c.x Ä ¶ - :mcmisc.c ¶ - :main.h ¶ - "{CIncludes}"limits.h ¶ - "{CIncludes}"signal.h ¶ - "{CIncludes}"stdio.h ¶ - "{CIncludes}"stdlib.h ¶ - "{CIncludes}"string.h ¶ - "{CIncludes}"AERegistry.h ¶ - "{CIncludes}"AppleEvents.h ¶ - "{CIncludes}"ControlDefinitions.h ¶ - "{CIncludes}"Controls.h ¶ - "{CIncludes}"Devices.h ¶ - "{CIncludes}"Dialogs.h ¶ - "{CIncludes}"DiskInit.h ¶ - "{CIncludes}"Drag.h ¶ - "{CIncludes}"Finder.h ¶ - "{CIncludes}"FixMath.h ¶ - "{CIncludes}"Folders.h ¶ - "{CIncludes}"Fonts.h ¶ - "{CIncludes}"Gestalt.h ¶ - "{CIncludes}"LowMem.h ¶ - "{CIncludes}"MacTypes.h ¶ - "{CIncludes}"MacWindows.h ¶ - "{CIncludes}"Menus.h ¶ - "{CIncludes}"Power.h ¶ - "{CIncludes}"Printing.h ¶ - "{CIncludes}"Processes.h ¶ - "{CIncludes}"QDOffscreen.h ¶ - "{CIncludes}"QuickDraw.h ¶ - "{CIncludes}"Resources.h ¶ - "{CIncludes}"Scrap.h ¶ - "{CIncludes}"Script.h ¶ - "{CIncludes}"SegLoad.h ¶ - "{CIncludes}"Sound.h ¶ - "{CIncludes}"StandardFile.h ¶ - "{CIncludes}"Strings.h ¶ - "{CIncludes}"TextUtils.h ¶ - "{CIncludes}"ToolUtils.h ¶ - ::byterun:rotatecursor.h ¶ - :ocamlconstants.h ¶ - "{CIncludes}"NullDef.h ¶ - "{CIncludes}"SizeTDef.h ¶ - "{CIncludes}"SeekDefs.h ¶ - "{CIncludes}"VaListTDef.h ¶ - "{CIncludes}"WCharTDef.h ¶ - "{CIncludes}"MacErrors.h ¶ - "{CIncludes}"MixedMode.h ¶ - "{CIncludes}"AEDataModel.h ¶ - "{CIncludes}"AEInteraction.h ¶ - "{CIncludes}"Appearance.h ¶ - "{CIncludes}"CarbonEvents.h ¶ - "{CIncludes}"Lists.h ¶ - "{CIncludes}"MacHelp.h ¶ - "{CIncludes}"CFString.h ¶ - "{CIncludes}"TextEdit.h ¶ - "{CIncludes}"Icons.h ¶ - "{CIncludes}"Collections.h ¶ - "{CIncludes}"OSUtils.h ¶ - "{CIncludes}"Files.h ¶ - "{CIncludes}"NameRegistry.h ¶ - "{CIncludes}"CodeFragments.h ¶ - "{CIncludes}"Multiprocessing.h ¶ - "{CIncludes}"DriverFamilyMatching.h ¶ - "{CIncludes}"Disks.h ¶ - "{CIncludes}"Events.h ¶ - "{CIncludes}"ATSTypes.h ¶ - "{CIncludes}"TextCommon.h ¶ - "{CIncludes}"MacMemory.h ¶ - "{CIncludes}"ConditionalMacros.h ¶ - "{CIncludes}"Aliases.h ¶ - "{CIncludes}"Components.h ¶ - "{CIncludes}"QuickdrawText.h ¶ - "{CIncludes}"CGContext.h ¶ - "{CIncludes}"IntlResources.h ¶ - "{CIncludes}"NumberFormatting.h ¶ - "{CIncludes}"StringCompare.h ¶ - "{CIncludes}"DateTimeUtils.h ¶ - "{CIncludes}"Notification.h ¶ - "{CIncludes}"Balloons.h ¶ - "{CIncludes}"CFBase.h ¶ - "{CIncludes}"CFArray.h ¶ - "{CIncludes}"CFData.h ¶ - "{CIncludes}"CFDictionary.h ¶ - "{CIncludes}"stdarg.h ¶ - "{CIncludes}"Patches.h ¶ - "{CIncludes}"Endian.h ¶ - "{CIncludes}"UTCUtils.h ¶ - "{CIncludes}"CFBundle.h ¶ - "{CIncludes}"CGBase.h ¶ - "{CIncludes}"CGAffineTransform.h ¶ - "{CIncludes}"CGColorSpace.h ¶ - "{CIncludes}"CGFont.h ¶ - "{CIncludes}"CGImage.h ¶ - "{CIncludes}"CGPDFDocument.h ¶ - "{CIncludes}"TypeSelect.h ¶ - "{CIncludes}"CFURL.h ¶ - "{CIncludes}"stddef.h ¶ - "{CIncludes}"CGGeometry.h ¶ - "{CIncludes}"CGDataProvider.h - -:menus.c.x Ä ¶ - :menus.c ¶ - :main.h ¶ - "{CIncludes}"limits.h ¶ - "{CIncludes}"signal.h ¶ - "{CIncludes}"stdio.h ¶ - "{CIncludes}"stdlib.h ¶ - "{CIncludes}"string.h ¶ - "{CIncludes}"AERegistry.h ¶ - "{CIncludes}"AppleEvents.h ¶ - "{CIncludes}"ControlDefinitions.h ¶ - "{CIncludes}"Controls.h ¶ - "{CIncludes}"Devices.h ¶ - "{CIncludes}"Dialogs.h ¶ - "{CIncludes}"DiskInit.h ¶ - "{CIncludes}"Drag.h ¶ - "{CIncludes}"Finder.h ¶ - "{CIncludes}"FixMath.h ¶ - "{CIncludes}"Folders.h ¶ - "{CIncludes}"Fonts.h ¶ - "{CIncludes}"Gestalt.h ¶ - "{CIncludes}"LowMem.h ¶ - "{CIncludes}"MacTypes.h ¶ - "{CIncludes}"MacWindows.h ¶ - "{CIncludes}"Menus.h ¶ - "{CIncludes}"Power.h ¶ - "{CIncludes}"Printing.h ¶ - "{CIncludes}"Processes.h ¶ - "{CIncludes}"QDOffscreen.h ¶ - "{CIncludes}"QuickDraw.h ¶ - "{CIncludes}"Resources.h ¶ - "{CIncludes}"Scrap.h ¶ - "{CIncludes}"Script.h ¶ - "{CIncludes}"SegLoad.h ¶ - "{CIncludes}"Sound.h ¶ - "{CIncludes}"StandardFile.h ¶ - "{CIncludes}"Strings.h ¶ - "{CIncludes}"TextUtils.h ¶ - "{CIncludes}"ToolUtils.h ¶ - ::byterun:rotatecursor.h ¶ - :ocamlconstants.h ¶ - "{CIncludes}"NullDef.h ¶ - "{CIncludes}"SizeTDef.h ¶ - "{CIncludes}"SeekDefs.h ¶ - "{CIncludes}"VaListTDef.h ¶ - "{CIncludes}"WCharTDef.h ¶ - "{CIncludes}"MacErrors.h ¶ - "{CIncludes}"MixedMode.h ¶ - "{CIncludes}"AEDataModel.h ¶ - "{CIncludes}"AEInteraction.h ¶ - "{CIncludes}"Appearance.h ¶ - "{CIncludes}"CarbonEvents.h ¶ - "{CIncludes}"Lists.h ¶ - "{CIncludes}"MacHelp.h ¶ - "{CIncludes}"CFString.h ¶ - "{CIncludes}"TextEdit.h ¶ - "{CIncludes}"Icons.h ¶ - "{CIncludes}"Collections.h ¶ - "{CIncludes}"OSUtils.h ¶ - "{CIncludes}"Files.h ¶ - "{CIncludes}"NameRegistry.h ¶ - "{CIncludes}"CodeFragments.h ¶ - "{CIncludes}"Multiprocessing.h ¶ - "{CIncludes}"DriverFamilyMatching.h ¶ - "{CIncludes}"Disks.h ¶ - "{CIncludes}"Events.h ¶ - "{CIncludes}"ATSTypes.h ¶ - "{CIncludes}"TextCommon.h ¶ - "{CIncludes}"MacMemory.h ¶ - "{CIncludes}"ConditionalMacros.h ¶ - "{CIncludes}"Aliases.h ¶ - "{CIncludes}"Components.h ¶ - "{CIncludes}"QuickdrawText.h ¶ - "{CIncludes}"CGContext.h ¶ - "{CIncludes}"IntlResources.h ¶ - "{CIncludes}"NumberFormatting.h ¶ - "{CIncludes}"StringCompare.h ¶ - "{CIncludes}"DateTimeUtils.h ¶ - "{CIncludes}"Notification.h ¶ - "{CIncludes}"Balloons.h ¶ - "{CIncludes}"CFBase.h ¶ - "{CIncludes}"CFArray.h ¶ - "{CIncludes}"CFData.h ¶ - "{CIncludes}"CFDictionary.h ¶ - "{CIncludes}"stdarg.h ¶ - "{CIncludes}"Patches.h ¶ - "{CIncludes}"Endian.h ¶ - "{CIncludes}"UTCUtils.h ¶ - "{CIncludes}"CFBundle.h ¶ - "{CIncludes}"CGBase.h ¶ - "{CIncludes}"CGAffineTransform.h ¶ - "{CIncludes}"CGColorSpace.h ¶ - "{CIncludes}"CGFont.h ¶ - "{CIncludes}"CGImage.h ¶ - "{CIncludes}"CGPDFDocument.h ¶ - "{CIncludes}"TypeSelect.h ¶ - "{CIncludes}"CFURL.h ¶ - "{CIncludes}"stddef.h ¶ - "{CIncludes}"CGGeometry.h ¶ - "{CIncludes}"CGDataProvider.h - -:modalfilter.c.x Ä ¶ - :modalfilter.c ¶ - :main.h ¶ - "{CIncludes}"limits.h ¶ - "{CIncludes}"signal.h ¶ - "{CIncludes}"stdio.h ¶ - "{CIncludes}"stdlib.h ¶ - "{CIncludes}"string.h ¶ - "{CIncludes}"AERegistry.h ¶ - "{CIncludes}"AppleEvents.h ¶ - "{CIncludes}"ControlDefinitions.h ¶ - "{CIncludes}"Controls.h ¶ - "{CIncludes}"Devices.h ¶ - "{CIncludes}"Dialogs.h ¶ - "{CIncludes}"DiskInit.h ¶ - "{CIncludes}"Drag.h ¶ - "{CIncludes}"Finder.h ¶ - "{CIncludes}"FixMath.h ¶ - "{CIncludes}"Folders.h ¶ - "{CIncludes}"Fonts.h ¶ - "{CIncludes}"Gestalt.h ¶ - "{CIncludes}"LowMem.h ¶ - "{CIncludes}"MacTypes.h ¶ - "{CIncludes}"MacWindows.h ¶ - "{CIncludes}"Menus.h ¶ - "{CIncludes}"Power.h ¶ - "{CIncludes}"Printing.h ¶ - "{CIncludes}"Processes.h ¶ - "{CIncludes}"QDOffscreen.h ¶ - "{CIncludes}"QuickDraw.h ¶ - "{CIncludes}"Resources.h ¶ - "{CIncludes}"Scrap.h ¶ - "{CIncludes}"Script.h ¶ - "{CIncludes}"SegLoad.h ¶ - "{CIncludes}"Sound.h ¶ - "{CIncludes}"StandardFile.h ¶ - "{CIncludes}"Strings.h ¶ - "{CIncludes}"TextUtils.h ¶ - "{CIncludes}"ToolUtils.h ¶ - ::byterun:rotatecursor.h ¶ - :ocamlconstants.h ¶ - "{CIncludes}"NullDef.h ¶ - "{CIncludes}"SizeTDef.h ¶ - "{CIncludes}"SeekDefs.h ¶ - "{CIncludes}"VaListTDef.h ¶ - "{CIncludes}"WCharTDef.h ¶ - "{CIncludes}"MacErrors.h ¶ - "{CIncludes}"MixedMode.h ¶ - "{CIncludes}"AEDataModel.h ¶ - "{CIncludes}"AEInteraction.h ¶ - "{CIncludes}"Appearance.h ¶ - "{CIncludes}"CarbonEvents.h ¶ - "{CIncludes}"Lists.h ¶ - "{CIncludes}"MacHelp.h ¶ - "{CIncludes}"CFString.h ¶ - "{CIncludes}"TextEdit.h ¶ - "{CIncludes}"Icons.h ¶ - "{CIncludes}"Collections.h ¶ - "{CIncludes}"OSUtils.h ¶ - "{CIncludes}"Files.h ¶ - "{CIncludes}"NameRegistry.h ¶ - "{CIncludes}"CodeFragments.h ¶ - "{CIncludes}"Multiprocessing.h ¶ - "{CIncludes}"DriverFamilyMatching.h ¶ - "{CIncludes}"Disks.h ¶ - "{CIncludes}"Events.h ¶ - "{CIncludes}"ATSTypes.h ¶ - "{CIncludes}"TextCommon.h ¶ - "{CIncludes}"MacMemory.h ¶ - "{CIncludes}"ConditionalMacros.h ¶ - "{CIncludes}"Aliases.h ¶ - "{CIncludes}"Components.h ¶ - "{CIncludes}"QuickdrawText.h ¶ - "{CIncludes}"CGContext.h ¶ - "{CIncludes}"IntlResources.h ¶ - "{CIncludes}"NumberFormatting.h ¶ - "{CIncludes}"StringCompare.h ¶ - "{CIncludes}"DateTimeUtils.h ¶ - "{CIncludes}"Notification.h ¶ - "{CIncludes}"Balloons.h ¶ - "{CIncludes}"CFBase.h ¶ - "{CIncludes}"CFArray.h ¶ - "{CIncludes}"CFData.h ¶ - "{CIncludes}"CFDictionary.h ¶ - "{CIncludes}"stdarg.h ¶ - "{CIncludes}"Patches.h ¶ - "{CIncludes}"Endian.h ¶ - "{CIncludes}"UTCUtils.h ¶ - "{CIncludes}"CFBundle.h ¶ - "{CIncludes}"CGBase.h ¶ - "{CIncludes}"CGAffineTransform.h ¶ - "{CIncludes}"CGColorSpace.h ¶ - "{CIncludes}"CGFont.h ¶ - "{CIncludes}"CGImage.h ¶ - "{CIncludes}"CGPDFDocument.h ¶ - "{CIncludes}"TypeSelect.h ¶ - "{CIncludes}"CFURL.h ¶ - "{CIncludes}"stddef.h ¶ - "{CIncludes}"CGGeometry.h ¶ - "{CIncludes}"CGDataProvider.h - -:prefs.c.x Ä ¶ - :prefs.c ¶ - :main.h ¶ - "{CIncludes}"limits.h ¶ - "{CIncludes}"signal.h ¶ - "{CIncludes}"stdio.h ¶ - "{CIncludes}"stdlib.h ¶ - "{CIncludes}"string.h ¶ - "{CIncludes}"AERegistry.h ¶ - "{CIncludes}"AppleEvents.h ¶ - "{CIncludes}"ControlDefinitions.h ¶ - "{CIncludes}"Controls.h ¶ - "{CIncludes}"Devices.h ¶ - "{CIncludes}"Dialogs.h ¶ - "{CIncludes}"DiskInit.h ¶ - "{CIncludes}"Drag.h ¶ - "{CIncludes}"Finder.h ¶ - "{CIncludes}"FixMath.h ¶ - "{CIncludes}"Folders.h ¶ - "{CIncludes}"Fonts.h ¶ - "{CIncludes}"Gestalt.h ¶ - "{CIncludes}"LowMem.h ¶ - "{CIncludes}"MacTypes.h ¶ - "{CIncludes}"MacWindows.h ¶ - "{CIncludes}"Menus.h ¶ - "{CIncludes}"Power.h ¶ - "{CIncludes}"Printing.h ¶ - "{CIncludes}"Processes.h ¶ - "{CIncludes}"QDOffscreen.h ¶ - "{CIncludes}"QuickDraw.h ¶ - "{CIncludes}"Resources.h ¶ - "{CIncludes}"Scrap.h ¶ - "{CIncludes}"Script.h ¶ - "{CIncludes}"SegLoad.h ¶ - "{CIncludes}"Sound.h ¶ - "{CIncludes}"StandardFile.h ¶ - "{CIncludes}"Strings.h ¶ - "{CIncludes}"TextUtils.h ¶ - "{CIncludes}"ToolUtils.h ¶ - ::byterun:rotatecursor.h ¶ - :ocamlconstants.h ¶ - "{CIncludes}"NullDef.h ¶ - "{CIncludes}"SizeTDef.h ¶ - "{CIncludes}"SeekDefs.h ¶ - "{CIncludes}"VaListTDef.h ¶ - "{CIncludes}"WCharTDef.h ¶ - "{CIncludes}"MacErrors.h ¶ - "{CIncludes}"MixedMode.h ¶ - "{CIncludes}"AEDataModel.h ¶ - "{CIncludes}"AEInteraction.h ¶ - "{CIncludes}"Appearance.h ¶ - "{CIncludes}"CarbonEvents.h ¶ - "{CIncludes}"Lists.h ¶ - "{CIncludes}"MacHelp.h ¶ - "{CIncludes}"CFString.h ¶ - "{CIncludes}"TextEdit.h ¶ - "{CIncludes}"Icons.h ¶ - "{CIncludes}"Collections.h ¶ - "{CIncludes}"OSUtils.h ¶ - "{CIncludes}"Files.h ¶ - "{CIncludes}"NameRegistry.h ¶ - "{CIncludes}"CodeFragments.h ¶ - "{CIncludes}"Multiprocessing.h ¶ - "{CIncludes}"DriverFamilyMatching.h ¶ - "{CIncludes}"Disks.h ¶ - "{CIncludes}"Events.h ¶ - "{CIncludes}"ATSTypes.h ¶ - "{CIncludes}"TextCommon.h ¶ - "{CIncludes}"MacMemory.h ¶ - "{CIncludes}"ConditionalMacros.h ¶ - "{CIncludes}"Aliases.h ¶ - "{CIncludes}"Components.h ¶ - "{CIncludes}"QuickdrawText.h ¶ - "{CIncludes}"CGContext.h ¶ - "{CIncludes}"IntlResources.h ¶ - "{CIncludes}"NumberFormatting.h ¶ - "{CIncludes}"StringCompare.h ¶ - "{CIncludes}"DateTimeUtils.h ¶ - "{CIncludes}"Notification.h ¶ - "{CIncludes}"Balloons.h ¶ - "{CIncludes}"CFBase.h ¶ - "{CIncludes}"CFArray.h ¶ - "{CIncludes}"CFData.h ¶ - "{CIncludes}"CFDictionary.h ¶ - "{CIncludes}"stdarg.h ¶ - "{CIncludes}"Patches.h ¶ - "{CIncludes}"Endian.h ¶ - "{CIncludes}"UTCUtils.h ¶ - "{CIncludes}"CFBundle.h ¶ - "{CIncludes}"CGBase.h ¶ - "{CIncludes}"CGAffineTransform.h ¶ - "{CIncludes}"CGColorSpace.h ¶ - "{CIncludes}"CGFont.h ¶ - "{CIncludes}"CGImage.h ¶ - "{CIncludes}"CGPDFDocument.h ¶ - "{CIncludes}"TypeSelect.h ¶ - "{CIncludes}"CFURL.h ¶ - "{CIncludes}"stddef.h ¶ - "{CIncludes}"CGGeometry.h ¶ - "{CIncludes}"CGDataProvider.h - -:prims.c.x Ä ¶ - :prims.c - -:print.c.x Ä ¶ - :print.c ¶ - :main.h ¶ - "{CIncludes}"limits.h ¶ - "{CIncludes}"signal.h ¶ - "{CIncludes}"stdio.h ¶ - "{CIncludes}"stdlib.h ¶ - "{CIncludes}"string.h ¶ - "{CIncludes}"AERegistry.h ¶ - "{CIncludes}"AppleEvents.h ¶ - "{CIncludes}"ControlDefinitions.h ¶ - "{CIncludes}"Controls.h ¶ - "{CIncludes}"Devices.h ¶ - "{CIncludes}"Dialogs.h ¶ - "{CIncludes}"DiskInit.h ¶ - "{CIncludes}"Drag.h ¶ - "{CIncludes}"Finder.h ¶ - "{CIncludes}"FixMath.h ¶ - "{CIncludes}"Folders.h ¶ - "{CIncludes}"Fonts.h ¶ - "{CIncludes}"Gestalt.h ¶ - "{CIncludes}"LowMem.h ¶ - "{CIncludes}"MacTypes.h ¶ - "{CIncludes}"MacWindows.h ¶ - "{CIncludes}"Menus.h ¶ - "{CIncludes}"Power.h ¶ - "{CIncludes}"Printing.h ¶ - "{CIncludes}"Processes.h ¶ - "{CIncludes}"QDOffscreen.h ¶ - "{CIncludes}"QuickDraw.h ¶ - "{CIncludes}"Resources.h ¶ - "{CIncludes}"Scrap.h ¶ - "{CIncludes}"Script.h ¶ - "{CIncludes}"SegLoad.h ¶ - "{CIncludes}"Sound.h ¶ - "{CIncludes}"StandardFile.h ¶ - "{CIncludes}"Strings.h ¶ - "{CIncludes}"TextUtils.h ¶ - "{CIncludes}"ToolUtils.h ¶ - ::byterun:rotatecursor.h ¶ - :ocamlconstants.h ¶ - "{CIncludes}"NullDef.h ¶ - "{CIncludes}"SizeTDef.h ¶ - "{CIncludes}"SeekDefs.h ¶ - "{CIncludes}"VaListTDef.h ¶ - "{CIncludes}"WCharTDef.h ¶ - "{CIncludes}"MacErrors.h ¶ - "{CIncludes}"MixedMode.h ¶ - "{CIncludes}"AEDataModel.h ¶ - "{CIncludes}"AEInteraction.h ¶ - "{CIncludes}"Appearance.h ¶ - "{CIncludes}"CarbonEvents.h ¶ - "{CIncludes}"Lists.h ¶ - "{CIncludes}"MacHelp.h ¶ - "{CIncludes}"CFString.h ¶ - "{CIncludes}"TextEdit.h ¶ - "{CIncludes}"Icons.h ¶ - "{CIncludes}"Collections.h ¶ - "{CIncludes}"OSUtils.h ¶ - "{CIncludes}"Files.h ¶ - "{CIncludes}"NameRegistry.h ¶ - "{CIncludes}"CodeFragments.h ¶ - "{CIncludes}"Multiprocessing.h ¶ - "{CIncludes}"DriverFamilyMatching.h ¶ - "{CIncludes}"Disks.h ¶ - "{CIncludes}"Events.h ¶ - "{CIncludes}"ATSTypes.h ¶ - "{CIncludes}"TextCommon.h ¶ - "{CIncludes}"MacMemory.h ¶ - "{CIncludes}"ConditionalMacros.h ¶ - "{CIncludes}"Aliases.h ¶ - "{CIncludes}"Components.h ¶ - "{CIncludes}"QuickdrawText.h ¶ - "{CIncludes}"CGContext.h ¶ - "{CIncludes}"IntlResources.h ¶ - "{CIncludes}"NumberFormatting.h ¶ - "{CIncludes}"StringCompare.h ¶ - "{CIncludes}"DateTimeUtils.h ¶ - "{CIncludes}"Notification.h ¶ - "{CIncludes}"Balloons.h ¶ - "{CIncludes}"CFBase.h ¶ - "{CIncludes}"CFArray.h ¶ - "{CIncludes}"CFData.h ¶ - "{CIncludes}"CFDictionary.h ¶ - "{CIncludes}"stdarg.h ¶ - "{CIncludes}"Patches.h ¶ - "{CIncludes}"Endian.h ¶ - "{CIncludes}"UTCUtils.h ¶ - "{CIncludes}"CFBundle.h ¶ - "{CIncludes}"CGBase.h ¶ - "{CIncludes}"CGAffineTransform.h ¶ - "{CIncludes}"CGColorSpace.h ¶ - "{CIncludes}"CGFont.h ¶ - "{CIncludes}"CGImage.h ¶ - "{CIncludes}"CGPDFDocument.h ¶ - "{CIncludes}"TypeSelect.h ¶ - "{CIncludes}"CFURL.h ¶ - "{CIncludes}"stddef.h ¶ - "{CIncludes}"CGGeometry.h ¶ - "{CIncludes}"CGDataProvider.h - -:scroll.c.x Ä ¶ - :scroll.c ¶ - :main.h ¶ - "{CIncludes}"limits.h ¶ - "{CIncludes}"signal.h ¶ - "{CIncludes}"stdio.h ¶ - "{CIncludes}"stdlib.h ¶ - "{CIncludes}"string.h ¶ - "{CIncludes}"AERegistry.h ¶ - "{CIncludes}"AppleEvents.h ¶ - "{CIncludes}"ControlDefinitions.h ¶ - "{CIncludes}"Controls.h ¶ - "{CIncludes}"Devices.h ¶ - "{CIncludes}"Dialogs.h ¶ - "{CIncludes}"DiskInit.h ¶ - "{CIncludes}"Drag.h ¶ - "{CIncludes}"Finder.h ¶ - "{CIncludes}"FixMath.h ¶ - "{CIncludes}"Folders.h ¶ - "{CIncludes}"Fonts.h ¶ - "{CIncludes}"Gestalt.h ¶ - "{CIncludes}"LowMem.h ¶ - "{CIncludes}"MacTypes.h ¶ - "{CIncludes}"MacWindows.h ¶ - "{CIncludes}"Menus.h ¶ - "{CIncludes}"Power.h ¶ - "{CIncludes}"Printing.h ¶ - "{CIncludes}"Processes.h ¶ - "{CIncludes}"QDOffscreen.h ¶ - "{CIncludes}"QuickDraw.h ¶ - "{CIncludes}"Resources.h ¶ - "{CIncludes}"Scrap.h ¶ - "{CIncludes}"Script.h ¶ - "{CIncludes}"SegLoad.h ¶ - "{CIncludes}"Sound.h ¶ - "{CIncludes}"StandardFile.h ¶ - "{CIncludes}"Strings.h ¶ - "{CIncludes}"TextUtils.h ¶ - "{CIncludes}"ToolUtils.h ¶ - ::byterun:rotatecursor.h ¶ - :ocamlconstants.h ¶ - "{CIncludes}"NullDef.h ¶ - "{CIncludes}"SizeTDef.h ¶ - "{CIncludes}"SeekDefs.h ¶ - "{CIncludes}"VaListTDef.h ¶ - "{CIncludes}"WCharTDef.h ¶ - "{CIncludes}"MacErrors.h ¶ - "{CIncludes}"MixedMode.h ¶ - "{CIncludes}"AEDataModel.h ¶ - "{CIncludes}"AEInteraction.h ¶ - "{CIncludes}"Appearance.h ¶ - "{CIncludes}"CarbonEvents.h ¶ - "{CIncludes}"Lists.h ¶ - "{CIncludes}"MacHelp.h ¶ - "{CIncludes}"CFString.h ¶ - "{CIncludes}"TextEdit.h ¶ - "{CIncludes}"Icons.h ¶ - "{CIncludes}"Collections.h ¶ - "{CIncludes}"OSUtils.h ¶ - "{CIncludes}"Files.h ¶ - "{CIncludes}"NameRegistry.h ¶ - "{CIncludes}"CodeFragments.h ¶ - "{CIncludes}"Multiprocessing.h ¶ - "{CIncludes}"DriverFamilyMatching.h ¶ - "{CIncludes}"Disks.h ¶ - "{CIncludes}"Events.h ¶ - "{CIncludes}"ATSTypes.h ¶ - "{CIncludes}"TextCommon.h ¶ - "{CIncludes}"MacMemory.h ¶ - "{CIncludes}"ConditionalMacros.h ¶ - "{CIncludes}"Aliases.h ¶ - "{CIncludes}"Components.h ¶ - "{CIncludes}"QuickdrawText.h ¶ - "{CIncludes}"CGContext.h ¶ - "{CIncludes}"IntlResources.h ¶ - "{CIncludes}"NumberFormatting.h ¶ - "{CIncludes}"StringCompare.h ¶ - "{CIncludes}"DateTimeUtils.h ¶ - "{CIncludes}"Notification.h ¶ - "{CIncludes}"Balloons.h ¶ - "{CIncludes}"CFBase.h ¶ - "{CIncludes}"CFArray.h ¶ - "{CIncludes}"CFData.h ¶ - "{CIncludes}"CFDictionary.h ¶ - "{CIncludes}"stdarg.h ¶ - "{CIncludes}"Patches.h ¶ - "{CIncludes}"Endian.h ¶ - "{CIncludes}"UTCUtils.h ¶ - "{CIncludes}"CFBundle.h ¶ - "{CIncludes}"CGBase.h ¶ - "{CIncludes}"CGAffineTransform.h ¶ - "{CIncludes}"CGColorSpace.h ¶ - "{CIncludes}"CGFont.h ¶ - "{CIncludes}"CGImage.h ¶ - "{CIncludes}"CGPDFDocument.h ¶ - "{CIncludes}"TypeSelect.h ¶ - "{CIncludes}"CFURL.h ¶ - "{CIncludes}"stddef.h ¶ - "{CIncludes}"CGGeometry.h ¶ - "{CIncludes}"CGDataProvider.h - -:windows.c.x Ä ¶ - :windows.c ¶ - :main.h ¶ - "{CIncludes}"limits.h ¶ - "{CIncludes}"signal.h ¶ - "{CIncludes}"stdio.h ¶ - "{CIncludes}"stdlib.h ¶ - "{CIncludes}"string.h ¶ - "{CIncludes}"AERegistry.h ¶ - "{CIncludes}"AppleEvents.h ¶ - "{CIncludes}"ControlDefinitions.h ¶ - "{CIncludes}"Controls.h ¶ - "{CIncludes}"Devices.h ¶ - "{CIncludes}"Dialogs.h ¶ - "{CIncludes}"DiskInit.h ¶ - "{CIncludes}"Drag.h ¶ - "{CIncludes}"Finder.h ¶ - "{CIncludes}"FixMath.h ¶ - "{CIncludes}"Folders.h ¶ - "{CIncludes}"Fonts.h ¶ - "{CIncludes}"Gestalt.h ¶ - "{CIncludes}"LowMem.h ¶ - "{CIncludes}"MacTypes.h ¶ - "{CIncludes}"MacWindows.h ¶ - "{CIncludes}"Menus.h ¶ - "{CIncludes}"Power.h ¶ - "{CIncludes}"Printing.h ¶ - "{CIncludes}"Processes.h ¶ - "{CIncludes}"QDOffscreen.h ¶ - "{CIncludes}"QuickDraw.h ¶ - "{CIncludes}"Resources.h ¶ - "{CIncludes}"Scrap.h ¶ - "{CIncludes}"Script.h ¶ - "{CIncludes}"SegLoad.h ¶ - "{CIncludes}"Sound.h ¶ - "{CIncludes}"StandardFile.h ¶ - "{CIncludes}"Strings.h ¶ - "{CIncludes}"TextUtils.h ¶ - "{CIncludes}"ToolUtils.h ¶ - ::byterun:rotatecursor.h ¶ - :ocamlconstants.h ¶ - "{CIncludes}"NullDef.h ¶ - "{CIncludes}"SizeTDef.h ¶ - "{CIncludes}"SeekDefs.h ¶ - "{CIncludes}"VaListTDef.h ¶ - "{CIncludes}"WCharTDef.h ¶ - "{CIncludes}"MacErrors.h ¶ - "{CIncludes}"MixedMode.h ¶ - "{CIncludes}"AEDataModel.h ¶ - "{CIncludes}"AEInteraction.h ¶ - "{CIncludes}"Appearance.h ¶ - "{CIncludes}"CarbonEvents.h ¶ - "{CIncludes}"Lists.h ¶ - "{CIncludes}"MacHelp.h ¶ - "{CIncludes}"CFString.h ¶ - "{CIncludes}"TextEdit.h ¶ - "{CIncludes}"Icons.h ¶ - "{CIncludes}"Collections.h ¶ - "{CIncludes}"OSUtils.h ¶ - "{CIncludes}"Files.h ¶ - "{CIncludes}"NameRegistry.h ¶ - "{CIncludes}"CodeFragments.h ¶ - "{CIncludes}"Multiprocessing.h ¶ - "{CIncludes}"DriverFamilyMatching.h ¶ - "{CIncludes}"Disks.h ¶ - "{CIncludes}"Events.h ¶ - "{CIncludes}"ATSTypes.h ¶ - "{CIncludes}"TextCommon.h ¶ - "{CIncludes}"MacMemory.h ¶ - "{CIncludes}"ConditionalMacros.h ¶ - "{CIncludes}"Aliases.h ¶ - "{CIncludes}"Components.h ¶ - "{CIncludes}"QuickdrawText.h ¶ - "{CIncludes}"CGContext.h ¶ - "{CIncludes}"IntlResources.h ¶ - "{CIncludes}"NumberFormatting.h ¶ - "{CIncludes}"StringCompare.h ¶ - "{CIncludes}"DateTimeUtils.h ¶ - "{CIncludes}"Notification.h ¶ - "{CIncludes}"Balloons.h ¶ - "{CIncludes}"CFBase.h ¶ - "{CIncludes}"CFArray.h ¶ - "{CIncludes}"CFData.h ¶ - "{CIncludes}"CFDictionary.h ¶ - "{CIncludes}"stdarg.h ¶ - "{CIncludes}"Patches.h ¶ - "{CIncludes}"Endian.h ¶ - "{CIncludes}"UTCUtils.h ¶ - "{CIncludes}"CFBundle.h ¶ - "{CIncludes}"CGBase.h ¶ - "{CIncludes}"CGAffineTransform.h ¶ - "{CIncludes}"CGColorSpace.h ¶ - "{CIncludes}"CGFont.h ¶ - "{CIncludes}"CGImage.h ¶ - "{CIncludes}"CGPDFDocument.h ¶ - "{CIncludes}"TypeSelect.h ¶ - "{CIncludes}"CFURL.h ¶ - "{CIncludes}"stddef.h ¶ - "{CIncludes}"CGGeometry.h ¶ - "{CIncludes}"CGDataProvider.h - diff --git a/maccaml/SHORTCUTS b/maccaml/SHORTCUTS deleted file mode 100644 index 144c7328e9..0000000000 --- a/maccaml/SHORTCUTS +++ /dev/null @@ -1,9 +0,0 @@ -option-click a scrollbar's arrow -> scroll by one pixel - -Enter in the toplevel window -> go to bottom of window and append -a newline - -Drag & drop to the toplevel window -> go to bottom of window and -append the dragged text - -Command-period in the toplevel window -> interrupt O'Caml's computation diff --git a/maccaml/WASTE/.cvsignore b/maccaml/WASTE/.cvsignore deleted file mode 100644 index 652f7a0453..0000000000 --- a/maccaml/WASTE/.cvsignore +++ /dev/null @@ -1 +0,0 @@ -WASTE*1.3*Distribution diff --git a/maccaml/WASTE/Makefile b/maccaml/WASTE/Makefile deleted file mode 100644 index 1b927fd88d..0000000000 --- a/maccaml/WASTE/Makefile +++ /dev/null @@ -1,507 +0,0 @@ -######################################################################### -# # -# Objective Caml # -# # -# Damien Doligez, projet Para, INRIA Rocquencourt # -# # -# Copyright 1999 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### - -# $Id$ - - -# Makefile for the WASTE library (version 1.3) - -# Put this makefile into the "WASTE 1.3 Distribution" folder. -# If you type "Make all", it will build five files: -# -# WASTELib.o the WASTE library (classic 68k version) -# WASTELib.CFMo the WASTE library (CFM 68k version) -# WASTELib.x the WASTE library (PPC version) -# "WASTE Demo (CFM)" the demo application (CFM 68k and CFM PPC) -# "WASTE Demo (classic)" the demo application (classic 68k and CFM PPC) - -# You can easily change the WASTE options, the compiler options, and the -# libraries to suit your needs. (see below) - - -#### WASTE Options. See ":WASTE 1.3:Private Includes:WASTEIntf.h" for details. - -# The defaults are shown here. -#WEDefs = -d WASTE_DEBUG=0 ¶ -# -d WASTE_OBJECTS=1 ¶ -# -d WASTE_TSM_SUPPORT=1 ¶ -# -d WASTE_DRAG_AND_DROP=1 ¶ -# -d WASTE_USE_UPPS=GENERATINGCFM ¶ -# -d WASTE_NO_SYNCH=0 ¶ -# -d WASTE_NO_RO_CARET=1 ¶ -# -d WASTE_IC_SUPPORT=1 ¶ -# -d WASTE_OBJECTS_ARE_GLYPHS=0 ¶ -# -d WASTE_RESOLVE_FONT_DESIGNATORS=1 ¶ -# -d WASTE_WECALTEXT_DOES_REDRAW=0 ¶ -# -d WASTE_TRANSLUCENT_DRAGS=0 - -WEDefs = -d WASTE_DEBUG=0 ¶ - -d WASTE_OBJECTS=0 ¶ - -d WASTE_TSM_SUPPORT=0 ¶ - -d WASTE_DRAG_AND_DROP=1 ¶ - -d WASTE_USE_UPPS=GENERATINGCFM ¶ - -d WASTE_NO_SYNCH=0 ¶ - -d WASTE_NO_RO_CARET=0 ¶ - -d WASTE_IC_SUPPORT=0 ¶ - -d WASTE_OBJECTS_ARE_GLYPHS=0 ¶ - -d WASTE_RESOLVE_FONT_DESIGNATORS=1 ¶ - -d WASTE_WECALTEXT_DOES_REDRAW=0 ¶ - -d WASTE_TRANSLUCENT_DRAGS=0 - - -#### Compilers and their options. - -# Uncomment this definition to get a debugging version of the library. -debugflag = -sym on - -# Classic 68k -C = sc -COptions = {Defs} {Incl} -model far -w 17 -proto strict {debugflag} -#C = mwc68k -#COptions = {Defs} {Incl} -model far - -# CFM 68k -CFMC = sc -CFMCOptions = {Defs} {Incl} -model cfmflat -w 17 -proto strict {debugflag} -#CFMC = {c} -#CFMCOptions = {coptions} - -# PPC -PPCC = mrc -PPCCOptions = {Defs} {Incl} -w 35 -sym on - - -#### Libraries for the demo application - -Libs = "{libraries}MacRuntime.o" ¶ - "{clibraries}StdCLib.far.o" ¶ - "{libraries}Interface.o" -#Libs = "{mw68klibraries}macos.lib" ¶ -# "{mw68klibraries}ANSI (N/4i/8d) C.68K.Lib" - -CFMLibs = "{CFM68kLibraries}NuMacRuntime.o" ¶ - "{sharedlibraries}StdCLib" ¶ - "{sharedlibraries}DragLib" ¶ - "{sharedlibraries}InterfaceLib" -#CFMLibs = {Libs} - -PPCLibs = "{ppclibraries}PPCCRuntime.o" ¶ - "{sharedlibraries}StdCLib" ¶ - "{ppclibraries}StdCRuntime.o" ¶ - "{sharedlibraries}DragLib" ¶ - "{sharedlibraries}InterfaceLib" ¶ - - -#### Common definitions - -# Compiler options -Incl = -i ":WASTE C/C++ Headers:" {OHIncl} {WEIncl} {WDIncl} {WTIncl} -Defs = {WEDefs} -d inline=static - - -#### Main target - -all Ä everything - - -#### :WASTE 1.3: - -WEObj = ¶ - ':WASTE 1.3:Source:WEAccessors.c.o' ¶ - ':WASTE 1.3:Source:WEBirthDeath.c.o' ¶ - ':WASTE 1.3:Source:WEDebug.c.o' ¶ - ':WASTE 1.3:Source:WEDrawing.c.o' ¶ - ':WASTE 1.3:Source:WEFontTables.c.o' ¶ - ':WASTE 1.3:Source:WEHighLevelEditing.c.o' ¶ - ':WASTE 1.3:Source:WEICGlue.c.o' ¶ - ':WASTE 1.3:Source:WEInlineInput.c.o' ¶ - ':WASTE 1.3:Source:WELineLayout.c.o' ¶ - ':WASTE 1.3:Source:WELongCoords.c.o' ¶ - ':WASTE 1.3:Source:WELowLevelEditing.c.o' ¶ - ':WASTE 1.3:Source:WEMouse.c.o' ¶ - ':WASTE 1.3:Source:WEObjects.c.o' ¶ - ':WASTE 1.3:Source:WEScraps.c.o' ¶ - ':WASTE 1.3:Source:WESelecting.c.o' ¶ - ':WASTE 1.3:Source:WESelectors.c.o' ¶ - ':WASTE 1.3:Source:WEUserSelectors.c.o' ¶ - ':WASTE 1.3:Source:WEUtilities.c.o' ¶ - -WECFMObj = ¶ - ':WASTE 1.3:Source:WEAccessors.c.CFMo' ¶ - ':WASTE 1.3:Source:WEBirthDeath.c.CFMo' ¶ - ':WASTE 1.3:Source:WEDebug.c.CFMo' ¶ - ':WASTE 1.3:Source:WEDrawing.c.CFMo' ¶ - ':WASTE 1.3:Source:WEFontTables.c.CFMo' ¶ - ':WASTE 1.3:Source:WEHighLevelEditing.c.CFMo' ¶ - ':WASTE 1.3:Source:WEICGlue.c.CFMo' ¶ - ':WASTE 1.3:Source:WEInlineInput.c.CFMo' ¶ - ':WASTE 1.3:Source:WELineLayout.c.CFMo' ¶ - ':WASTE 1.3:Source:WELongCoords.c.CFMo' ¶ - ':WASTE 1.3:Source:WELowLevelEditing.c.CFMo' ¶ - ':WASTE 1.3:Source:WEMouse.c.CFMo' ¶ - ':WASTE 1.3:Source:WEObjects.c.CFMo' ¶ - ':WASTE 1.3:Source:WEScraps.c.CFMo' ¶ - ':WASTE 1.3:Source:WESelecting.c.CFMo' ¶ - ':WASTE 1.3:Source:WESelectors.c.CFMo' ¶ - ':WASTE 1.3:Source:WEUserSelectors.c.CFMo' ¶ - ':WASTE 1.3:Source:WEUtilities.c.CFMo' ¶ - -WEPPCObj = ¶ - ':WASTE 1.3:Source:WEAccessors.c.x' ¶ - ':WASTE 1.3:Source:WEBirthDeath.c.x' ¶ - ':WASTE 1.3:Source:WEDebug.c.x' ¶ - ':WASTE 1.3:Source:WEDrawing.c.x' ¶ - ':WASTE 1.3:Source:WEFontTables.c.x' ¶ - ':WASTE 1.3:Source:WEHighLevelEditing.c.x' ¶ - ':WASTE 1.3:Source:WEICGlue.c.x' ¶ - ':WASTE 1.3:Source:WEInlineInput.c.x' ¶ - ':WASTE 1.3:Source:WELineLayout.c.x' ¶ - ':WASTE 1.3:Source:WELongCoords.c.x' ¶ - ':WASTE 1.3:Source:WELowLevelEditing.c.x' ¶ - ':WASTE 1.3:Source:WEMouse.c.x' ¶ - ':WASTE 1.3:Source:WEObjects.c.x' ¶ - ':WASTE 1.3:Source:WEScraps.c.x' ¶ - ':WASTE 1.3:Source:WESelecting.c.x' ¶ - ':WASTE 1.3:Source:WESelectors.c.x' ¶ - ':WASTE 1.3:Source:WEUserSelectors.c.x' ¶ - ':WASTE 1.3:Source:WEUtilities.c.x' ¶ - -WEIncl = -i ":WASTE 1.3:Private Includes:" ¶ - -i ":WASTE 1.3:Internet Config Headers:" - -WETarg = WASTELib.o WASTELib.CFMo WASTELib.x - -WASTELib.o Ä {WEObj} - lib -o WASTELib.o {WEObj} - -WASTELib.CFMo Ä {WECFMObj} - lib -o WASTELib.CFMo {WECFMObj} - -WASTELib.x Ä {WEPPCObj} - ppclink {debugflag} -xm library -o WASTELib.x {WEPPCObj} - -clean ÄÄ - delete -i {WEObj} {WECFMObj} {WEPPCObj} {WETarg} - - -#### :Extras:Sample Object Handlers: - -OHObj = ":Extras:Sample Object Handlers:WEObjectHandlers.c.o" -OHCFMObj = ":Extras:Sample Object Handlers:WEObjectHandlers.c.CFMo" -OHPPCObj = ":Extras:Sample Object Handlers:WEObjectHandlers.c.x" -OHIncl = -i ":Extras:Sample Object Handlers:" -OHTarg = {OHObj} {OHCFMObj} {OHPPCObj} - -clean ÄÄ - delete -i {OHTarg} - - -#### :Extras:WASTE Tabs 1.3.2: - -WTObj = ¶ - ":Extras:WASTE Tabs 1.3.2:WETabs.c.o" ¶ - ":Extras:WASTE Tabs 1.3.2:WETabHooks.c.o"¶ - -WTCFMObj = ¶ - ":Extras:WASTE Tabs 1.3.2:WETabs.c.CFMo" ¶ - ":Extras:WASTE Tabs 1.3.2:WETabHooks.c.CFMo" ¶ - -WTPPCObj = ¶ - ":Extras:WASTE Tabs 1.3.2:WETabs.c.x" ¶ - ":Extras:WASTE Tabs 1.3.2:WETabHooks.c.x" ¶ - -WTIncl = -i ":Extras:Waste Tabs 1.3.2:" -WTTarg = {WTObj} {WTCFMObj} {WTPPCObj} - -clean ÄÄ - delete -i {WTTarg} - - -#### :Demo:Source: - -WDObj = ¶ - :Demo:Source:DialogUtils.c.o ¶ - :Demo:Source:LongControls.c.o ¶ - ':Demo:Source:SmartScroll Stuff:SmartScroll.c.o' ¶ - :Demo:Source:WEDemoAbout.c.o ¶ - :Demo:Source:WEDemoDrags.c.o ¶ - :Demo:Source:WEDemoEvents.c.o ¶ - :Demo:Source:WEDemoFiles.c.o ¶ - :Demo:Source:WEDemoInit.c.o ¶ - :Demo:Source:WEDemoIntf.c.o ¶ - :Demo:Source:WEDemoMain.c.o ¶ - :Demo:Source:WEDemoMenus.c.o ¶ - :Demo:Source:WEDemoScripting.c.o ¶ - :Demo:Source:WEDemoWindows.c.o ¶ - :Demo:Source:qd.c.o ¶ - -WDLibs = WASTELib.o {WTObj} {OHObj} - -WDCFMObj = ¶ - :Demo:Source:DialogUtils.c.CFMo ¶ - :Demo:Source:LongControls.c.CFMo ¶ - ':Demo:Source:SmartScroll Stuff:SmartScroll.c.CFMo' ¶ - :Demo:Source:WEDemoAbout.c.CFMo ¶ - :Demo:Source:WEDemoDrags.c.CFMo ¶ - :Demo:Source:WEDemoEvents.c.CFMo ¶ - :Demo:Source:WEDemoFiles.c.CFMo ¶ - :Demo:Source:WEDemoInit.c.CFMo ¶ - :Demo:Source:WEDemoIntf.c.CFMo ¶ - :Demo:Source:WEDemoMain.c.CFMo ¶ - :Demo:Source:WEDemoMenus.c.CFMo ¶ - :Demo:Source:WEDemoScripting.c.CFMo ¶ - :Demo:Source:WEDemoWindows.c.CFMo ¶ - :Demo:Source:qd.c.CFMo ¶ - -WDCFMLibs = WASTELib.CFMo {WTCFMObj} {OHCFMObj} - -WDPPCObj = ¶ - :Demo:Source:DialogUtils.c.x ¶ - :Demo:Source:LongControls.c.x ¶ - ':Demo:Source:SmartScroll Stuff:SmartScroll.c.x' ¶ - :Demo:Source:WEDemoAbout.c.x ¶ - :Demo:Source:WEDemoDrags.c.x ¶ - :Demo:Source:WEDemoEvents.c.x ¶ - :Demo:Source:WEDemoFiles.c.x ¶ - :Demo:Source:WEDemoInit.c.x ¶ - :Demo:Source:WEDemoIntf.c.x ¶ - :Demo:Source:WEDemoMain.c.x ¶ - :Demo:Source:WEDemoMenus.c.x ¶ - :Demo:Source:WEDemoScripting.c.x ¶ - :Demo:Source:WEDemoWindows.c.x ¶ - :Demo:Source:qd.c.x ¶ - -WDPPCLibs = WASTELib.x {WTPPCObj} {OHPPCObj} - -WDIncl = -i ":Demo:Source:" -i ":Demo:Source:SmartScroll Stuff:" - -WDTarg = "WASTE Demo (classic)" "WASTE Demo (CFM)" - -:Demo:Source:qd.c Ä - echo "#include ¶nQDGlobals qd;¶n" > :Demo:Source:qd.c - -:Demo:Source:size.r Ä - begin - echo '#include "Types.r"' - echo 'resource '¶''SIZE'¶'' (-1) {' - echo 'reserved,' - echo 'acceptSuspendResumeEvents,' - echo 'reserved,' - echo 'canBackground,' - echo 'multiFinderAware,' - echo 'backgroundAndForeground,' - echo 'dontGetFrontClicks,' - echo 'ignoreChildDiedEvents,' - echo 'is32BitCompatible,' - echo 'isHighLevelEventAware,' - echo 'localAndRemoteHLEvents,' - echo 'notStationeryAware,' - echo 'dontUseTextEditServices,' - echo 'reserved,' - echo 'reserved,' - echo 'reserved,' - echo '262144,' - echo '196608' - echo '};' - end > :Demo:Source:size.r - -"WASTE Demo (classic)" ÄÄ {WDObj} {WDLibs} - ilink -c OEDE {WDObj} {WDLibs} {Libs} -o "WASTE Demo (classic)" ¶ - -model far -compact -pad 0 -state nouse - -"WASTE Demo (classic)" ÄÄ {WDPPCObj} {WDPPCLibs} - ppclink -c OEDE {WDPPCObj} {WDPPCLibs} {PPCLibs} ¶ - -fragname 'WASTE Demo PPC' -sym on - mergefragment -z PPCLink.out "WASTE Demo (classic)" - delete -i PPCLink.out - rename -y PPCLink.out.xcoff "WASTE Demo (classic).xcoff" - -"WASTE Demo (classic)" ÄÄ :Demo:Source:WEDemo.rsrc :Demo:Source:size.r - begin - echo 'include ":Demo:Source:WEDemo.rsrc";' - echo '#include ":Demo:Source:size.r"' - end | rez -a -c OEDE -o "WASTE Demo (classic)" - setfile -a Bi "WASTE Demo (classic)" - -"WASTE Demo (CFM)" ÄÄ {WDCFMObj} {WDCFMLibs} - ilink -c OEDE {WDCFMObj} {WDCFMLibs} {CFMLibs} -o "WASTE Demo (CFM)" ¶ - -model cfmseg -state nouse -fragname 'WASTE Demo 68k' - -"WASTE Demo (CFM)" ÄÄ {WDPPCObj} {WDPPCLibs} - ppclink -c OEDE {WDPPCObj} {WDPPCLibs} {PPCLibs} ¶ - -fragname 'WASTE Demo PPC' -sym on - mergefragment -z PPCLink.out "WASTE Demo (CFM)" - delete -i PPCLink.out - rename -y PPCLink.out.xcoff "WASTE Demo (CFM).xcoff" - -"WASTE Demo (CFM)" ÄÄ :Demo:Source:WEDemo.rsrc :Demo:Source:size.r - begin - echo 'include ":Demo:Source:WEDemo.rsrc";' - echo '#include ":Demo:Source:size.r";' - end | rez -a -c OEDE -o "WASTE Demo (CFM)" - setfile -a Bi "WASTE Demo (CFM)" - -clean ÄÄ - delete -i {WDObj} {WDCFMObj} {WDPPCObj} {WDTarg} - delete -i :Demo:Source:size.r :Demo:Source:qd.c - delete -i "WASTE Demo (CFM).xcoff" "WASTE Demo (classic).xcoff" - - -#### Main target (continued) - -everything Ä {OHTarg} {WETarg} {WDTarg} - - -#### Default rule for CFM-68k compilation. - -.c.CFMo Ä .c - {CFMC} {depdir}{default}.c -o {targdir}{default}.c.CFMo {CFMCOptions} - - -#### Dependencies - -':Extras:Sample Object Handlers:WEObjectHandlers.c.o' ¶ -':Extras:Sample Object Handlers:WEObjectHandlers.c.CFMo' ¶ -':Extras:Sample Object Handlers:WEObjectHandlers.c.x' ¶ -Ä ":Extras:Sample Object Handlers:WEObjectHandlers.h" ¶ - ":WASTE C/C++ Headers:WASTE.h" ¶ - ":WASTE C/C++ Headers:LongCoords.h" - -':WASTE 1.3:Source:WEAccessors.c.o' ¶ -':WASTE 1.3:Source:WEAccessors.c.CFMo' ¶ -':WASTE 1.3:Source:WEAccessors.c.x' ¶ -':WASTE 1.3:Source:WEBirthDeath.c.o' ¶ -':WASTE 1.3:Source:WEBirthDeath.c.CFMo' ¶ -':WASTE 1.3:Source:WEBirthDeath.c.x' ¶ -':WASTE 1.3:Source:WEDebug.c.o' ¶ -':WASTE 1.3:Source:WEDebug.c.CFMo' ¶ -':WASTE 1.3:Source:WEDebug.c.x' ¶ -':WASTE 1.3:Source:WEDrawing.c.o' ¶ -':WASTE 1.3:Source:WEDrawing.c.CFMo' ¶ -':WASTE 1.3:Source:WEDrawing.c.x' ¶ -':WASTE 1.3:Source:WEFontTables.c.o' ¶ -':WASTE 1.3:Source:WEFontTables.c.CFMo' ¶ -':WASTE 1.3:Source:WEFontTables.c.x' ¶ -':WASTE 1.3:Source:WEHighLevelEditing.c.o' ¶ -':WASTE 1.3:Source:WEHighLevelEditing.c.CFMo' ¶ -':WASTE 1.3:Source:WEHighLevelEditing.c.x' ¶ -':WASTE 1.3:Source:WEICGlue.c.o' ¶ -':WASTE 1.3:Source:WEICGlue.c.CFMo' ¶ -':WASTE 1.3:Source:WEICGlue.c.x' ¶ -':WASTE 1.3:Source:WEInlineInput.c.o' ¶ -':WASTE 1.3:Source:WEInlineInput.c.CFMo' ¶ -':WASTE 1.3:Source:WEInlineInput.c.x' ¶ -':WASTE 1.3:Source:WELineLayout.c.o' ¶ -':WASTE 1.3:Source:WELineLayout.c.CFMo' ¶ -':WASTE 1.3:Source:WELineLayout.c.x' ¶ -':WASTE 1.3:Source:WELongCoords.c.o' ¶ -':WASTE 1.3:Source:WELongCoords.c.CFMo' ¶ -':WASTE 1.3:Source:WELongCoords.c.x' ¶ -':WASTE 1.3:Source:WELowLevelEditing.c.o' ¶ -':WASTE 1.3:Source:WELowLevelEditing.c.CFMo' ¶ -':WASTE 1.3:Source:WELowLevelEditing.c.x' ¶ -':WASTE 1.3:Source:WEMouse.c.o' ¶ -':WASTE 1.3:Source:WEMouse.c.CFMo' ¶ -':WASTE 1.3:Source:WEMouse.c.x' ¶ -':WASTE 1.3:Source:WEObjects.c.o' ¶ -':WASTE 1.3:Source:WEObjects.c.CFMo' ¶ -':WASTE 1.3:Source:WEObjects.c.x' ¶ -':WASTE 1.3:Source:WEScraps.c.o' ¶ -':WASTE 1.3:Source:WEScraps.c.CFMo' ¶ -':WASTE 1.3:Source:WEScraps.c.x' ¶ -':WASTE 1.3:Source:WESelecting.c.o' ¶ -':WASTE 1.3:Source:WESelecting.c.CFMo' ¶ -':WASTE 1.3:Source:WESelecting.c.x' ¶ -':WASTE 1.3:Source:WESelectors.c.o' ¶ -':WASTE 1.3:Source:WESelectors.c.CFMo' ¶ -':WASTE 1.3:Source:WESelectors.c.x' ¶ -':WASTE 1.3:Source:WEUserSelectors.c.o' ¶ -':WASTE 1.3:Source:WEUserSelectors.c.CFMo' ¶ -':WASTE 1.3:Source:WEUserSelectors.c.x' ¶ -':WASTE 1.3:Source:WEUtilities.c.o' ¶ -':WASTE 1.3:Source:WEUtilities.c.CFMo' ¶ -':WASTE 1.3:Source:WEUtilities.c.x' ¶ -Ä ":WASTE 1.3:Private Includes:WASTEIntf.h" ¶ - ":WASTE 1.3:Private Includes:LongCoords.h" - -":WASTE 1.3:Source:WEMouse.c.o" ¶ -":WASTE 1.3:Source:WEMouse.c.CFMo" ¶ -":WASTE 1.3:Source:WEMouse.c.x" ¶ -Ä ":Waste 1.3:Internet Config Headers:ICTypes.h" ¶ - ":Waste 1.3:Internet Config Headers:ICAPI.h" - -":WASTE 1.3:Source:WEICGlue.c.o" ¶ -":WASTE 1.3:Source:WEICGlue.c.CFMo" ¶ -":WASTE 1.3:Source:WEICGlue.c.x" ¶ -Ä ":Waste 1.3:Internet Config Headers:ICComponentSelectors.h" ¶ - ":Waste 1.3:Internet Config Headers:ICAPI.h" - -:Demo:Source:DialogUtils.c.o ¶ -:Demo:Source:DialogUtils.c.CFMo ¶ -:Demo:Source:DialogUtils.c.x ¶ -:Demo:Source:LongControls.c.o ¶ -:Demo:Source:LongControls.c.CFMo ¶ -:Demo:Source:LongControls.c.x ¶ -:Demo:Source:WEDemoAbout.c.o ¶ -:Demo:Source:WEDemoAbout.c.CFMo ¶ -:Demo:Source:WEDemoAbout.c.x ¶ -:Demo:Source:WEDemoDrags.c.o ¶ -:Demo:Source:WEDemoDrags.c.CFMo ¶ -:Demo:Source:WEDemoDrags.c.x ¶ -:Demo:Source:WEDemoEvents.c.o ¶ -:Demo:Source:WEDemoEvents.c.CFMo ¶ -:Demo:Source:WEDemoEvents.c.x ¶ -:Demo:Source:WEDemoFiles.c.o ¶ -:Demo:Source:WEDemoFiles.c.CFMo ¶ -:Demo:Source:WEDemoFiles.c.x ¶ -:Demo:Source:WEDemoInit.c.o ¶ -:Demo:Source:WEDemoInit.c.CFMo ¶ -:Demo:Source:WEDemoInit.c.x ¶ -:Demo:Source:WEDemoIntf.c.o ¶ -:Demo:Source:WEDemoIntf.c.CFMo ¶ -:Demo:Source:WEDemoIntf.c.x ¶ -:Demo:Source:WEDemoMain.c.o ¶ -:Demo:Source:WEDemoMain.c.CFMo ¶ -:Demo:Source:WEDemoMain.c.x ¶ -:Demo:Source:WEDemoMenus.c.o ¶ -:Demo:Source:WEDemoMenus.c.CFMo ¶ -:Demo:Source:WEDemoMenus.c.x ¶ -:Demo:Source:WEDemoScripting.c.o ¶ -:Demo:Source:WEDemoScripting.c.CFMo ¶ -:Demo:Source:WEDemoScripting.c.x ¶ -:Demo:Source:WEDemoWindows.c.o ¶ -:Demo:Source:WEDemoWindows.c.CFMo ¶ -:Demo:Source:WEDemoWindows.c.x ¶ -Ä ":Demo:Source:WEDemoIntf.h" ¶ - ":WASTE C/C++ Headers:WASTE.h" - -:Demo:Source:WEDemoInit.c.o ¶ -:Demo:Source:WEDemoInit.c.CFMo ¶ -:Demo:Source:WEDemoInit.c.x ¶ -Ä ":Demo:Source:SmartScroll Stuff:SmartScroll.h" ¶ - ":Extras:Sample Object Handlers:WEObjectHandlers.h" - -:Demo:Source:WEDemoMenus.c.o ¶ -:Demo:Source:WEDemoMenus.c.CFMo ¶ -:Demo:Source:WEDemoMenus.c.x ¶ -Ä ":Extras:WASTE Tabs 1.3.2:WETabs.h" - -:Demo:Source:WEDemoWindows.c.o ¶ -:Demo:Source:WEDemoWindows.c.CFMo ¶ -:Demo:Source:WEDemoWindows.c.x ¶ -Ä ":WASTE C/C++ Headers:LongCoords.h" ¶ - ":Demo:Source:SmartScroll Stuff:SmartScroll.h" - -':Demo:Source:SmartScroll Stuff:SmartScroll.c.o' ¶ -':Demo:Source:SmartScroll Stuff:SmartScroll.c.CFMo' ¶ -':Demo:Source:SmartScroll Stuff:SmartScroll.c.x' ¶ -Ä ':Demo:Source:SmartScroll Stuff:SmartScroll.h' diff --git a/maccaml/WASTE/README b/maccaml/WASTE/README deleted file mode 100644 index fd8e5e1e7f..0000000000 --- a/maccaml/WASTE/README +++ /dev/null @@ -1,5 +0,0 @@ -WASTE 1.3 is needed to build the O'Caml standalone application. - -Get WASTE 1.3 from -and unpack it in this directory (maccaml:WASTE:) to create the folder -"WASTE 1.3 Distribution". diff --git a/maccaml/aboutbox.c b/maccaml/aboutbox.c deleted file mode 100644 index 92cb198255..0000000000 --- a/maccaml/aboutbox.c +++ /dev/null @@ -1,125 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Damien Doligez, projet Para, INRIA Rocquencourt */ -/* */ -/* Copyright 1997 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 file ../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include "main.h" - -static WindowPtr aboutbox = NULL; -static UserItemUPP DrawAboutUPP = NULL; - -#define kItemText 2 - -static pascal void DrawAbout (DialogPtr d, short item) -{ -#pragma unused (item) - WEHandle we = WinGetWE (d); - - Assert (we != NULL); - WEUpdate (d->visRgn, we); -} - -void OpenAboutBox (void) -{ - OSErr err; - short itemtype; - Handle item; - Rect itemrect; - LongRect lr; - WEHandle we = NULL; - WStatusH st = NULL; - Handle txt = NULL, copr = NULL; - TextStyle ts; - - if (DrawAboutUPP == NULL) DrawAboutUPP = NewUserItemProc (DrawAbout); - - if (aboutbox != NULL){ - SelectWindow (aboutbox); - }else{ - aboutbox = GetNewDialog (kDialogAbout, NULL, (WindowPtr) -1L); - if (aboutbox == NULL){ - err = memFullErr; - goto failed; - } - SetPort (aboutbox); - - err = WinAllocStatus (aboutbox); - if (err != noErr) goto failed; - - st = WinGetStatus (aboutbox); - Assert (st != NULL); - (*st)->kind = kWinAbout; - - GetDialogItem (aboutbox, kItemText, &itemtype, &item, &itemrect); - SetDialogItem (aboutbox, kItemText, itemtype, (Handle) DrawAboutUPP, &itemrect); - WERectToLongRect (&itemrect, &lr); - err = WENew (&lr, &lr, 0, &we); - if (err != noErr) goto failed; - - (*st)->we = we; - - GetFNum ("\pGeneva", &ts.tsFont); - ts.tsSize = 10; - err = WESetStyle (weDoFont + weDoSize, &ts, we); - if (err != noErr) goto failed; - - txt = GetResource ('TEXT', kAboutText1); - err = ResError (); if (err != noErr){ err = noErr; goto failed; } - DetachResource (txt); - - copr = GetResource ('TEXT', kAboutText2); - err = ResError (); - if (err == noErr){ - HLock (copr); - err = HandAndHand (copr, txt); - /* ignore errors */ - HUnlock (copr); - ReleaseResource (copr); - copr = NULL; - } - - err = WEUseText (txt, we); - if (err != noErr) goto failed; - err = WECalText (we); - if (err != noErr) goto failed; - - WEFeatureFlag (weFReadOnly, weBitSet, we); - - return; - - failed: - if (copr != NULL) DisposeHandle (copr); - if (txt != NULL) DisposeHandle (txt); - if (we != NULL) WEDispose (we); - if (st != NULL) DisposeHandle ((Handle) st); - if (aboutbox != NULL) DisposeWindow (aboutbox); - aboutbox = NULL; - ErrorAlertGeneric (err); - } -} - -void CloseAboutBox (WindowPtr w) -{ - WStatusH st = WinGetStatus (w); - WEHandle we = WinGetWE (w); - - Assert (w == aboutbox); - - Assert (we != NULL); - WEDispose (we); - Assert (st != NULL); - DisposeHandle ((Handle) st); - Assert (w != NULL); - DisposeDialog (w); - aboutbox = NULL; -} diff --git a/maccaml/appleevents.c b/maccaml/appleevents.c deleted file mode 100644 index cad35c032e..0000000000 --- a/maccaml/appleevents.c +++ /dev/null @@ -1,147 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Damien Doligez, projet Para, INRIA Rocquencourt */ -/* */ -/* Copyright 1997 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 file ../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include "main.h" - -static OSErr GotRequiredParams (const AppleEvent *ae) -{ - OSErr err; - DescType type; - Size sz; - - err = AEGetAttributePtr (ae, keyMissedKeywordAttr, typeWildCard, &type, NULL, - 0, &sz); - if (err == errAEDescNotFound) return noErr; - if (err == noErr) return errAEParamMissed; - return err; -} - -static pascal OSErr HandleOpenApplication (const AppleEvent *ae, - AppleEvent *reply, long refCon) -{ -#pragma unused (ae, reply, refCon) - launch_toplevel_requested = 1; - return noErr; -} - -static pascal OSErr HandleQuitApplication (const AppleEvent *ae, - AppleEvent *reply, long refCon) -{ -#pragma unused (ae, reply, refCon) - WindowPtr w = FrontWindow (); - WStatusH st; - int request_interaction = prefs.asksavetop && winToplevel != NULL; - OSErr err; - - while (w != NULL){ - WinUpdateStatus (w); - st = WinGetStatus (w); - if (st != NULL && (*st)->menuflags.save){ - request_interaction = 1; - } - w = GetNextWindow (w); - } - if (request_interaction){ - err = AEInteractWithUser (kAEDefaultTimeout, NULL, ProcessEventUPP); - if (err != noErr) return err; - } - err = DoQuit (); - if (err != noErr) return err; - - return noErr; -} - -static pascal OSErr HandleOpenDocuments (const AppleEvent *ae, - AppleEvent *reply, long refCon) -{ -#pragma unused (reply, refCon) - FSSpec filespec; - AEDescList doclist = {0, NULL}; - OSErr err; - long i, len; - Size sz; - AEKeyword key; - DescType type; - - launch_toplevel_requested = 1; - - err = AEGetParamDesc (ae, keyDirectObject, typeAEList, &doclist); - if (err != noErr) goto failed; - - err = GotRequiredParams (ae); - if (err != noErr) goto failed; - - err = AECountItems (&doclist, &len); - if (err != noErr) goto failed; - - for (i = 1; i <= len; i++){ - err = AEGetNthPtr (&doclist, i, typeFSS, &key, &type, &filespec, - sizeof (filespec), &sz); - if (err != noErr) goto failed; - err = FileOpen (&filespec); - if (err != noErr){ - OSErr err2 = AEInteractWithUser (kAEDefaultTimeout, NULL,ProcessEventUPP); - if (err2 == noErr){ - ErrorAlertCantOpen (filespec.name, err); - }else{ - if (err2 == errAENoUserInteraction) err = err2; - goto failed; - } - } - } - AEDisposeDesc (&doclist); - return noErr; - - failed: - if (doclist.dataHandle != NULL) AEDisposeDesc (&doclist); - return err; -} - -static pascal OSErr HandlePrintDocuments (const AppleEvent *ae, - AppleEvent *reply, long refCon) -{ -#pragma unused (ae, reply, refCon) - return errAEEventNotHandled; /* XXX */ -} - -OSErr InstallAEHandlers (void) -{ - OSErr err; - - err = AEInstallEventHandler (kCoreEventClass, kAEOpenApplication, - NewAEEventHandlerProc (HandleOpenApplication), - 0, false); - if (err != noErr) goto failed; - - err = AEInstallEventHandler (kCoreEventClass, kAEQuitApplication, - NewAEEventHandlerProc (HandleQuitApplication), - 0, false); - if (err != noErr) goto failed; - - err = AEInstallEventHandler (kCoreEventClass, kAEOpenDocuments, - NewAEEventHandlerProc (HandleOpenDocuments), - 0, false); - if (err != noErr) goto failed; - - err = AEInstallEventHandler (kCoreEventClass, kAEPrintDocuments, - NewAEEventHandlerProc (HandlePrintDocuments), - 0, false); - if (err != noErr) goto failed; - - return noErr; - - failed: - return err; -} diff --git a/maccaml/appli.r b/maccaml/appli.r deleted file mode 100644 index a238f9c125..0000000000 --- a/maccaml/appli.r +++ /dev/null @@ -1,808 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Damien Doligez, projet Moscova, INRIA Rocquencourt */ -/* */ -/* Copyright 2000 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 file ../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - - -#include "Types.r" -#include "Sound.r" - -#include "ocamlconstants.h" - - -/* These 5 resources are meant to be overridden. */ - -data 'Line' (1000) { "%a\000" }; /* command line template */ - -data 'Line' (1001) { "" }; /* environment template */ - -data 'TEXT' (1000, purgeable) { /* kAboutText1 */ - "\n" - APPLNAME "\n" - "\n" - "\n" - "\n" - "\n" - "\n" -}; - -data 'cicn' (1000) { /* kApplicationIcon */ - $"0000 0000 8020 0000 0000 0020 0020 0000 0000 0000 0000 0048" - $"0000 0048 0000 0000 0008 0001 0008 0000 0000 0000 0000 0000" - $"0000 0000 0000 0004 0000 0000 0020 0020 0000 0000 0004 0000" - $"0000 0020 0020 0000 0000 0000 0000 001F F01C 003F F83E 007F" - $"FC7E 00FF FEFC 01FF FFF8 03FF FFF0 07FF FFE0 0FFF FFE0 1FFF" - $"FFF0 3FFF FFF8 7FFF FFFC FFFF FFFF FFFF FFFF FFFF FFFF 7FFF" - $"FFFF 3FFF FFFF 1FFF FFFF 0FFF FFFF 07FF FFFF 03FF FFFF 01FF" - $"FFFE 00FF FFFF 007F FFFF 003F FFFF 001F FFFE 000F FFFC 0007" - $"FFF8 0003 FFF0 0001 FFE0 0000 FF80 0000 7F00 0000 0000 001F" - $"F01C 0030 3826 0048 7C5E 0084 E69C 0103 C338 0200 9E70 0400" - $"24E0 0800 49E0 1000 9330 2001 2618 4002 4E0C 8002 9A07 8001" - $"7C07 C002 8007 6002 E007 3007 FC07 1806 1FC7 0C00 01FF 0600" - $"003F 0300 0007 0180 000E 00C0 001F 0060 003F 0030 007F 0018" - $"00FE 000C 01FC 0006 03F8 0003 07F0 0001 8FE0 0000 DF80 0000" - $"7F00 0000 0000 0000 002F 0000 FFFF FFFF FFFF 0001 FFFF FFFF" - $"6666 0002 FFFF CCCC CCCC 0003 FFFF CCCC 9999 0004 FFFF CCCC" - $"6666 0005 FFFF 9999 9999 0006 FFFF 0000 3333 0007 CCCC CCCC" - $"CCCC 0008 CCCC CCCC 9999 0009 CCCC CCCC 6666 000A CCCC 9999" - $"9999 000B CCCC 9999 6666 000C CCCC 9999 3333 000D CCCC 6666" - $"6666 000E CCCC 6666 3333 000F 9999 9999 9999 0010 9999 9999" - $"6666 0011 9999 9999 3333 0012 9999 6666 6666 0013 9999 6666" - $"3333 0014 9999 3333 6666 0015 9999 3333 3333 0016 9999 0000" - $"3333 0017 9999 0000 0000 0018 6666 6666 6666 0019 6666 6666" - $"3333 001A 6666 3333 6666 001B 6666 3333 3333 001C 6666 3333" - $"0000 001D 6666 0000 3333 001E 3333 3333 0000 001F 3333 0000" - $"3333 0020 3333 0000 0000 0021 0000 0000 3333 0022 8888 0000" - $"0000 0023 4444 0000 0000 0024 1111 0000 0000 0025 0000 1111" - $"0000 0026 EEEE EEEE EEEE 0027 DDDD DDDD DDDD 0028 BBBB BBBB" - $"BBBB 0029 AAAA AAAA AAAA 002A 8888 8888 8888 002B 7777 7777" - $"7777 002C 5555 5555 5555 002D 4444 4444 4444 002E 2222 2222" - $"2222 002F 1111 1111 1111 0000 0000 0000 0000 0000 0000 0000" - $"0000 0000 0000 0000 0000 0000 0000 0000 0000 0000 0000 0000" - $"0000 0000 0029 0F29 0F29 0F29 0F18 0000 0000 0000 0022 062D" - $"0000 0000 0000 0000 0000 0000 2A2B 2600 0000 0027 2C2A 2D00" - $"0000 0000 1606 1622 2D00 0000 0000 0000 0000 002A 2700 2B26" - $"0000 072D 2928 2A2D 0000 002C 0717 171F 2D00 0000 0000 0000" - $"0000 2A07 0000 262B 2607 2C29 2827 282A 2D00 2C01 0F2B 2E2D" - $"0000 0000 0000 0000 002A 2700 0000 0026 2B2C 2928 0707 030A" - $"0F11 0410 1B23 2C00 0000 0000 0000 0000 2A27 0000 0000 0000" - $"2628 0702 0803 0A0A 1104 0C1B 1E2D 0000 0000 0000 0000 002A" - $"2700 0000 0000 0000 2627 080A 0503 0F13 040B 1B1E 1A00 0000" - $"0000 0000 0000 2A07 0000 0000 0000 0000 2708 0A03 1015 1304" - $"0B1C 1E0A 2C00 0000 0000 0000 002A 2700 0000 0000 0000 0026" - $"0A05 0312 1B13 040B 1C1F 0E03 0A18 0000 0000 0000 2A27 0000" - $"0000 0000 0000 0028 0403 0E1B 1304 0C1B 1E1B 1203 030B 2C00" - $"0000 002A 2700 0000 0000 0000 0000 2705 0312 1B13 040B 1B24" - $"1B15 1310 0303 0A2C 0000 2A27 0000 0000 0000 0000 0000 0703" - $"141C 1B09 0C1B 252F 1513 0D0B 0303 090A 182A 2C07 0000 0000" - $"0000 0000 0026 1215 1B0B 0B0D 0A0B 0303 0303 0303 0303 050B" - $"2B12 2D2C 2800 0000 0000 0000 0026 261C 1B05 0A12 120B 0B03" - $"0303 0303 030A 0B0A 2B11 002D 2C07 0000 0000 0000 0000 0711" - $"0B1B 151E 1B1B 1519 120B 0A0B 0B0B 1212 2A29 0000 2D2D 0700" - $"0000 0000 0027 120B 1319 2B12 1B1D 1E1B 1B1B 1B12 2C15 1213" - $"0F29 0000 002D 2C07 0000 0000 0008 2C2C 2A0A 2726 2729 1223" - $"2320 1E1D 1C2D 1B1B 2A29 0000 0000 2D2D 2800 0000 272C 0A28" - $"2727 2727 2727 0728 2912 1219 2C1B 1B1B 2B29 0000 0000 002D" - $"2C28 0000 0721 2D2C 182A 2928 2807 0707 0707 0707 0707 0F2B" - $"2B29 0000 0000 0000 2D2C 2800 0026 2707 2829 290F 0F0F 2928" - $"2828 2828 2828 2A2E 2D2D 0000 0000 0000 002D 2C28 0000 0026" - $"2727 2727 2707 2829 0F0F 0F0F 0F29 2E2D 2D00 0000 0000 0000" - $"0000 2D2C 2800 0000 0000 0000 2727 2707 0707 0707 282F 2D2D" - $"2D2D 0000 0000 0000 0000 002D 2C28 0000 0000 0000 0000 0000" - $"2727 2728 2F2C 2D2D 2D2D 0000 0000 0000 0000 0000 2D2C 2800" - $"0000 0000 0000 0000 0000 072F 2D2D 2D2D 2D2D 0000 0000 0000" - $"0000 0000 002D 2C28 0000 0000 0000 0000 0007 2E2D 2D2D 2D2D" - $"2D00 0000 0000 0000 0000 0000 0000 2D2C 2800 0000 0000 0000" - $"072E 2D2D 2D2D 2D2D 0000 0000 0000 0000 0000 0000 0000 002D" - $"2C28 0000 0000 0007 2E2D 2D2D 2D2D 2D00 0000 0000 0000 0000" - $"0000 0000 0000 0000 2D2C 2900 0000 072E 2D2D 2D2D 2D2D 0000" - $"0000 0000 0000 0000 0000 0000 0000 0000 002D 2C28 2607 2F2D" - $"2D2D 2D2D 2D00 0000 0000 0000 0000 0000 0000 0000 0000 0000" - $"0000 2D2D 282E 2D2D 2D2D 2D00 0000 0000 0000 0000 0000 0000" - $"0000 0000 0000 0000 0000 002D 2E2D 2D2D 2D2D 0000 0000 0000" - $"0000" -}; - -data 'ICON' (1000) { /* kApplicationIcon */ - $"0000 0000 001F F01C 0030 3826 0048 7C5E 0084 E69C 0103 C338" - $"0200 9E70 0400 24E0 0800 49E0 1000 9330 2001 2618 4002 4E0C" - $"8002 9A07 8001 7C07 C002 8007 6002 E007 3007 FC07 1806 1FC7" - $"0C00 01FF 0600 003F 0300 0007 0180 000E 00C0 001F 0060 003F" - $"0030 007F 0018 00FE 000C 01FC 0006 03F8 0003 07F0 0001 8FE0" - $"0000 DF80 0000 7F00" -}; - - -/* The other resources should not need to be changed. */ - -data 'TEXT' (kAboutText2, purgeable) { - "Includes (parts of) Objective Caml, MPW libraries," - "and the WASTE text engine.\n" - "\n" - "Objective Caml Copyright 1991-2001 INRIA, all rights reserved.\n" - "MPW © 1983-2001 by Apple Computer, Inc., all rights reserved\n" - "WASTE text engine © 1993-1998 Marco Piovanelli\n" -}; - -resource 'SIZE' (-1) { - reserved, - acceptSuspendResumeEvents, - reserved, - canBackground, - doesActivateOnFGSwitch, - backgroundAndForeground, - dontGetFrontClicks, - ignoreChildDiedEvents, - is32BitCompatible, - isHighLevelEventAware, - localAndRemoteHLEvents, - isStationeryAware, - dontuseTextEditServices, - reserved, - reserved, - reserved, - PREFSIZE * 1024, - MINSIZE * 1024 -}; - -type 'Kequ' { - wide array KequArray { - byte any = 0 command = 1; - byte char; - byte item; - fill byte; - }; -}; - -resource 'Kequ' (kKeysOK) { - { - any, charReturn, 1, - any, charEnter, 1, - any, 'o', 1, - any, 'O', 1, - } -}; - -resource 'Kequ' (kKeysSaveDontCancel) { - { - any, charReturn, 1, - any, charEnter, 1, - any, 'y', 1, - any, 'Y', 1, - any, 's', 1, - any, 'S', 1, - - any, charEscape, 2, - command, '.', 2, - any, 'c', 2, - any, 'C', 2, - - any, 'n', 3, - any, 'N', 3, - any, 'd', 3, - any, 'D', 3, - } -}; - -resource 'ALRT' (kAlertBug) { - {60, 61, 260, 451}, kAlertBug, - { - OK, visible, silent, - OK, visible, silent, - OK, visible, silent, - OK, visible, silent, - }, - alertPositionParentWindowScreen -}; - -resource 'DITL' (kAlertBug) { - { - {160, 310, 180, 368}, Button {enabled, "Quit"}, - - {10, 70, 80, 368}, - StaticText {disabled, /* Don't change this occurrence of Obj Caml */ - "You have discovered a bug in Objective Caml. Please" - " report the following information to ." - }, - - {80, 20, 145, 368}, - StaticText {disabled, "file: ^1\nline: ^2\nexpr: ^0"}, - } -}; - -resource 'ALRT' (kAlertNotYet) { - {60, 81, 160, 431}, kAlertNotYet, - { - OK, visible, silent, - OK, visible, silent, - OK, visible, silent, - OK, visible, silent, - }, - alertPositionParentWindowScreen -}; - -resource 'DITL' (kAlertNotYet) { - { - {60, 270, 80, 328}, Button {enabled, "OK"}, - - {10, 70, 45, 328}, - StaticText {disabled, "This feature is not yet implemented." }, - } -}; - -resource 'ALRT' (kAlertNeedSys7) { - {60, 81, 200, 431}, kAlertNeedSys7, - { - OK, visible, silent, - OK, visible, silent, - OK, visible, silent, - OK, visible, silent, - }, - alertPositionMainScreen -}; - -resource 'DITL' (kAlertNeedSys7) { - { - {100, 270, 120, 328}, - Button {enabled, "Quit"}, - - {10, 70, 85, 328}, - StaticText { - disabled, - APPLNAME " cannot run on MacOS versions prior to System 7." - }, - - {10, 20, 42, 52}, Icon {disabled, kApplicationIcon}, - } -}; - -resource 'ALRT' (kAlertNeed32BitQD) { - {60, 81, 200, 431}, kAlertNeed32BitQD, - { - OK, visible, silent, - OK, visible, silent, - OK, visible, silent, - OK, visible, silent, - }, - alertPositionMainScreen -}; - -resource 'DITL' (kAlertNeed32BitQD) { - { - {100, 270, 120, 328}, - Button {enabled, "Quit"}, - - {10, 70, 85, 328}, - StaticText { - disabled, - APPLNAME " needs a Macintosh with 32-bit color QuickDraw." - }, - - {10, 20, 42, 52}, Icon {disabled, kApplicationIcon}, - } -}; - -resource 'ALRT' (kAlertExit) { - {60, 81, 210, 431}, kAlertExit, - { - OK, visible, silent, - OK, visible, silent, - OK, visible, silent, - OK, visible, silent, - }, - alertPositionParentWindowScreen -}; - -resource 'DITL' (kAlertExit) { - { - {110, 270, 130, 328}, Button {enabled, "OK"}, - - {10, 70, 95, 328}, - StaticText { - disabled, - "The " APPLNAME " toplevel loop has terminated^0^1.\n\n" - "Any further input in the toplevel window will be ignored." - }, - } -}; - -resource 'ALRT' (kAlertErrorMsg) { - {60, 81, 200, 431}, kAlertErrorMsg, - { - OK, visible, sound1, - OK, visible, sound1, - OK, visible, sound1, - OK, visible, sound1, - }, - alertPositionParentWindowScreen -}; - -resource 'DITL' (kAlertErrorMsg) { - { - {100, 270, 120, 328}, Button {enabled, "OK"}, - {10, 70, 85, 328}, StaticText { disabled, "^0^1^2^3" }, - } -}; - -resource 'ALRT' (kAlertErrorNum) { - {60, 81, 200, 431}, kAlertErrorNum, - { - OK, visible, sound1, - OK, visible, sound1, - OK, visible, sound1, - OK, visible, sound1, - }, - alertPositionParentWindowScreen -}; - -resource 'DITL' (kAlertErrorNum) { - { - {100, 270, 120, 328}, Button {enabled, "OK"}, - - {10, 70, 85, 328}, - StaticText { disabled, "An error occurred.\n\nerror code = ^3" }, - } -}; - -resource 'ALRT' (kAlertGeneric) { - {60, 81, 200, 431}, kAlertGeneric, - { - OK, visible, sound1, - OK, visible, sound1, - OK, visible, sound1, - OK, visible, sound1, - }, - alertPositionParentWindowScreen -}; - -resource 'DITL' (kAlertGeneric) { - { - {100, 270, 120, 328}, Button {enabled, "OK"}, - - {10, 20, 85, 378}, - StaticText { disabled, "^0^1^2^3" }, - } -}; - -resource 'ALRT' (kAlertSaveAsk) { - {60, 81, 200, 431}, kAlertSaveAsk, - { - OK, visible, silent, - OK, visible, silent, - OK, visible, silent, - OK, visible, silent, - }, - alertPositionParentWindowScreen -}; - -resource 'DITL' (kAlertSaveAsk) { - { - {100, 270, 120, 328}, Button {enabled, "Save"}, - {100, 202, 120, 260}, Button {enabled, "Cancel"}, - {100, 22, 120, 110}, Button {enabled, "Don't Save"}, - {10, 70, 85, 328}, StaticText { disabled, "Save \"^0\" before ^1 ?" }, - {10, 20, 42, 52}, Icon {disabled, kApplicationIcon}, - } -}; - -resource 'DLOG' (kDialogAbout) { - {70, 60, 285, 470}, - noGrowDocProc, - visible, - goAway, - 0, - kDialogAbout, - "About " APPLNAME, - alertPositionMainScreen -}; - -resource 'DITL' (kDialogAbout) { - { - {10, 20, 42, 52}, Icon {disabled, kApplicationIcon}, - {10, 72, 205, 400}, UserItem { disabled }, - } -}; - -resource 'MBAR' (kMenuBar) { - { kMenuApple, kMenuFile, kMenuEdit, kMenuWindows, } -}; - -resource 'MENU' (kMenuApple) { - kMenuApple, - textMenuProc, - 0x7FFFFFFD, - enabled, - apple, - { - "About " APPLNAME "É", noIcon, noKey, noMark, plain, - "-", noIcon, noKey, noMark, plain, - } -}; - -resource 'MENU' (kMenuFile) { - kMenuFile, - textMenuProc, - 0x7FFFFB7B, - enabled, - "File", - { - "New", noIcon, "N", noMark, plain, - "OpenÉ", noIcon, "O", noMark, plain, - "-", noIcon, noKey, noMark, plain, - "Close", noIcon, "W", noMark, plain, - "Save", noIcon, "S", noMark, plain, - "Save asÉ", noIcon, noKey, noMark, plain, - "Revert to Saved", noIcon, noKey, noMark, plain, - "-", noIcon, noKey, noMark, plain, - "Page SetupÉ", noIcon, nokey, noMark, plain, - "PrintÉ", noIcon, "P", noMark, plain, - "-", noIcon, noKey, noMark, plain, - "Quit", noIcon, "Q", noMark, plain, - } -}; - -resource 'MENU' (kMenuEdit) { - kMenuEdit, - textMenuProc, - 0x7FFFFFBD, - enabled, - "Edit", - { - "Undo", noIcon, "Z", noMark, plain, - "-", noIcon, noKey, noMark, plain, - "Cut", noIcon, "X", noMark, plain, - "Copy", noIcon, "C", noMark, plain, - "Paste", noIcon, "V", noMark, plain, - "Clear", noIcon, noKey, noMark, plain, - "Select All", noIcon, "A", noMark, plain, - "Show Clipboard", noIcon, noKey, noMark, plain, - "-", noIcon, noKey, noMark, plain, - "FindÉ", noIcon, "F", noMark, plain, - "ReplaceÉ", noIcon, "R", noMark, plain, - "-", noIcon, noKey, noMark, plain, - "PreferencesÉ", noIcon, noKey, noMark, plain, - } -}; - -resource 'MENU' (kMenuWindows) { - kMenuWindows, - textMenuProc, - 0x7FFFFFF9, - enabled, - "Windows", - { - "Toplevel", noIcon, "T", noMark, plain, - "Graphics", noIcon, "G", noMark, plain, - "-", noIcon, noKey, noMark, plain, - } -}; - -resource 'STR#' (kUndoStrings) { - { - "Cannot undo", - "Undo", "Redo", - "Undo Typing", "Redo Typing", - "Undo Cut", "Redo Cut", - "Undo Paste", "Redo Paste", - "Undo Clear", "Redo Clear", - "Undo Drag & Drop", "Redo Drag & Drop", - /* Style change is not supported. */ - } -}; - -resource 'STR#' (kMiscStrings, purgeable) { - { - APPLNAME " Preferences", - "Untitled", - "closing", - "quitting", - "Unable to open \"", - "\". ", - "Save file as:", - "", - "Unable to write to \"", - " with error code ", - } -}; - -resource 'STR#' (kErrorStrings, purgeable) { - { - "There is not enough memory.", - "The disk is full.", - "The directory is full.", - "Too many files are already open.", - "The file does not exist.", - "The disk is write-protected.", - "The file is locked.", - "The disk is locked.", - "The file is in use.", - "The file is already open (by " APPLNAME " or another application).", - "The disk was ejected.", - "The file is locked or you do not have the permission to open it.", - "You do not have the permission to write to this file.", - "The folder does not exist.", - "The connection to the file server was closed or broken.", - "A hardware error occurred during input or output.", - } -}; - -resource 'STR ' (kPrefsDescriptionStr, purgeable) { - "This document describes user preferences for " APPLNAME ". " - "You cannot open or print this document. To be " - "effective, this document must be stored in the Preferences " - "folder of the System Folder." -}; - -resource 'WIND' (kToplevelWinTemplate) { - {40, 4, 342, 512}, - zoomDocProc, - invisible, - noGoAway, - 0, - APPLNAME " Toplevel", - noAutoCenter -}; - -resource 'WIND' (kGraphicsWinTemplate) { - {40, 4, 342, 512}, - zoomDocProc, - invisible, - goAway, - 0, - APPLNAME " Graphics", - noAutoCenter -}; - -resource 'WIND' (kDocumentWinTemplate) { - {45, 10, 342, 512}, - zoomDocProc, - visible, - goAway, - 0, - "Untitled", - staggerMainScreen -}; - -resource 'CNTL' (kScrollBarTemplate) { - {0, 0, 16, 16}, - 0, - invisible, - 0, 0, - scrollBarProc, - 0, - "" -}; - -resource 'acur' (0) { - {1000, 1001, 1002, 1003, } -}; - -resource 'CURS' (1000) { - $"07C0 1F30 3F08 7F04 7F04 FF02 FF02 FFFE" - $"81FE 81FE 41FC 41FC 21F8 19F0 07C0", - $"07C0 1FF0 3FF8 7FFC 7FFC FFFE FFFE FFFE" - $"FFFE FFFE 7FFC 7FFC 3FF8 1FF0 07C0", - {7, 7} -}; - -resource 'CURS' (1001) { - $"07C0 1FF0 3FF8 5FF4 4FE4 87C2 8382 8102" - $"8382 87C2 4FE4 5FF4 3FF8 1FF0 07C0", - $"07C0 1FF0 3FF8 7FFC 7FFC FFFE FFFE FFFE" - $"FFFE FFFE 7FFC 7FFC 3FF8 1FF0 07C0", - {7, 7} -}; - -resource 'CURS' (1002) { - $"07C0 19F0 21F8 41FC 41FC 81FE 81FE FFFE" - $"FF02 FF02 7F04 7F04 3F08 1F30 07C0", - $"07C0 1FF0 3FF8 7FFC 7FFC FFFE FFFE FFFE" - $"FFFE FFFE 7FFC 7FFC 3FF8 1FF0 07C0", - {7, 7} -}; - -resource 'CURS' (1003) { - $"07C0 1830 2008 701C 783C FC7E FEFE FFFE" - $"FEFE FC7E 783C 701C 2008 1830 07C0", - $"07C0 1FF0 3FF8 7FFC 7FFC FFFE FFFE FFFE" - $"FFFE FFFE 7FFC 7FFC 3FF8 1FF0 07C0", - {7, 7} -}; - -resource 'snd ' (1002){ - FormatOne{ - { sampledSynth, 0x80 }, - }, - { - hasData, soundCmd {0x2C}, - noData, ampCmd {127}, - noData, freqDurationCmd {0x4321, 60}, - noData, quietCmd {}, - }, - { - 4, - Rate22K, - 0, 4, - 0, - 60, - $"FF01FF01" - } -}; - -resource 'snd ' (1004){ - FormatOne{ - { sampledSynth, 0x80 }, - }, - { - hasData, soundCmd {0x2C}, - noData, ampCmd {127}, - noData, freqDurationCmd {0x4321, 60}, - noData, quietCmd {}, - }, - { - 4, - Rate22K, - 0, 4, - 0, - 60, - $"FF800180" - } -}; - -resource 'snd ' (1008){ - FormatOne{ - { sampledSynth, 0x80 }, - }, - { - hasData, soundCmd {0x2C}, - noData, ampCmd {127}, - noData, freqDurationCmd {0x4321, 60}, - noData, quietCmd {}, - }, - { - 8, - Rate22K, - 0, 8, - 0, - 60, - $"FFDA8026012680DA" - } -}; - -resource 'snd ' (1032){ - FormatOne{ - { sampledSynth, 0x80 }, - }, - { - hasData, soundCmd {0x2C}, - noData, ampCmd {127}, - noData, freqDurationCmd {0x4321, 60}, - noData, quietCmd {}, - }, - { - 32, - Rate22K, - 0, 32, - 0, - 60, - $"FFFDF5EADAC7B19980674F3926160B0301030B1626394F678099B1C7DAEAF5FD" - } -}; - - -resource 'snd ' (1128){ - FormatOne{ - { sampledSynth, 0x80 }, - }, - { - hasData, soundCmd {0x2C}, - noData, ampCmd {127}, - noData, freqDurationCmd {0x4321, 60}, - noData, quietCmd {}, - }, - { - 128, - Rate22K, - 0, 128, - 0, - 60, - $"FFFFFEFEFDFBFAF8F5F3F0EDEAE6E2DEDAD5D1CCC7C1BCB6B1ABA59F99938C86" - $"807A746D67615B554F4A443F39342F2B26221E1A1613100D0B08060503020201" - $"01010202030506080B0D1013161A1E22262B2F34393F444A4F555B61676D747A" - $"80868C93999FA5ABB1B6BCC1C7CCD1D5DADEE2E6EAEDF0F3F5F8FAFBFDFEFEFF" - } -}; - -resource 'snd ' (1512, "foo"){ - FormatOne{ - { sampledSynth, 0x80 }, - }, - { - hasData, soundCmd {0x2C}, - noData, ampCmd {127}, - noData, freqDurationCmd {0x4321, 60}, - noData, quietCmd {}, - }, - { - 512, - Rate22K, - 0, 512, - 0, - 60, - $"FFFFFFFFFFFFFFFFFEFEFEFEFEFDFDFDFDFCFCFCFBFBFAFAFAF9F9F8F8F7F6F6" - $"F5F5F4F3F3F2F1F1F0EFEFEEEDECEBEAEAE9E8E7E6E5E4E3E2E1E0DFDEDDDCDB" - $"DAD9D8D6D5D4D3D2D1CFCECDCCCAC9C8C7C5C4C3C1C0BFBDBCBAB9B8B6B5B3B2" - $"B1AFAEACABA9A8A6A5A3A2A09F9D9C9A999796949391908E8C8B898886858382" - $"807E7D7B7A7877757472706F6D6C6A696766646361605E5D5B5A585755545251" - $"4F4E4D4B4A484746444341403F3D3C3B39383736343332312F2E2D2C2B2A2827" - $"262524232221201F1E1D1C1B1A1918171616151413121111100F0F0E0D0D0C0B" - $"0B0A0A0908080707060606050504040403030303020202020201010101010101" - $"0101010101010101020202020203030303040404050506060607070808090A0A" - $"0B0B0C0D0D0E0F0F1011111213141516161718191A1B1C1D1E1F202122232425" - $"2627282A2B2C2D2E2F31323334363738393B3C3D3F404143444647484A4B4D4E" - $"4F5152545557585A5B5D5E606163646667696A6C6D6F7072747577787A7B7D7E" - $"808283858688898B8C8E909193949697999A9C9D9FA0A2A3A5A6A8A9ABACAEAF" - $"B1B2B3B5B6B8B9BABCBDBFC0C1C3C4C5C7C8C9CACCCDCECFD1D2D3D4D5D6D8D9" - $"DADBDCDDDEDFE0E1E2E3E4E5E6E7E8E9EAEAEBECEDEEEFEFF0F1F1F2F3F3F4F5" - $"F5F6F6F7F8F8F9F9FAFAFAFBFBFCFCFCFDFDFDFDFEFEFEFEFEFFFFFFFFFFFFFF" - } -}; - -resource 'FREF' (128) { - 'APPL', - 0, - "" -}; - -resource 'FREF' (129) { - 'TEXT', - 1, - "" -}; - -resource 'FREF' (130) { - 'sEXT', - 2, - "" -}; - -resource 'BNDL' (128) { - CREATOR, - 0, - { /* array TypeArray: 2 elements */ - /* [1] */ - 'FREF', - { /* array IDArray: 3 elements */ - /* [1] */ - 0, 128, - /* [2] */ - 1, 129, - /* [3] */ - 2, 130 - }, - /* [2] */ - 'ICN#', - { /* array IDArray: 3 elements */ - /* [1] */ - 0, 1000, - /* [2] */ - 1, 1001, - /* [3] */ - 2, 1002 - } - } -}; - -data CREATOR (0) { - $"00" /* . */ -}; diff --git a/maccaml/clipboard.c b/maccaml/clipboard.c deleted file mode 100644 index 0e09065fb2..0000000000 --- a/maccaml/clipboard.c +++ /dev/null @@ -1,40 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Damien Doligez, projet Para, INRIA Rocquencourt */ -/* */ -/* Copyright 1998 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 file ../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include "main.h" - -WindowPtr clip_window = NULL; - -/* Open clipboard window or bring it to the front. */ -void ClipShow (void) -{ - if (clip_window != NULL){ - SelectWindow (clip_window); - }else{ - XXX (); - } -} - -void ClipClose (void) -{ - XXX (); -} - -void ClipChanged (void) -{ - if (clip_window != NULL){ - XXX (); - } -} diff --git a/maccaml/drag.c b/maccaml/drag.c deleted file mode 100644 index 64bf909cf3..0000000000 --- a/maccaml/drag.c +++ /dev/null @@ -1,241 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Damien Doligez, projet Para, INRIA Rocquencourt */ -/* */ -/* Copyright 1997 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 file ../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include "main.h" - -static DragTrackingHandlerUPP MyTrackingHandlerUPP = NULL; -static DragReceiveHandlerUPP MyReceiveHandlerUPP = NULL; - -static OSErr ToplevelTrackDrag (DragTrackingMessage message, DragReference drag) -{ - static int canacceptdrag = 0; - static int hilited = 0; - WEReference we = WinGetWE (winToplevel); - short readonly; - Point mouse; - RgnHandle rgn = NewRgn (); - Rect viewrect; - LongRect lviewrect; - OSErr err; - DragAttributes attributes; - - Assert (we != NULL); - switch (message){ - - case kDragTrackingEnterWindow: - readonly = WEFeatureFlag (weFReadOnly, weBitTest, we); - WEFeatureFlag (weFReadOnly, weBitClear, we); - canacceptdrag = WECanAcceptDrag (drag, we); - if (readonly) WEFeatureFlag (weFReadOnly, weBitSet, we); - break; - - case kDragTrackingInWindow: - if (canacceptdrag){ - err = GetDragAttributes (drag, &attributes); - if (err != noErr) goto failed; - err = GetDragMouse (drag, &mouse, nil); - if (err != noErr) goto failed; - GlobalToLocal (&mouse); - WEGetViewRect (&lviewrect, we); - WELongRectToRect (&lviewrect, &viewrect); - InsetRect (&viewrect, -kTextMarginH, 0); - if (PtInRect (mouse, &viewrect)){ - if (!hilited && (attributes & kDragHasLeftSenderWindow)){ - RectRgn (rgn, &viewrect); - InsetRgn (rgn, 0, -kTextMarginV); - ShowDragHilite (drag, rgn, true); - DisposeRgn (rgn); - hilited = 1; - } - }else{ - if (hilited){ - HideDragHilite (drag); - hilited = 0; - } - } - } - break; - - case kDragTrackingLeaveWindow: - if (hilited){ - HideDragHilite (drag); - hilited = 0; - } - break; - - default: break; - } - return noErr; - - failed: return err; -} - -static pascal OSErr MyTrackingHandler (DragTrackingMessage message, WindowPtr w, - void *refCon, DragReference drag) -{ - #pragma unused (refCon) - WEReference we; - - switch (WinGetKind (w)){ - case kWinUnknown: - case kWinUninitialised: - case kWinAbout: - case kWinGraphics: - case kWinPrefs: - case kWinClipboard: - return noErr; - - case kWinToplevel: - return ToplevelTrackDrag (message, drag); - - case kWinDocument: - we = WinGetWE (w); Assert (we != NULL); - return WETrackDrag (message, drag, we); - - default: - Assert (0); - return noErr; - } -} - -static OSErr ToplevelReceiveDrag (DragReference drag, WEReference we) -{ - GrafPtr saveport; - short readonly = 0; - Boolean canaccept; - OSErr err; - Point mouse; - LongRect lviewrect; - Rect viewrect; - UInt16 nitems; - UInt16 i; - ItemReference itemref; - Handle h = NULL; - Size sz, curlen; - long dest, selstart, selend = -1; - - PushWindowPort (winToplevel); - - readonly = WEFeatureFlag (weFReadOnly, weBitTest, we); - if (readonly) WEFeatureFlag (weFReadOnly, weBitClear, we); - canaccept = WECanAcceptDrag (drag, we); - if (!canaccept){ err = badDragFlavorErr; goto failed; } - - err = GetDragMouse (drag, &mouse, nil); - if (err != noErr) goto failed; - GlobalToLocal (&mouse); - WEGetViewRect (&lviewrect, we); - WELongRectToRect (&lviewrect, &viewrect); - if (!PtInRect (mouse, &viewrect)){ err = dragNotAcceptedErr; goto failed; } - - /* XXX Ne pas coller si le drag vient de la mme fentre et la souris - est revenue dans la sŽlection. */ - - h = NewHandle (0); - err = MemError (); if (err != noErr) goto failed; - curlen = 0; - - err = CountDragItems (drag, &nitems); - if (err != noErr) goto failed; - - for (i = 1; i <= nitems; i++){ - err = GetDragItemReferenceNumber (drag, i, &itemref); - if (err != noErr) goto failed; - err = GetFlavorDataSize (drag, itemref, kTypeText, &sz); - if (err != noErr) goto failed; - SetHandleSize (h, curlen + sz); - err = MemError (); if (err != noErr) goto failed; - HLock (h); - err = GetFlavorData (drag, itemref, kTypeText, (*h)+curlen, &sz, 0); - HUnlock (h); - if (err != noErr) goto failed; - curlen += sz; - } - dest = WEGetTextLength (we); - WEGetSelection (&selstart, &selend, we); - WESetSelection (dest, dest, we); - WESetStyle (weDoFont + weDoFace + weDoSize + weDoColor + weDoReplaceFace, - &prefs.unread, we); - HLock (h); - err = WEInsert (*h, curlen, NULL, NULL, we); - HUnlock (h); - if (err != noErr) goto failed; - WESetSelection (dest + curlen, dest + curlen, we); - ScrollToEnd (winToplevel); - - DisposeHandle (h); - PopPort; - return noErr; - - failed: - if (h != NULL) DisposeHandle (h); - if (selend != -1) WESetSelection (selstart, selend, we); - if (readonly) WEFeatureFlag (weFReadOnly, weBitSet, we); - PopPort; - return err; -} - -static pascal OSErr MyReceiveHandler (WindowPtr w, void *refCon, - DragReference drag) -{ - #pragma unused (refCon) - WEReference we; - - switch (WinGetKind (w)){ - case kWinUnknown: - case kWinUninitialised: - case kWinAbout: - case kWinGraphics: - case kWinPrefs: - case kWinClipboard: - return noErr; - case kWinToplevel: - we = WinGetWE (w); Assert (we != NULL); - return ToplevelReceiveDrag (drag, we); - case kWinDocument: - we = WinGetWE (w); Assert (we != NULL); - return WEReceiveDrag (drag, we); - default: - Assert (0); - return noErr; - } -} - -OSErr InstallDragHandlers (void) -{ - OSErr err; - - MyTrackingHandlerUPP = NewDragTrackingHandlerProc (MyTrackingHandler); - MyReceiveHandlerUPP = NewDragReceiveHandlerProc (MyReceiveHandler); - - err = InstallTrackingHandler (MyTrackingHandlerUPP, NULL, NULL); - if (err != noErr) return err; - err = InstallReceiveHandler (MyReceiveHandlerUPP, NULL, NULL); - if (err != noErr){ - RemoveTrackingHandler (MyTrackingHandlerUPP, NULL); - return err; - } - return noErr; -} - -OSErr RemoveDragHandlers (void) -{ - OSErr err1, err2; - - err1 = RemoveTrackingHandler (MyTrackingHandlerUPP, NULL); - err2 = RemoveReceiveHandler (MyReceiveHandlerUPP, NULL); - if (err2 != noErr && err1 == noErr) return err2; - return err1; -} diff --git a/maccaml/dummy_fragment.c b/maccaml/dummy_fragment.c deleted file mode 100644 index 2a924f1d6a..0000000000 --- a/maccaml/dummy_fragment.c +++ /dev/null @@ -1 +0,0 @@ -/* This file intentionally left blank. */ diff --git a/maccaml/errors.c b/maccaml/errors.c deleted file mode 100644 index bf32ce4e9f..0000000000 --- a/maccaml/errors.c +++ /dev/null @@ -1,114 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Damien Doligez, projet Para, INRIA Rocquencourt */ -/* */ -/* Copyright 1997 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 file ../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include "main.h" - -static int exiting = 0; - -void assert_failure (char *condition, char *file, int line) -{ - Str255 buf; - - if (exiting) ExitToShell (); - exiting = 1; - NumToString ((long) line, buf); - ParamText (c2pstr (condition), c2pstr (file), buf, NULL); - InitCursor (); - modalkeys = kKeysOK; - StopAlert (kAlertBug, myModalFilterUPP); - FinaliseAndQuit (); -} - -void XXX (void) -{ - InitCursor (); - modalkeys = kKeysOK; - StopAlert (kAlertNotYet, myModalFilterUPP); -} - -void ErrorAlert (short msg1, Str255 bufmsg2, short msg3, OSErr err) -{ - Str255 bufmsg1, bufmsg3, bufmsg4; - short msg; - - switch (err){ - case noErr: - case userCanceledErr: return; - - case mFulErr: - case memFullErr: - case cTempMemErr: - case cNoMemErr: - case updPixMemErr: msg = kMemFull; break; - case dskFulErr: - case afpDiskFull: msg = kDiskFull; break; - case dirFulErr: msg = kDirFull; break; - case tmfoErr: - case afpTooManyFilesOpen: msg = kTooManyFiles; break; - case fnfErr: msg = kFileNotFound; break; - case wPrErr: msg = kWriteProtect; break; - case fLckdErr: - case afpObjectLocked: msg = kFileLocked; break; - case vLckdErr: - case afpVolLocked: msg = kVolLocked; break; - case fBsyErr: - case afpFileBusy: msg = kFileBusy; break; - case opWrErr: msg = kFileOpen; break; - case volOffLinErr: msg = kVolOffLine; break; - case permErr: - case afpAccessDenied: msg = kPermDenied; break; - case wrPermErr: msg = kWritePermDenied; break; - case dirNFErr: msg = kDirNotFound; break; - case volGoneErr: - case afpSessClosed: msg = kDisconnected; break; - case ioErr: msg = kIOError; break; - - default: msg = 0; break; - } - - GetIndString (bufmsg1, kMiscStrings, msg1); - GetIndString (bufmsg3, kMiscStrings, msg3); - - if (msg != 0){ - GetIndString (bufmsg4, kErrorStrings, msg); - ParamText (bufmsg1, bufmsg2, bufmsg3, bufmsg4); - }else{ - NumToString (err, bufmsg4); - ParamText (bufmsg1, bufmsg2, bufmsg3, bufmsg4); - } - InitCursor (); - modalkeys = kKeysOK; - StopAlert (msg ? kAlertErrorMsg : kAlertErrorNum, myModalFilterUPP); -} - -void ErrorAlertCantOpen (Str255 filename, OSErr err) -{ - ErrorAlert (kCannotOpenIdx, filename, kCloseQuoteIdx, err); -} - -void ErrorAlertGeneric (OSErr err) -{ - ErrorAlert (kEmptyIdx, "\p", kEmptyIdx, err); -} - -OSErr InitialiseErrors (void) -{ - /* XXX CouldAlert is not in any library ?!? - CouldAlert (kAlertErrorMsg); - CouldAlert (kAlertErrorNum); - CouldAlert (kAlertBug); - */ - return noErr; -} diff --git a/maccaml/events.c b/maccaml/events.c deleted file mode 100644 index 7411482094..0000000000 --- a/maccaml/events.c +++ /dev/null @@ -1,319 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Damien Doligez, projet Para, INRIA Rocquencourt */ -/* */ -/* Copyright 1997 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 file ../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include "main.h" - -/* [intr_requested] is true if the user typed command-period and the - SIGINT signal was not yet delivered. -*/ -int intr_requested = 0; - -UInt32 last_event_date = 0; - -UInt32 evtSleep = 0; -static RgnHandle mouseRegion = NULL; -static RgnHandle pointRegion = NULL; - -static void AdjustCursor (Point mouse, RgnHandle mouseRegion) -{ - WindowPtr w = FrontWindow (); - WEHandle we = WinGetWE (w); - int k = WinGetKind (w); - Boolean res; - - SetRectRgn (mouseRegion, -SHRT_MAX, -SHRT_MAX, SHRT_MAX, SHRT_MAX); - if (we != NULL && k != kWinAbout){ - if (w == winToplevel){ - res = AdjustRotatingCursor (); - if (res) return; - } - res = WEAdjustCursor (mouse, mouseRegion, we); - if (res) return; - } - SetCursor (&qd.arrow); -} - -static void DoActivate (EventRecord *evt) -{ - WindowPtr w = (WindowPtr) evt->message; - - if (GetWindowKind (w) != userKind) return; /*XXX*/ - WinActivateDeactivate (evt->modifiers & activeFlag, w); -} - -static void DoDiskEvent (EventRecord *evt) -{ - OSErr err; - Point pt; - - if (evt->message >> 16 != noErr){ - DILoad (); - err = DIBadMount (pt, evt->message); /* [pt] is ignored */ - if (err != noErr && err != 1 && err != 2){ - ErrorAlertGeneric (err); /* XXX or nothing ? */ - } - DIUnload (); - } -} - -static void DoKeyDown (EventRecord *evt) -{ - short chr = evt->message & charCodeMask; - Boolean isCmdKey = (evt->modifiers & cmdKey) != 0; - - if (chr == 0x10){ - switch ((evt->message & keyCodeMask) >> 8){ - case keyF1: - isCmdKey = 1; - chr = 'z'; - break; - case keyF2: - isCmdKey = 1; - chr = 'x'; - break; - case keyF3: - isCmdKey = 1; - chr = 'c'; - break; - case keyF4: - isCmdKey = 1; - chr = 'v'; - break; - default: - chr = -1; - } - } - if (isCmdKey && chr == '.' - && FrontWindow () == winToplevel - && evt->what != autoKey){ - FlushUnreadInput (); - raise (SIGINT); - } - if (isCmdKey && chr >= 0x20){ - UpdateMenus (); - DoMenuChoice (MenuKey (chr), evt->modifiers); - }else{ - WindowPtr w = FrontWindow (); - if (chr != -1 && w != NULL){ - WinDoKey (w, chr, evt); - } - } -} - -static void DoMouseDown (EventRecord *event) -{ - WindowPtr w; - short partCode; - - partCode = FindWindow (event->where, &w); - switch (partCode){ - case inMenuBar: - UpdateMenus (); - DoMenuChoice (MenuSelect (event->where), event->modifiers); - break; - case inSysWindow: - SystemClick (event, w); - break; - case inContent: - WinDoContentClick (event, w); - break; - case inDrag: - WinDoDrag (event->where, w); - break; - case inGrow: - WinDoGrow (event->where, w); - break; - case inGoAway: - if (TrackGoAway (w, event->where)) WinDoClose (closingWindow, w); - break; - case inZoomIn: - case inZoomOut: - if (TrackBox (w, event->where, partCode)) WinDoZoom (w, partCode); - break; - } -} - -/* XXX recuperer les mouse-up pour matcher les mouse-down ? */ -static void DoMouseUp (EventRecord *e) -{ - short partCode; - WindowPtr w; - Point hitpt; - GrafPtr saveport; - Rect r; - - if (FrontWindow () != winGraphics) return; - partCode = FindWindow (e->where, &w); - if (partCode != inContent) return; - PushWindowPort (winGraphics); - hitpt = e->where; - GlobalToLocal (&hitpt); - ScrollCalcGraph (winGraphics, &r); - if (PtInRect (hitpt, &r)) GraphGotEvent (e); - PopPort; - return; -} - -static void DoNullEvent (EventRecord *event) -{ -#pragma unused (event) - WindowPtr w = FrontWindow (); - - if (w != NULL) WinDoIdle (w); -} - -static void DoOSEvent (EventRecord *event) -{ - int msg = (event->message & osEvtMessageMask) >> 24; - WindowPtr w; - - switch (msg){ - case suspendResumeMessage: - w = FrontWindow (); - if (w != NULL){ - Boolean state = !! (event->message & resumeFlag); - WinActivateDeactivate (state, w); - } - if (event->message & convertClipboardFlag) ClipChanged (); - case mouseMovedMessage: ; - } -} - -static void DoUpdate (EventRecord *evt) -{ - WindowPtr w = (WindowPtr) evt->message; - - if (GetWindowKind (w) != userKind) return; /*XXX*/ - WinUpdate (w); -} - -static void DoDialogEvent (EventRecord *evt) -{ - DialogPtr dlg; - short itm; - - if (evt->what == diskEvt){ - DoDiskEvent (evt); - return; - }else if (evt->what == keyDown || evt->what == autoKey){ - if (evt->modifiers & cmdKey){ - DoKeyDown (evt); - return; - }else{ - switch ((evt->message & charCodeMask) >> 8){ - case '\n': - XXX (); /*XXX return key*/ - return; - case '\033': - XXX (); /*XXX escape key */ - return; - default: break; - } - } - } - if (DialogSelect (evt, &dlg, &itm)){ - switch (WinGetKind (dlg)){ - case kWinAbout: - Assert (0); /* No item is enabled. */ - break; - case kWinPrefs: - XXX (); - break; - default: - Assert (0); /* Other windows are not dialogs. */ - break; - } - } -} - -static pascal Boolean ProcessEvent (EventRecord *evt, long *sleep, - RgnHandle *rgn) -{ - if (evt->what <= osEvt) AdjustCursor (evt->where, mouseRegion); - if (IsDialogEvent (evt)){ - DoDialogEvent (evt); - }else{ - switch (evt->what){ - case nullEvent: - DoNullEvent (evt); - break; - case mouseDown: - DoMouseDown (evt); - break; - case mouseUp: /* Needed for the graphics window. */ - DoMouseUp (evt); - break; - case keyDown: - case autoKey: - DoKeyDown (evt); - break; - case updateEvt: - DoUpdate (evt); - break; - case activateEvt: - DoActivate (evt); - break; - case diskEvt: - DoDiskEvent (evt); - break; - case osEvt: - DoOSEvent (evt); - break; - case kHighLevelEvent: - AEProcessAppleEvent (evt); - break; - } - } - *sleep = evt->what == nullEvent ? evtSleep : 0; - *rgn = mouseRegion; - return false; -} - -void GetAndProcessEvents (WaitEventOption wait, short oldx, short oldy) -{ - EventRecord evt; - long dummysleep; - RgnHandle dummyregion; - UInt32 cursleep = (wait == noWait) ? 0 : evtSleep; - RgnHandle currgn; - - if (wait == waitMove){ - currgn = pointRegion; - SetRectRgn (pointRegion, oldx, oldy, oldx+1, oldy+1); - }else{ - currgn = mouseRegion; - } - - WaitNextEvent (everyEvent, &evt, cursleep, currgn); - ProcessEvent (&evt, &dummysleep, &dummyregion); - - while (evt.what != nullEvent){ - WaitNextEvent (everyEvent, &evt, 0, NULL); - ProcessEvent (&evt, &dummysleep, &dummyregion); - } -} - -AEIdleUPP ProcessEventUPP; - -OSErr InitialiseEvents (void) -{ - OSErr err; - - mouseRegion = NewRgn (); /* XXX out of memory ? */ - pointRegion = NewRgn (); /* XXX out of memory ? */ - ProcessEventUPP = NewAEIdleProc (ProcessEvent); - err = InstallAEHandlers (); - return err; -} diff --git a/maccaml/files.c b/maccaml/files.c deleted file mode 100644 index ae94adcc45..0000000000 --- a/maccaml/files.c +++ /dev/null @@ -1,427 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Damien Doligez, projet Para, INRIA Rocquencourt */ -/* */ -/* Copyright 1997 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 file ../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include "main.h" - -static unsigned long nuntitled = 0; -static unsigned long count = 2; - -/* XXX prŽvoir le cas o on peut Žcrire le texte mais pas les ressources - -> resrefnum peut tre -1 quand datarefnum est valide -*/ - -static void MakeUntitledTitle (Str255 result) -{ - char buffer [15]; - - GetIndString (result, kMiscStrings, kUntitledIdx); - if (nuntitled != 0){ - if (result [0] > 240) result [0] = 240; - sprintf (buffer, " %lu", count); Assert (strlen (buffer) < 15); - strcpy ((char *) result + result [0] + 1, buffer); - result [0] += strlen (buffer); - ++ count; - }else{ - count = 2; - } - ++ nuntitled; -} - -static void FreeUntitledTitle () -{ - -- nuntitled; -} - -/* Close the file associated with the window, saving it if needed. */ -OSErr FileDoClose (WindowPtr w, ClosingOption close) -{ - WStatusH st; - WEHandle we; - Str255 savingprompt, filename; - short item; - OSErr err; - - Assert (WinGetKind (w) == kWinDocument); - WinUpdateStatus (w); - st = WinGetStatus (w); Assert (st != NULL); - we = WinGetWE (w); Assert (we != NULL); - GetWTitle (w, filename); - if ((*st)->menuflags.save){ - GetIndString (savingprompt, kMiscStrings, kClosingIdx + close); - ParamText (filename, savingprompt, NULL, NULL); - InitCursor (); - modalkeys = kKeysSaveDontCancel; - item = Alert (kAlertSaveAsk, myModalFilterUPP); - switch (item){ - case 1: /* Yes */ - err = FileDoSave (w, 0); - if (err != noErr) return err; - break; - case 2: /* Cancel */ - return userCanceledErr; - case 3: /* No */ - break; - default: Assert (0); - } - }else{ - if ((*st)->resrefnum != -1){ - /* XXX sauver fenetre, selection, scrollbars */ - } - } - if ((*st)->datarefnum == -1){ - Assert ((*st)->resrefnum == -1); - FreeUntitledTitle (); - }else{ - FSClose ((*st)->datarefnum); - if ((*st)->resrefnum != -1) CloseResFile ((*st)->resrefnum); - } - return noErr; -} - -/* Open a new untitled window. */ -void FileNew (void) -{ - Str255 titlebuf; - WindowPtr w; - OSErr err; - WStatusH st; - - MakeUntitledTitle (titlebuf); - w = WinOpenDocument ((StringPtr) titlebuf); - if (w == NULL) {err = 0/*XXX*/; goto failed; } - st = WinGetStatus (w); Assert (st != NULL); - (*st)->datarefnum = (*st)->resrefnum = -1; - return; - - failed: - if (w != NULL) WinDoClose (closingWindow, w); - ErrorAlertGeneric (err); -} - -/* Open the specified file in a new window. */ -OSErr FileOpen (FSSpec *filespec) - { - WindowPtr w = NULL; - WStatusH st; - StringPtr title; - Str255 titlebuf; - short resrefnum = -1, datarefnum = -1; - Size textsize; - Handle texthandle = NULL; - OSErr err; - int template; - SignedByte perm; - FInfo fileinfo; - - err = FSpGetFInfo (filespec, &fileinfo); - if (err != noErr) goto failed; - if (fileinfo.fdFlags & kIsStationery){ - MakeUntitledTitle (titlebuf); - title = (StringPtr) titlebuf; - template = 1; - }else{ - title = (StringPtr) filespec->name; - template = 0; - } - perm = template ? fsRdPerm : fsRdWrPerm; - - err = FSpOpenDF (filespec, perm, &datarefnum); - if (err != noErr){ datarefnum = -1; goto failed; } - err = GetEOF (datarefnum, &textsize); - if (err != noErr) goto failed; - err = SetFPos (datarefnum, fsFromStart, 0L); - if (err != noErr) goto failed; - err = AllocHandle (textsize, &texthandle); - if (err != noErr) goto failed; - HLock (texthandle); - err = FSRead (datarefnum, &textsize, *texthandle); - HUnlock (texthandle); - if (err != noErr) goto failed; - - /*XXX FSpCreateResFile (filespec, creator, type, 0); */ - resrefnum = FSpOpenResFile (filespec, perm); - if (resrefnum != -1){ - /* XXX lire la position de la fentre, la sŽlection, les scrollbars */ - } - - w = WinOpenDocument (title); - if (w == NULL) { err = 0/*XXX*/; goto failed; } - st = WinGetStatus (w); Assert (st != NULL); - - WEUseText (texthandle, (*st)->we); - WECalText ((*st)->we); - WESetSelection (0, 0, (*st)->we); /* XXX */ - AdjustScrollBars (w); - WEResetModCount ((*st)->we); - (*st)->basemodcount = 0; - - if (template){ - FSClose (datarefnum); - if (resrefnum != -1) CloseResFile (resrefnum); - (*st)->datarefnum = (*st)->resrefnum = -1; - }else{ - (*st)->datarefnum = datarefnum; - (*st)->resrefnum = resrefnum; - } - return noErr; - - failed: - if (texthandle != NULL) DisposeHandle (texthandle); - if (datarefnum != -1) FSClose (datarefnum); - if (resrefnum != -1) CloseResFile (resrefnum); - if (w != NULL) WinDoClose (closingWindow, w); - return err; -} - -/* Get a file with the standard dialog and open it in a new window. */ -void FileDoGetOpen (void) -{ - OSErr err; - StandardFileReply sfreply; - SFTypeList types = { 'TEXT' }; - - StandardGetFile (NULL, 1, types, &sfreply); - if (sfreply.sfGood){ - err = FileOpen (&sfreply.sfFile); - if (err != noErr) ErrorAlertCantOpen (sfreply.sfFile.name, err); - } -} - -/* Revert w to the contents of its associated file. */ -void FileRevert (WindowPtr w) -{ - WStatusH st; - short err; - Size textsize; - Handle texthandle; - - /*XXX demander confirmation */ - - st = WinGetStatus (w); - Assert (st != NULL); - Assert ((*st)->datarefnum != -1); - Assert ((*st)->we != NULL); - - err = GetEOF ((*st)->datarefnum, &textsize); - if (err != noErr) goto failed; - err = SetFPos ((*st)->datarefnum, fsFromStart, 0L); - if (err != noErr) goto failed; - err = AllocHandle (textsize, &texthandle); - if (err != noErr) goto failed; - HLock (texthandle); - err = FSRead ((*st)->datarefnum, &textsize, *texthandle); - HUnlock (texthandle); - if (err != noErr) goto failed; - - /* XXX lire la sŽlection (pas la scrollbar ?) */ - - SetPortWindowPort (w); - WEUseText (texthandle, (*st)->we); - WECalText ((*st)->we); - WEUpdate (NULL, (*st)->we); - WESetSelection (0, 0, (*st)->we); /* XXX */ - AdjustScrollBars (w); - WEResetModCount ((*st)->we); - (*st)->basemodcount = 0; - return; - - failed: - if (texthandle != NULL) DisposeHandle (texthandle); - ErrorAlertGeneric (err); -} - -/* Save the text to datarefnum. - If resrefnum != -1, save the window position and the current selection. -*/ -static OSErr SaveText (WindowPtr w, short datarefnum, short resrefnum) -{ - WStatusH st = WinGetStatus (w); - Handle text; - Size textsize; - OSErr err; - - Assert (st != NULL); - Assert ((*st)->we != NULL); - err = SetEOF (datarefnum, 0L); - if (err != noErr) goto failed; - text = WEGetText ((*st)->we); - textsize = GetHandleSize (text); - HLock (text); - err = FSWrite (datarefnum, &textsize, *text); - HUnlock (text); - if (err != noErr) goto failed; - (*st)->basemodcount = WEGetModCount ((*st)->we); - - if (resrefnum != -1){ - /* XXX Žcrire la sŽlection et la position des scrollbars - attention: pas de fail. */ - } - return noErr; - - failed: - return err; -} - -/* Ask the user for a new file name, open both forks, and return - the refnums. -*/ -static OSErr PrepSaveAs (WindowPtr w, short *datarefnum, short *resrefnum, - StandardFileReply *reply) -{ - Str255 prompt, title; - OSErr err; - short auxrefnum = -1; - - *datarefnum = *resrefnum = -1; - - GetIndString (prompt, kMiscStrings, kSaveAsPromptIdx); - GetWTitle (w, title); - StandardPutFile (prompt, title, reply); - - if (reply->sfGood){ - if (reply->sfReplacing){ - err = FSpOpenDF (&reply->sfFile, fsRdWrPerm, datarefnum); - if (err != noErr) *datarefnum = -1; - if (err == opWrErr || err == fLckdErr || err == afpObjectLocked - || err == permErr || err == afpAccessDenied || err == wrPermErr){ - ErrorAlert (kCannotWriteIdx, reply->sfFile.name, kCloseQuoteIdx, err); - } - if (err != noErr) goto failed; - - err = FSpOpenRF (&reply->sfFile, fsRdWrPerm, &auxrefnum); - if (err != noErr) auxrefnum = -1; - if (err == opWrErr || err == fLckdErr || err == afpObjectLocked - || err == permErr || err == afpAccessDenied){ - ErrorAlert (kCannotWriteIdx, reply->sfFile.name, kCloseQuoteIdx, err); - } - if (err != noErr) goto failed; - - err = SetEOF (auxrefnum, 0L); - if (err != noErr) goto failed; - FSClose (auxrefnum); auxrefnum = -1; - FSpCreateResFile (&reply->sfFile, kCreatorCaml,kTypeText,reply->sfScript); - err = ResError (); if (err != noErr) goto failed; - *resrefnum = FSpOpenResFile (&reply->sfFile, fsRdWrPerm); - if (*resrefnum == -1){ err = ResError (); goto failed; } /*XXX ?? */ - - err = SetEOF (*datarefnum, 0L); - if (err != noErr) goto failed; - - }else{ - err = FSpCreate (&reply->sfFile, kCreatorCaml, kTypeText,reply->sfScript); - if (err != noErr) goto failed; - FSpCreateResFile (&reply->sfFile, kCreatorCaml,kTypeText,reply->sfScript); - err = ResError (); if (err != noErr) goto failed; - err = FSpOpenDF (&reply->sfFile, fsRdWrPerm, datarefnum); - if (err != noErr){ *datarefnum = -1; goto failed; } - *resrefnum = FSpOpenResFile (&reply->sfFile, fsRdWrPerm); - if (*resrefnum == -1){ err = ResError (); goto failed; } /*XXX ?? */ - } - }else{ - err = userCanceledErr; - goto failed; - } - return noErr; - - failed: - if (*datarefnum != -1) FSClose (*datarefnum); - if (*resrefnum != -1) CloseResFile (*resrefnum); - if (auxrefnum != -1) FSClose (auxrefnum); - return err; -} - -/* If saveasflag is true or there is no associated file, - then ask for a new file name with the standard dialog - and associate it with w. - - Save the contents of w to its associated file. -*/ -static OSErr SaveDocument (WindowPtr w, int saveasflag) -{ - WStatusH st = WinGetStatus (w); - OSErr err; - int changetitle = 0; - short datarefnum = -1, resrefnum = -1; - - Assert (st != NULL); - if (saveasflag || (*st)->datarefnum == -1){ - StandardFileReply reply; - - err = PrepSaveAs (w, &datarefnum, &resrefnum, &reply); - if (err != noErr) goto failed; - - if ((*st)->datarefnum == -1){ - Assert ((*st)->resrefnum == -1); - FreeUntitledTitle (); - }else{ - FSClose ((*st)->datarefnum); - if ((*st)->resrefnum != -1) CloseResFile ((*st)->resrefnum); - (*st)->datarefnum = (*st)->resrefnum = -1; - } - (*st)->datarefnum = datarefnum; - (*st)->resrefnum = resrefnum; - SetWTitle (w, reply.sfFile.name); - datarefnum = resrefnum = -1; - } - err = SaveText (w, (*st)->datarefnum, (*st)->resrefnum); - if (err != noErr) goto failed; - return noErr; - - failed: - if (datarefnum != -1) FSClose (datarefnum); - if (resrefnum != -1) CloseResFile (resrefnum); - return err; -} - -/* Save the toplevel window to a new file. Do not save the window - position or the current selection. -*/ -static OSErr SaveToplevel (void) -{ - WStatusH st; - StandardFileReply reply; - short datarefnum = -1, resrefnum = -1; - OSErr err; - - Assert (winToplevel != NULL); - st = WinGetStatus (winToplevel); - Assert (st != NULL); - - err = PrepSaveAs (winToplevel, &datarefnum, &resrefnum, &reply); - if (err != noErr) goto failed; - err = SaveText (winToplevel, datarefnum, -1); - if (err != noErr) goto failed; - FSClose (datarefnum); - if (resrefnum != -1) CloseResFile (resrefnum); - return noErr; - - failed: - if (datarefnum != -1) FSClose (datarefnum); - if (resrefnum != -1) CloseResFile (resrefnum); - return err; -} - -static OSErr SaveGraphics (void) -{ - XXX (); - return noErr; -} - -OSErr FileDoSave (WindowPtr w, int saveasflag) -{ - if (w == winToplevel) return SaveToplevel (); - else if (w == winGraphics) return SaveGraphics (); - else return SaveDocument (w, saveasflag); -} diff --git a/maccaml/glue.c b/maccaml/glue.c deleted file mode 100644 index ea9b5f97fb..0000000000 --- a/maccaml/glue.c +++ /dev/null @@ -1,557 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Damien Doligez, projet Para, INRIA Rocquencourt */ -/* */ -/* Copyright 1998 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 file ../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include -#include -#include -#include - -#include "alloc.h" -#include "mlvalues.h" -#include "rotatecursor.h" -#include "signals.h" -#include "ui.h" - -#include "main.h" - -/* These are defined by the ocamlrun library. */ -void caml_main(char **argv); -Handle macos_getfullpathname (short vrefnum, long dirid); - -/* This pointer contains the environment variables. */ -char *envPtr = NULL; - -/* True if the Caml program is reading from the console. */ -static int caml_reading_console = 0; - -/* [Caml_working] is used to manage the processor idle state on - PowerBooks. [Caml_working (1)] disables the idle state, and - [Caml_working (0)] enables it. -*/ -static int caml_at_work = 0; -static void Caml_working (int newstate) -{ - if (gHasPowerManager){ - if (caml_at_work && !newstate) EnableIdle (); - if (!caml_at_work && newstate) DisableIdle (); - } - caml_at_work = newstate; -} - -/* - Animated cursor (only when toplevel window is frontmost). -*/ -typedef struct { - short nframes; - short current; - union { - CursHandle h; - struct { short id; short fill; } i; - } frames [1]; -} **AnimCursHandle; - -static AnimCursHandle acurh = NULL; - -pascal void InitCursorCtl (acurHandle newCursors) -{ -#pragma unused (newCursors) - long i; - - if (acurh != NULL) return; - acurh = (AnimCursHandle) GetResource ('acur', 0); - for (i = 0; i < (*acurh)->nframes; i++){ - (*acurh)->frames[i].h = GetCursor ((*acurh)->frames[i].i.id); - if ((*acurh)->frames[i].h == NULL){ - (*acurh)->frames[i].h = GetCursor (watchCursor); - Assert ((*acurh)->frames[i].h != NULL); - } - } - (*acurh)->current = 0; -} - -pascal void RotateCursor (long counter) -{ -#pragma unused (counter) - if (acurh == NULL) InitCursorCtl (NULL); - /* (*acurh)->current += (*acurh)->nframes + (counter >= 0 ? 1 : -1); */ - (*acurh)->current += (*acurh)->nframes + (caml_at_work ? 1 : -1); - (*acurh)->current %= (*acurh)->nframes; -} - -int AdjustRotatingCursor (void) -{ - static Point oldmouse = {-1, -1}; - Point mouse; - int res = 0; - - if (acurh == NULL) InitCursorCtl (NULL); - - GetMouse (&mouse); - if (mouse.h != oldmouse.h || mouse.v != oldmouse.v){ - last_event_date = TickCount (); - } - if (caml_reading_console == 0 && TickCount () > last_event_date + 60){ - SetCursor (*((*acurh)->frames[(*acurh)->current].h)); - ShowCursor (); - res = 1; - } - oldmouse = mouse; - return res; -} - -static pascal void interp_yield (long counter) -{ - RotateCursor (counter); - GetAndProcessEvents (noWait, 0, 0); - if (intr_requested){ - intr_requested = 0; - raise (SIGINT); - } -} - -/* Expand the percent escapes in the string specified by s. - The escapes are: - %a application file name - %d full pathname of the current working directory (ends in ':') - %t full pathname of the temporary directory (ends in ':') - %% a percent sign "%" -*/ -static OSErr expand_escapes (Handle s) -{ - Size i, j, l; - OSErr err; - Handle curdir = NULL, tmpdir = NULL; - char *ptr2; - long len2; - - l = GetHandleSize (s) - 1; - i = j = 0; - while (i < l){ - if ((*s)[j] == '%'){ - switch ((*s)[j+1]){ - case 'a': - ptr2 = (char *) LMGetCurApName () + 1; - len2 = * (LMGetCurApName ()); - break; - case 'd': - if (curdir == NULL) curdir = macos_getfullpathname (0, 0); - if (curdir == NULL){ err = fnfErr; goto failed; } - HLock (curdir); - ptr2 = *curdir; - len2 = GetHandleSize (curdir); - break; - case 't': - if (tmpdir == NULL){ - short vrefnum; - long dirid; - err = FindFolder (kOnSystemDisk, kTemporaryFolderType, true, - &vrefnum, &dirid); - tmpdir = macos_getfullpathname (vrefnum, dirid); - if (tmpdir == NULL){ err = fnfErr; goto failed; } - } - HLock (tmpdir); - ptr2 = *tmpdir; - len2 = GetHandleSize (tmpdir); - break; - case '%': - ptr2 = "%"; - len2 = 1; - break; - default: - ptr2 = ""; - len2 = 0; - break; - } - Munger (s, j, NULL, 2, ptr2, len2); - j += len2 - 2; - i += 1; - } - ++ i; - ++ j; - } - if (curdir != NULL) DisposeHandle (curdir); - if (tmpdir != NULL) DisposeHandle (tmpdir); - return noErr; - - failed: - if (curdir != NULL) DisposeHandle (curdir); - if (tmpdir != NULL) DisposeHandle (tmpdir); - return err; -} - -/* [build_command_line] creates the array of strings that represents - the command line according to the template found in - the 'Line'(kCommandLineTemplate) resource and the environment - variables according to the 'Line'(kEnvironmentTemplate). - - Each of these resources is a sequence of strings terminated by null - bytes. In each string, percent escapes are expanded (see above for - a description of percent escapes). - - Each resource ends with a null byte. -*/ -static OSErr build_command_line (char ***p_argv) -{ - Handle template = NULL; - Size len, i, j; - char *args = NULL; - int argc; - char **argv = NULL; - OSErr err; - - template = GetResource ('Line', kCommandLineTemplate); - if (template == NULL){ err = ResError (); goto failed; } - err = expand_escapes (template); if (err != noErr) goto failed; - len = GetHandleSize (template); - - args = malloc (len); - if (args == NULL){ err = memFullErr; goto failed; } - memmove (args, *template, len); - - argc = 0; - for (i = 0; i < len; i++){ - if (args[i] == '\000') ++ argc; - } - argv = malloc ((argc+1) * sizeof (char *)); - if (argv == NULL){ err = memFullErr; goto failed; } - - i = j = 0; - do{ - argv[j++] = args + i; - while (args [i] != '\000') ++ i; - ++ i; - }while (i < len); - argv [argc] = NULL; - - ReleaseResource (template); - - template = GetResource ('Line', kEnvironmentTemplate); - if (template == NULL){ err = ResError (); goto failed; } - err = expand_escapes (template); if (err != noErr) goto failed; - len = GetHandleSize (template); - envPtr = NewPtr (len); - if (envPtr == NULL){ err = MemError (); goto failed; } - memmove (envPtr, *template, len); - - *p_argv = argv; - return noErr; - - failed: - if (template != NULL) ReleaseResource (template); - if (args != NULL) free (args); - if (argv != NULL) free (argv); - return err; -} - -/* [launch_caml_main] is called by [main]. - - After building the command line, [launch_caml_main] launches [caml_main] - in a thread, then executes the GUI event loop in the main thread. -*/ - -OSErr launch_caml_main (void) -{ - char **argv; - OSErr err; - - rotatecursor_options (&something_to_do, 0, &interp_yield); - err = WinOpenToplevel (); - if (err != noErr) goto failed; - - err = build_command_line (&argv); - if (err) goto failed; - - Caml_working (1); - caml_main (argv); - ui_exit (0); - - failed: - return err; -} - -/* console I/O functions */ - -/* Management of error highlighting. */ -static int erroring = 0; -static long error_curpos; -static long error_anchor = -1; - -void FlushUnreadInput (void) -{ - WEReference we; - int active; - - we = WinGetWE (winToplevel); - Assert (we != NULL); - - WEFeatureFlag (weFReadOnly, weBitClear, we); - WESetSelection (wintopfrontier, wintopfrontier, we); - WEFeatureFlag (weFOutlineHilite, weBitClear, we); - active = WEIsActive (we); - if (active) WEDeactivate (we); - WESetSelection (wintopfrontier, WEGetTextLength (we), we); - WEDelete (we); - if (active) WEActivate (we); - WEFeatureFlag (weFOutlineHilite, weBitSet, we); -} - -int ui_read (int fd, char *buffer, unsigned int nCharsDesired) -{ - long len, i; - char **htext; - WEReference we; - long selstart, selend; - Boolean active; - short readonly, autoscroll; - int atend; - - if (fd != 0) return read (fd, buffer, nCharsDesired); - - we = WinGetWE (winToplevel); - Assert (we != NULL); - htext = (char **) WEGetText (we); - - ++ caml_reading_console; - - while (1){ - char *p; - - len = WEGetTextLength (we); - p = *htext; - for (i = wintopfrontier; i < len; i++){ - if (p[i] == '\n') goto gotit; - } - GetAndProcessEvents (waitEvent, 0, 0); - } - - gotit: - - len = i+1 - wintopfrontier; - if (len > nCharsDesired) len = nCharsDesired; - memmove (buffer, (*htext)+wintopfrontier, len); - - atend = ScrollAtEnd (winToplevel); - autoscroll = WEFeatureFlag (weFAutoScroll, weBitTest, we); - WEFeatureFlag (weFAutoScroll, weBitClear, we); - WEGetSelection (&selstart, &selend, we); - readonly = WEFeatureFlag (weFReadOnly, weBitTest, we); - WEFeatureFlag (weFReadOnly, weBitClear, we); - /* Always set an empty selection before changing OutlineHilite or - the active status. */ - WESetSelection (wintopfrontier, wintopfrontier, we); - WEFeatureFlag (weFOutlineHilite, weBitClear, we); - active = WEIsActive (we); - if (active) WEDeactivate (we); - WESetSelection (wintopfrontier, wintopfrontier+len, we); - WESetStyle (weDoFont + weDoFace + weDoSize + weDoColor + weDoReplaceFace, - &prefs.input, we); - WESetSelection (wintopfrontier, wintopfrontier, we); - if (active) WEActivate (we); - WEFeatureFlag (weFOutlineHilite, weBitSet, we); - WESetSelection (selstart, selend, we); - if (readonly) WEFeatureFlag (weFReadOnly, weBitSet, we); - if (autoscroll) WEFeatureFlag (weFAutoScroll, weBitSet, we); - AdjustScrollBars (winToplevel); - if (atend) ScrollToEnd (winToplevel); - - WinAdvanceTopFrontier (len); - - -- caml_reading_console; - return len; -} - -int ui_write (int fd, char *buffer, unsigned int nChars) -{ - long selstart, selend; - WEReference we; - OSErr err; - short readonly, autoscroll; - int atend; - - if (fd != 1 && fd != 2) return write (fd, buffer, nChars); - - Assert (nChars >= 0); - we = WinGetWE (winToplevel); - Assert (we != NULL); - - if (erroring){ /* overwrite mode to display errors; see terminfo_* */ - error_curpos += nChars; - if (error_curpos > wintopfrontier) error_curpos = wintopfrontier; - return nChars; - } - - atend = ScrollAtEnd (winToplevel); - autoscroll = WEFeatureFlag (weFAutoScroll, weBitTest, we); - WEFeatureFlag (weFAutoScroll, weBitClear, we); - WEGetSelection (&selstart, &selend, we); - readonly = WEFeatureFlag (weFReadOnly, weBitTest, we); - WEFeatureFlag (weFReadOnly, weBitClear, we); - WESetSelection (wintopfrontier, wintopfrontier, we); - WESetStyle (weDoFont + weDoFace + weDoSize + weDoColor + weDoReplaceFace, - &prefs.output, we); - err = WEInsert (buffer, nChars, NULL, NULL, we); - if (err != noErr){ - WESetSelection (selstart, selend, we); - return nChars; - } - if (selstart >= wintopfrontier){ - selstart += nChars; - selend += nChars; - }else if (selend > wintopfrontier){ - selend += nChars; - } - WESetSelection (selstart, selend, we); - if (autoscroll) WEFeatureFlag (weFAutoScroll, weBitSet, we); - AdjustScrollBars (winToplevel); - if (atend) ScrollToEnd (winToplevel); - - WinAdvanceTopFrontier (nChars); - - return nChars; -} - -void ui_print_stderr (char *msg, void *arg) -{ - char buf [1000]; - - sprintf (buf, msg, arg); - ui_write (2, buf, strlen (buf)); -} - -void ui_exit (int return_code) -{ -#pragma unused (return_code) - Str255 buf0; - Str255 buf1; - - caml_reading_console = 1; /* hack: don't display rotating cursor */ - - if (return_code != 0){ - GetIndString (buf0, kMiscStrings, kWithErrorCodeIdx); - NumToString ((long) return_code, buf1); - }else{ - buf0[0] = 0; - buf1[0] = 0; - } - ParamText (buf0, buf1, NULL, NULL); - InitCursor (); - modalkeys = kKeysOK; - NoteAlert (kAlertExit, myModalFilterUPP); - - while (1) GetAndProcessEvents (waitEvent, 0, 0); - - if (winGraphics != NULL) WinCloseGraphics (); - WinCloseToplevel (); - rotatecursor_final (); - FinaliseAndQuit (); -} - - -/* - [getenv] in the standalone application - envPtr is set up by launch_caml_main -*/ -char *getenv (const char *name) -{ - Size envlen, i, namelen; - - Assert (envPtr != NULL); - envlen = GetPtrSize (envPtr); - namelen = strlen (name); - i = 0; - do{ - if (!strncmp (envPtr + i, name, namelen) && envPtr [i+namelen] == '='){ - return envPtr + i + namelen + 1; - } - while (envPtr [i] != '\000') ++ i; - ++ i; - }while (i < envlen); - return NULL; -} - - -/* - [terminfo] stuff: change the style of displayed text to show the - error locations. See also ui_write. -*/ - -value terminfo_setup (value vchan); -value terminfo_backup (value lines); -value terminfo_standout (value start); -value terminfo_resume (value lines); - -#define Good_term_tag 0 - -value terminfo_setup (value vchan) -{ -#pragma unused (vchan) - value result = alloc (1, Good_term_tag); - Field (result, 0) = Val_int (1000000000); - return result; -} - -value terminfo_backup (value lines) -{ - long i, j; - Handle txt; - char *p; - WEReference we = WinGetWE (winToplevel); - - Assert (we != NULL); - txt = WEGetText (we); - p = (char *) *txt; - j = wintopfrontier - 1; - - while (j >= 0 && p[j] != '\n') --j; - for (i = 0; i < Long_val (lines); i++){ - Assert (p[j] == '\n' || j == -1); - do{ --j; }while (j >= 0 && p[j] != '\n'); - } - Assert (p[j] == '\n' || j == -1); - error_curpos = j + 1; - erroring = 1; - error_anchor = -1; - return Val_unit; -} - -value terminfo_standout (value start) -{ - if (Bool_val (start) && error_anchor == -1){ - error_anchor = error_curpos; - }else if (!Bool_val (start) && error_anchor != -1){ - long selstart, selend; - WEReference we = WinGetWE (winToplevel); - short readonly; - - Assert (we != NULL); - WEGetSelection (&selstart, &selend, we); - readonly = WEFeatureFlag (weFReadOnly, weBitTest, we); - if (readonly) WEFeatureFlag (weFReadOnly, weBitClear, we); - WESetSelection (error_anchor, error_curpos, we); - WESetStyle (weDoFont + weDoFace + weDoSize + weDoColor + weDoReplaceFace, - &prefs.errors, we); - if (readonly) WEFeatureFlag (weFReadOnly, weBitSet, we); - WESetSelection (selstart, selend, we); - error_anchor = -1; - } - return Val_unit; -} - -value terminfo_resume (value lines) -{ -#pragma unused (lines) - erroring = 0; - return Val_unit; -} diff --git a/maccaml/graph.c b/maccaml/graph.c deleted file mode 100644 index 1bf03d9a37..0000000000 --- a/maccaml/graph.c +++ /dev/null @@ -1,1179 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Damien Doligez, projet Para, INRIA Rocquencourt */ -/* */ -/* Copyright 1998 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 file ../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include "alloc.h" -#include "callback.h" -#include "fail.h" -#include "memory.h" -#include "mlvalues.h" -#include "signals.h" - -#include "main.h" /* Include main.h last or Assert will not work. */ - - -/* The off-screen buffer that holds the contents of the graphics arena. */ -static GWorldPtr gworld = NULL; - -/* An arbitrarily large rectangle (for clipping). */ -static Rect maxrect = { -SHRT_MAX, -SHRT_MAX, SHRT_MAX, SHRT_MAX }; - -/* Coordinates (relative to the window) of the top-left corner - of the graphics arena. */ -long x0, y0; - -/* Width and height of the graphics arena. */ -long w0, h0; - -RGBColor fgcolor; - -/* Convert from Caml coordinates to QD coordinates in the off-screen buffer. */ -/* Note: these conversions are self-inverse (see gr_current_point). */ -#define Bx(x) (x) -#define By(y) (h0-1 - (y)) - -/* Convert from Caml coordinates to QD coordinates in the window. */ -#define Wx(x) (Bx(x) + x0) -#define Wy(y) (By(y) + y0) - -/* Convert from QD window coordinates to Caml coordinates. */ -#define Cx(x) ((x) - x0) -#define Cy(y) (h0-1 - ((y) - y0)) - - -/***********************************************************************/ -/* User interface functions */ -/***********************************************************************/ - -static void GraphUpdateGW (void) -{ - Rect r; - WStatusH st = WinGetStatus (winGraphics); - - Assert (st != NULL); - Assert (gworld != NULL); - WELongRectToRect (&(*st)->destrect, &r); - OffsetRect (&r, winGraphics->portRect.left, winGraphics->portRect.top); - UpdateGWorld (&gworld, 0, &r, NULL, NULL, clipPix); -} - -void GraphNewSizePos (void) -{ - GraphUpdateGW (); -} - -/* The current port must be winGraphics when this function is called. */ -void GraphUpdate (void) -{ - Rect r, src, dst; - Boolean good; - WStatusH st = WinGetStatus (winGraphics); - RGBColor forecolor, backcolor; - - Assert (st != NULL); - GraphUpdateGW (); - good = LockPixels (GetGWorldPixMap (gworld)); Assert (good); - WELongRectToRect (&(*st)->destrect, &r); - WELongRectToRect (&(*st)->viewrect, &dst); - src = dst; - OffsetRect (&src, -r.left, -r.top); - GetBackColor (&backcolor); - GetForeColor (&forecolor); - BackColor (whiteColor); - ForeColor (blackColor); - CopyBits (&((GrafPtr) gworld)->portBits, &((GrafPtr) winGraphics)->portBits, - &src, &dst, srcCopy, NULL); - RGBBackColor (&backcolor); - RGBForeColor (&forecolor); - UnlockPixels (GetGWorldPixMap (gworld)); -} - -/* All scrolling of the graphics window must go through this function - so it can update the coordinates x0 and y0, and the pen location. */ -void GraphScroll (long dx, long dy) -{ - Rect r; - RgnHandle update = NewRgn (); - WStatusH st = WinGetStatus (winGraphics); - Point p; - GrafPtr port; - - Assert (st != NULL); - GetPort (&port); - SetPort (winGraphics); - WELongRectToRect (&(*st)->viewrect, &r); - ScrollRect (&r, dx, dy, update); - WEOffsetLongRect (&(*st)->destrect, dx, dy); - SetClip (update); - GraphUpdate (); - ClipRect (&maxrect); - DisposeRgn (update); - - x0 += dx; - y0 += dy; - GetPen (&p); - MoveTo (p.h + dx, p.v + dy); - SetPort (port); -} - -/* Graphics event queue */ -#define GraphQsize 15 -static EventRecord graphQ[GraphQsize]; -static int graphQlen = 0; - -#define Succ(x) ((x) >= GraphQsize ? 0 : (x)+1) - -void GraphGotEvent (EventRecord *evt) -{ - GrafPort *saveport; - - if (graphQlen < GraphQsize) ++ graphQlen; - memmove (&(graphQ[1]), &(graphQ[0]), (graphQlen - 1) * sizeof (graphQ[0])); - - graphQ[0] = *evt; - - PushWindowPort (winGraphics); - GlobalToLocal (&(graphQ[0].where)); - PopPort; -} -static void DequeueEvent (int i) -{ - -- graphQlen; - memmove (&(graphQ[i]), &(graphQ[i+1]), (graphQlen - i) * sizeof (graphQ[0])); -} - -/***********************************************************************/ -/* Primitives for the graphics library */ -/***********************************************************************/ - -value gr_open_graph (value vgeometry); -value gr_close_graph (value unit); -value gr_sigio_signal (value unit); -value gr_sigio_handler (value unit); -value gr_display_mode (value flag); -value gr_remember_mode (value flag); -value gr_synchronize (value unit); -value gr_clear_graph (value unit); -value gr_size_x (value unit); -value gr_size_y (value unit); -value gr_set_color (value vrgb); -value gr_plot (value vx, value vy); -value gr_point_color (value vx, value vy); -value gr_moveto (value vx, value vy); -value gr_current_x (value unit); -value gr_current_y (value unit); -value gr_lineto (value vx, value vy); -value gr_draw_rect (value vx, value vy, value vw, value vh); -value gr_draw_arc (value *argv, int argc); -value gr_draw_arc_nat (value, value, value, value, value, value); -value gr_set_line_width (value vwidth); -value gr_fill_rect (value vx, value vy, value vw, value vh); -value gr_fill_poly (value vpoints); -value gr_fill_arc (value *argv, int argc); -value gr_fill_arc_nat (value, value, value, value, value, value); -value gr_draw_char (value vchr); -value gr_draw_string (value vstr); -value gr_set_font (value vfontname); -value gr_set_text_size (value vsz); -value gr_text_size (value vstr); -value gr_make_image (value varray); -value gr_dump_image (value vimage); -value gr_draw_image (value vimage, value vx, value vy); -value gr_create_image (value vw, value vh); -value gr_blit_image (value vimage, value vx, value vy); -value gr_wait_event (value veventlist); -value gr_sound (value vfreq, value vdur); -value gr_set_window_title (value title); - -#define UNIMPLEMENTED(f, args) \ -value f args; \ -value f args \ -{ \ - failwith ("not implemented: " #f); \ - return Val_unit; /* not reached */ \ -} - -UNIMPLEMENTED (gr_window_id, (value unit)) -UNIMPLEMENTED (gr_open_subwindow, (value x, value y, value w, value h)) -UNIMPLEMENTED (gr_close_subwindow, (value id)) - - -/**** Ancillary macros and function */ - -/* double-buffer or write-through */ -static int grdisplay_mode; -static int grremember_mode; - -/* Current state */ -static long cur_x, cur_y; -static short cur_width, cur_font, cur_size; -/* see also fgcolor */ - - -/* Drawing off-screen and on-screen simultaneously. The following three - macros must always be used together and in this order. -*/ -/* 1. Begin drawing in the off-screen buffer. */ -#define BeginOff { \ - CGrafPtr _saveport_; \ - GDHandle _savegdev_; \ - Rect _cliprect_; \ - if (grremember_mode) { \ - GetGWorld (&_saveport_, &_savegdev_); \ - LockPixels (GetGWorldPixMap (gworld)); \ - SetGWorld ((CGrafPtr) gworld, NULL); - -/* 2. Continue with on-screen drawing. */ -#define On \ - SetGWorld (_saveport_, _savegdev_); \ - UnlockPixels (GetGWorldPixMap (gworld)); \ - } \ - if (grdisplay_mode) { \ - SetPort (winGraphics); \ - ScrollCalcGraph (winGraphics, &_cliprect_); \ - ClipRect (&_cliprect_); - -/* 3. Clean up after drawing. */ -#define EndOffOn \ - ClipRect (&maxrect); \ - SetPort ((GrafPtr) _saveport_); \ - } \ -} - -/* Set up the current port unconditionally. This is for functions that - don't draw (measurements and setting the graphport state). - Usage: BeginOffAlways / EndOffAlways - or BeginOffAlways / OnAlways / EndOffOnAlways - */ -#define BeginOffAlways { \ - CGrafPtr _saveport_; \ - GDHandle _savegdev_; \ - GetGWorld (&_saveport_, &_savegdev_); \ - LockPixels (GetGWorldPixMap (gworld)); \ - SetGWorld ((CGrafPtr) gworld, NULL); - -#define EndOffAlways \ - SetGWorld (_saveport_, _savegdev_); \ - UnlockPixels (GetGWorldPixMap (gworld)); \ -} - -#define OnAlways \ - SetGWorld (_saveport_, _savegdev_); \ - UnlockPixels (GetGWorldPixMap (gworld)); \ - SetPort (winGraphics); \ - -#define EndOffOnAlways \ - SetPort ((GrafPtr) _saveport_); \ -} - -/* Convert a red, green, or blue value from 8 bits to 16 bits. */ -#define RGB8to16(x) ((x) | ((x) << 8)) - -/* Declare and convert x and y from vx and vy. */ -#define XY long x = Long_val (vx), y = Long_val (vy) - - -static value * graphic_failure_exn = NULL; - -static void gr_fail(char *fmt, void *arg) -{ - char buffer[1024]; - - if (graphic_failure_exn == NULL) { - graphic_failure_exn = caml_named_value("Graphics.Graphic_failure"); - if (graphic_failure_exn == NULL){ - invalid_argument("Exception Graphics.Graphic_failure not initialized," - " you must load graphics.cma"); - } - } - sprintf(buffer, fmt, arg); - raise_with_string(*graphic_failure_exn, buffer); -} - -static void gr_check_open (void) -{ - if (winGraphics == NULL) gr_fail("graphic screen not opened", NULL); -} - -/* Max_image_mem is the number of image pixels that can be allocated - in one major GC cycle. The GC will speed up to match this allocation - speed. -*/ -#define Max_image_mem 1000000 /*FIXME Should use user pref. */ - -#define Transparent (-1) - -struct grimage { - final_fun f; /* Finalization function */ - long width, height; /* Dimensions of the image */ - GWorldPtr data; /* Pixels */ - GWorldPtr mask; /* Mask for transparent points, or NULL */ -}; - -#define Grimage_wosize \ - ((sizeof (struct grimage) + sizeof (value) - 1) / sizeof (value)) - -static void free_image (value vimage) -{ - struct grimage *im = (struct grimage *) Bp_val (vimage); - - if (im->data != NULL) DisposeGWorld (im->data); - if (im->mask != NULL) DisposeGWorld (im->mask); -} - -static value alloc_image (long w, long h) -{ - value res = alloc_final (Grimage_wosize, free_image, w*h, Max_image_mem); - struct grimage *im = (struct grimage *) Bp_val (res); - Rect r; - QDErr err; - - im->width = w; - im->height = h; - im->mask = NULL; - SetRect (&r, 0, 0, w, h); - err = NewGWorld (&im->data, 32, &r, NULL, NULL, 0); - if (err != noErr){ - im->data = NULL; - gr_fail ("Cannot allocate image (error code %ld)", (void *) err); - } - return res; -} - -static value gr_alloc_int_vect(mlsize_t size) -{ - value res; - mlsize_t i; - - if (size <= Max_young_wosize) { - res = alloc(size, 0); - } else { - res = alloc_shr(size, 0); - } - for (i = 0; i < size; i++) { - Field(res, i) = Val_long(0); - } - return res; -} - -/***********************************************************************/ - -value gr_open_graph (value vgeometry) -{ - int i; - short err; - Rect r; - WStatusH st; - - if (winGraphics == NULL){ - Assert (gworld == NULL); - - i = sscanf (String_val (vgeometry), "%ldx%ld", &w0, &h0); - if (i < 2){ - w0 = 640; - h0 = 480; - } - if (w0 < kMinWindowWidth - kScrollBarWidth - 1){ - w0 = kMinWindowWidth - kScrollBarWidth - 1; - } - if (h0 < kMinWindowHeight - kScrollBarWidth - 1){ - h0 = kMinWindowHeight - kScrollBarWidth - 1; - } - - err = WinOpenGraphics (w0, h0); - if (err != noErr) goto failed; - - x0 = y0 = 0; - - st = WinGetStatus (winGraphics); Assert (st != NULL); - WELongRectToRect (&(*st)->destrect, &r); - OffsetRect (&r, winGraphics->portRect.left, winGraphics->portRect.top); - err = NewGWorld (&gworld, 0, &r, NULL, NULL, 0); - if (err != noErr) goto failed; - - fgcolor.red = fgcolor.green = fgcolor.blue = 0; - } - /* Synchronise off-screen and on-screen by initialising everything. */ - grremember_mode = 1; - grdisplay_mode = 1; - gr_clear_graph (Val_unit); - gr_moveto (Val_long (0), Val_long (0)); - gr_set_color (Val_long (0)); - gr_set_line_width (Val_long (0)); - gr_set_font ((value) "geneva"); /* XXX hack */ - gr_set_text_size (Val_long (12)); - - return Val_unit; - - failed: - if (gworld != NULL){ - DisposeGWorld (gworld); - gworld = NULL; - } - if (winGraphics != NULL) WinCloseGraphics (); - gr_fail ("open_graph failed (error %d)", (void *) (long) err); - return Val_unit; /* not reached */ -} - -value gr_close_graph (value unit) -{ -#pragma unused (unit) - gr_check_open (); - WinCloseGraphics (); - DisposeGWorld (gworld); - gworld = NULL; - return Val_unit; -} - -value gr_sigio_signal (value unit) /* Not used on MacOS */ -{ -#pragma unused (unit) - return Val_unit; -} - -value gr_sigio_handler (value unit) /* Not used on MacOS */ -{ -#pragma unused (unit) - return Val_unit; -} - -value gr_synchronize (value unit) -{ -#pragma unused (unit) - GrafPtr saveport; - - gr_check_open (); - PushWindowPort (winGraphics); - GraphUpdate (); - PopPort; - return Val_unit; -} - -value gr_display_mode (value flag) -{ - grdisplay_mode = Bool_val (flag); - return Val_unit; -} - -value gr_remember_mode (value flag) -{ - grremember_mode = Bool_val (flag); - return Val_unit; -} - -value gr_clear_graph (value unit) -{ -#pragma unused (unit) - gr_check_open (); - BeginOff - EraseRect (&maxrect); - On - EraseRect (&maxrect); - EndOffOn - return unit; -} - -value gr_size_x (value unit) -{ -#pragma unused (unit) - gr_check_open (); - return Val_long (w0); -} - -value gr_size_y (value unit) -{ -#pragma unused (unit) - gr_check_open (); - return Val_long (h0); -} - -value gr_set_color (value vrgb) -{ - long rgb = Long_val (vrgb); - - gr_check_open (); - fgcolor.red = RGB8to16 ((rgb >> 16) & 0xFF); - fgcolor.green = RGB8to16 ((rgb >> 8) & 0xFF); - fgcolor.blue = RGB8to16 (rgb & 0xFF); - BeginOffAlways - RGBForeColor (&fgcolor); - OnAlways - RGBForeColor (&fgcolor); - EndOffOnAlways - return Val_unit; -} - -value gr_plot (value vx, value vy) -{ - XY; - - gr_check_open (); - BeginOff - SetCPixel (Bx (x), By (y) - 1, &fgcolor); - On - SetCPixel (Wx (x), Wy (y) - 1, &fgcolor); - EndOffOn - return Val_unit; -} - -value gr_point_color (value vx, value vy) -{ - XY; - RGBColor c; - - gr_check_open (); - if (x < 0 || x >= w0 || y < 0 || y >= h0) return Val_long (-1); - BeginOffAlways - GetCPixel (Bx (x), By (y) - 1, &c); - EndOffAlways - return Val_long (((c.red & 0xFF00) << 8) - | (c.green & 0xFF00) - | ((c.blue & 0xFF00) >> 8)); -} - -value gr_moveto (value vx, value vy) -{ - XY; - - gr_check_open (); - cur_x = x; cur_y = y; - return Val_unit; -} - -value gr_current_x (value unit) -{ -#pragma unused (unit) - - gr_check_open (); - return Val_long (cur_x); -} - -value gr_current_y (value unit) -{ -#pragma unused (unit) - - gr_check_open (); - return Val_long (cur_y); -} - -value gr_lineto (value vx, value vy) -{ - XY; - int delta = cur_width / 2; - - gr_check_open (); - BeginOff - MoveTo (Bx (cur_x) - delta, By (cur_y) - delta); - LineTo (Bx (x) - delta, By (y) - delta); - On - MoveTo (Wx (cur_x) - delta, Wy (cur_y) - delta); - LineTo (Wx (x) - delta, Wy (y) - delta); - EndOffOn - cur_x = x; cur_y = y; - return Val_unit; -} - -value gr_draw_rect (value vx, value vy, value vw, value vh) -{ - XY; - long w = Long_val (vw), h = Long_val (vh); - Rect r; - int d1 = cur_width / 2; - int d2 = cur_width - d1; - - gr_check_open (); - BeginOff - SetRect (&r, Bx (x) - d1, By (y+h) - d1, Bx (x+w) + d2, By (y) + d2); - FrameRect (&r); - On - SetRect (&r, Wx (x) - d1, Wy (y+h) - d1, Wx (x+w) + d2, Wy (y) + d2); - FrameRect (&r); - EndOffOn - return Val_unit; -} - -value gr_draw_arc (value *argv, int argc) -{ -#pragma unused (argc) - return gr_draw_arc_nat (argv[0], argv[1], argv[2], argv[3], argv[4], argv[5]); -} - -value gr_draw_arc_nat (value vx, value vy, value vrx, value vry, value va1, - value va2) -{ - XY; - long rx = Long_val (vrx), ry = Long_val (vry); - long a1 = Long_val (va1), a2 = Long_val (va2); - Rect r; - long qda1 = 90 - a1, qda2 = 90 - a2; - int d1 = cur_width / 2; - int d2 = cur_width - d1; - - gr_check_open (); - BeginOff - SetRect (&r, Bx(x-rx) - d1, By(y+ry) - d1, Bx(x+rx) + d2, By(y-ry) + d2); - FrameArc (&r, qda1, qda2 - qda1); - On - SetRect (&r, Wx(x-rx) - d1, Wy(y+ry) - d1, Wx(x+rx) + d2, Wy(y-ry) + d2); - FrameArc (&r, qda1, qda2 - qda1); - EndOffOn - return Val_unit; -} - -value gr_set_line_width (value vwidth) -{ - short width = Int_val (vwidth); - - if (width == 0) width = 1; - gr_check_open (); - BeginOffAlways - PenSize (width, width); - OnAlways - PenSize (width, width); - EndOffOnAlways - cur_width = width; - return Val_unit; -} - -value gr_fill_rect (value vx, value vy, value vw, value vh) -{ - XY; - long w = Long_val (vw), h = Long_val (vh); - Rect r; - - gr_check_open (); - BeginOff - SetRect (&r, Bx (x), By (y+h), Bx (x+w), By (y)); - PaintRect (&r); - On - SetRect (&r, Wx (x), Wy (y+h), Wx (x+w), Wy (y)); - PaintRect (&r); - EndOffOn - return Val_unit; -} - -value gr_fill_poly (value vpoints) -{ - long i, n = Wosize_val (vpoints); - PolyHandle p; - - #define Bxx(i) Bx (Int_val (Field (Field (vpoints, (i)), 0))) - #define Byy(i) By (Int_val (Field (Field (vpoints, (i)), 1))) - - gr_check_open (); - if (n < 1) return Val_unit; - - p = OpenPoly (); - MoveTo (Bxx (0), Byy (0)); - for (i = 1; i < n; i++) LineTo (Bxx (i), Byy (i)); - ClosePoly (); - BeginOff - PaintPoly (p); - On - OffsetPoly (p, x0, y0); - PaintPoly (p); - EndOffOn - KillPoly (p); - return Val_unit; -} - -value gr_fill_arc (value *argv, int argc) -{ -#pragma unused (argc) - return gr_fill_arc_nat (argv[0], argv[1], argv[2], argv[3], argv[4], argv[5]); -} - -value gr_fill_arc_nat (value vx, value vy, value vrx, value vry, value va1, - value va2) -{ - XY; - long rx = Long_val (vrx), ry = Long_val (vry); - long a1 = Long_val (va1), a2 = Long_val (va2); - Rect r; - long qda1 = 90 - a1, qda2 = 90 - a2; - - gr_check_open (); - BeginOff - SetRect (&r, Bx (x-rx), By (y+ry), Bx (x+rx), By (y-ry)); - PaintArc (&r, qda1, qda2 - qda1); - On - SetRect (&r, Wx (x-rx), Wy (y+ry), Wx (x+rx), Wy (y-ry)); - PaintArc (&r, qda1, qda2 - qda1); - EndOffOn - return Val_unit; -} - -static void draw_text (char *txt, unsigned long len) -{ - FontInfo info; - unsigned long w; - - if (len > 32767) len = 32767; - - BeginOffAlways - GetFontInfo (&info); - w = TextWidth (txt, 0, len); - EndOffAlways - - gr_check_open (); - BeginOff - MoveTo (Bx (cur_x), By (cur_y) - info.descent); - DrawText (txt, 0, len); - On - MoveTo (Wx (cur_x), Wy (cur_y) - info.descent); - DrawText (txt, 0, len); - EndOffOn - cur_x += w; -} - -value gr_draw_char (value vchr) -{ - char c = Int_val (vchr); - - draw_text (&c, 1); - return Val_unit; -} - -value gr_draw_string (value vstr) -{ - mlsize_t len = string_length (vstr); - char *str = String_val (vstr); - - draw_text (str, len); - return Val_unit; -} - -value gr_set_font (value vfontname) -{ - Str255 pfontname; - short fontnum; - - gr_check_open (); - CopyCStringToPascal (String_val (vfontname), pfontname); - GetFNum (pfontname, &fontnum); - BeginOffAlways - TextFont (fontnum); - OnAlways - TextFont (fontnum); - EndOffOnAlways - cur_font = fontnum; - return Val_unit; -} - -value gr_set_text_size (value vsz) -{ - short sz = Int_val (vsz); - - gr_check_open (); - BeginOffAlways - TextSize (sz); - OnAlways - TextSize (sz); - EndOffOnAlways - cur_size = sz; - return Val_unit; -} - -value gr_text_size (value vstr) -{ - mlsize_t len = string_length (vstr); - char *str = String_val (vstr); - value result = alloc_tuple (2); - FontInfo info; - long w, h; - - BeginOffAlways - GetFontInfo (&info); - w = TextWidth (str, 0, len); - h = info.ascent + info.descent; - EndOffAlways - Field (result, 0) = Val_long (w); - Field (result, 1) = Val_long (h); - return result; -} - -value gr_make_image (value varray) -{ - long height = Wosize_val (varray); - long width; - long x, y; - GWorldPtr w; - value result, line; - long color; - RGBColor qdcolor; - int has_transp = 0; - CGrafPtr saveport; - GDHandle savegdev; - - gr_check_open (); - if (height == 0) return alloc_image (0, 0); - width = Wosize_val (Field (varray, 0)); - for (y = 1; y < height; y++){ - if (Wosize_val (Field (varray, y)) != width){ - gr_fail("make_image: lines of different lengths", NULL); - } - } - - result = alloc_image (width, height); - w = ((struct grimage *) Bp_val (result))->data; - - LockPixels (GetGWorldPixMap (w)); - GetGWorld (&saveport, &savegdev); - SetGWorld ((CGrafPtr) w, NULL); - for (y = 0; y < height; y++){ - line = Field (varray, y); - for (x = 0; x < width; x++){ - color = Long_val (Field (line, x)); - if (color == Transparent) has_transp = 1; - qdcolor.red = ((color >> 16) & 0xFF) | ((color >> 8) & 0xFF00); - qdcolor.green = ((color >> 8) & 0xFF) | (color & 0xFF00); - qdcolor.blue = (color & 0xFF) | ((color << 8) & 0xFF00); - SetCPixel (x, y, &qdcolor); - } - } - UnlockPixels (GetGWorldPixMap (w)); - - if (has_transp){ - Rect r; - QDErr err; - - SetRect (&r, 0, 0, width, height); - err = NewGWorld (&w, 1, &r, NULL, NULL, 0); - if (err != noErr){ - SetGWorld (saveport, savegdev); - gr_fail ("Cannot allocate image (error code %d)", (void *) err); - } - LockPixels (GetGWorldPixMap (w)); - SetGWorld ((CGrafPtr) w, NULL); - EraseRect (&maxrect); - qdcolor.red = qdcolor.green = qdcolor.blue = 0; - for (y = 0; y < height; y++){ - line = Field (varray, y); - for (x = 0; x < width; x++){ - color = Long_val (Field (line, x)); - if (color != Transparent) SetCPixel (x, y, &qdcolor); - } - } - UnlockPixels (GetGWorldPixMap (w)); - ((struct grimage *) Bp_val (result))->mask = w; - } - - SetGWorld (saveport, savegdev); - - return result; -} - -value gr_dump_image (value vimage) -{ - value result = Val_unit; - struct grimage *im = (struct grimage *) Bp_val (vimage); - long width = im->width; - long height = im->height; - long x, y; - GWorldPtr wdata = im->data; - GWorldPtr wmask = im->mask; - CGrafPtr saveport; - GDHandle savegdev; - RGBColor qdcolor; - value line; - - gr_check_open (); - Begin_roots2 (vimage, result); - result = gr_alloc_int_vect (height); - for (y = 0; y < height; y++){ - value v = gr_alloc_int_vect (width); - modify (&Field (result, y), v); - } - End_roots (); - GetGWorld (&saveport, &savegdev); - LockPixels (GetGWorldPixMap (wdata)); - SetGWorld (wdata, NULL); - for (y = 0; y < height; y++){ - line = Field (result, y); - for (x = 0; x < width; x++){ - GetCPixel (x, y, &qdcolor); - Field (line, x) = Val_long (((qdcolor.red & 0xFF00) << 8) - | (qdcolor.green & 0xFF00) - | ((qdcolor.blue & 0xFF00) >> 8)); - } - } - UnlockPixels (GetGWorldPixMap (wdata)); - if (wmask != NULL){ - LockPixels (GetGWorldPixMap (wmask)); - SetGWorld (wmask, NULL); - for (y = 0; y < height; y++){ - line = Field (result, y); - for (x = 0; x < width; x++){ - if (!GetPixel (x, y)) Field (line, x) = Val_long (Transparent); - } - } - UnlockPixels (GetGWorldPixMap (wmask)); - } - SetGWorld (saveport, savegdev); - return result; -} - -value gr_draw_image (value vimage, value vx, value vy) -{ - XY; - struct grimage *im = (struct grimage *) Bp_val (vimage); - RGBColor forecolor, backcolor; - Rect srcrect, dstrect; - - SetRect (&srcrect, 0, 0, im->width, im->height); - if (im->mask != NULL){ - LockPixels (GetGWorldPixMap (im->data)); - LockPixels (GetGWorldPixMap (im->mask)); - BeginOff - SetRect (&dstrect, Bx (x), By (y+im->height), Bx (x+im->width), By (y)); - GetBackColor (&backcolor); - GetForeColor (&forecolor); - BackColor (whiteColor); - ForeColor (blackColor); - CopyMask (&((GrafPtr) im->data)->portBits, - &((GrafPtr) im->mask)->portBits, - &((GrafPtr) gworld)->portBits, - &srcrect, &srcrect, &dstrect); - RGBBackColor (&backcolor); - RGBForeColor (&forecolor); - On - SetRect (&dstrect, Wx (x), Wy (y+im->height), Wx (x+im->width), Wy (y)); - GetBackColor (&backcolor); - GetForeColor (&forecolor); - BackColor (whiteColor); - ForeColor (blackColor); - CopyMask (&((GrafPtr) im->data)->portBits, - &((GrafPtr) im->mask)->portBits, - &((GrafPtr) winGraphics)->portBits, - &srcrect, &srcrect, &dstrect); - RGBBackColor (&backcolor); - RGBForeColor (&forecolor); - EndOffOn - UnlockPixels (GetGWorldPixMap (im->data)); - UnlockPixels (GetGWorldPixMap (im->mask)); - }else{ - LockPixels (GetGWorldPixMap (im->data)); - BeginOff - SetRect (&dstrect, Bx (x), By (y+im->height), Bx (x+im->width), By (y)); - GetBackColor (&backcolor); - GetForeColor (&forecolor); - BackColor (whiteColor); - ForeColor (blackColor); - CopyBits (&((GrafPtr) im->data)->portBits, &((GrafPtr) gworld)->portBits, - &srcrect, &dstrect, srcCopy, NULL); - RGBBackColor (&backcolor); - RGBForeColor (&forecolor); - On - SetRect (&dstrect, Wx (x), Wy (y+im->height), Wx (x+im->width), Wy (y)); - GetBackColor (&backcolor); - GetForeColor (&forecolor); - BackColor (whiteColor); - ForeColor (blackColor); - CopyBits (&((GrafPtr) im->data)->portBits, - &((GrafPtr) winGraphics)->portBits, &srcrect, &dstrect, srcCopy, - NULL); - RGBBackColor (&backcolor); - RGBForeColor (&forecolor); - EndOffOn - UnlockPixels (GetGWorldPixMap (im->data)); - } - return Val_unit; -} - -value gr_create_image (value vw, value vh) -{ - return alloc_image (Long_val (vw), Long_val (vh)); -} - -value gr_blit_image (value vimage, value vx, value vy) -{ - XY; - struct grimage *im = (struct grimage *) Bp_val (vimage); - Rect srcrect, dstrect, worldrect; - CGrafPtr saveport; - GDHandle savegdev; - - SetRect (&worldrect, 0, 0, w0, h0); - SetRect (&srcrect, Bx (x), By (y+im->height), Bx (x+im->width), By (y)); - SectRect (&srcrect, &worldrect, &srcrect); - dstrect = srcrect; - OffsetRect (&dstrect, -Bx (x), -By (y+im->height)); - - LockPixels (GetGWorldPixMap (im->data)); - LockPixels (GetGWorldPixMap (gworld)); - GetGWorld (&saveport, &savegdev); - SetGWorld (im->data, NULL); - BackColor (whiteColor); - ForeColor (blackColor); - CopyBits (&((GrafPtr) gworld)->portBits, &((GrafPtr) im->data)->portBits, - &srcrect, &dstrect, srcCopy, NULL); - SetGWorld (saveport, savegdev); - UnlockPixels (GetGWorldPixMap (im->data)); - UnlockPixels (GetGWorldPixMap (gworld)); - return Val_unit; -} - -int motion_requested = 0; -short motion_oldx, motion_oldy; -/* local coord versions of motion_oldx, motion_oldy */ -static Point lastpt = {SHRT_MAX - 1, SHRT_MAX - 1}; - -#define Button_down_val 0 -#define Button_up_val 1 -#define Key_pressed_val 2 -#define Mouse_motion_val 3 -#define Poll_val 4 - -value gr_wait_event (value veventlist) -{ - int askmousedown = 0, askmouseup = 0, askkey = 0, askmotion = 0, askpoll = 0; - GrafPtr saveport; - value result; - int mouse_x, mouse_y, button, keypressed, key; - Point pt; - int i; - - gr_check_open(); - PushWindowPort (winGraphics); - - while (veventlist != Val_int (0)) { - switch (Int_val(Field (veventlist, 0))) { - case Button_down_val: askmousedown = 1; break; - case Button_up_val: askmouseup = 1; break; - case Key_pressed_val: askkey = 1; break; - case Mouse_motion_val: askmotion = 1; break; - case Poll_val: askpoll = 1; break; - default: Assert (0); - } - veventlist = Field (veventlist, 1); - } - - enter_blocking_section (); - - while (1){ - while (graphQlen > 0 && graphQ[0].when + 300 < TickCount ()){ - DequeueEvent (0); - } - for (i = graphQlen - 1; i >= 0; i--){ - int what = graphQ[i].what; - if (askpoll){ - if (what == keyDown || what == autoKey){ - GetMouse (&pt); - mouse_x = pt.h; - mouse_y = pt.v; - button = Button (); - keypressed = 1; - key = graphQ[i].message & charCodeMask; - goto gotevent; - } - }else if ( askmousedown && what == mouseDown - || askmouseup && what == mouseUp){ - mouse_x = graphQ[i].where.h; - mouse_y = graphQ[i].where.v; - button = graphQ[i].what == mouseDown; - keypressed = 0; - DequeueEvent (i); - goto gotevent; - }else if (askkey && (what == keyDown || what == autoKey)){ - mouse_x = graphQ[i].where.h; - mouse_y = graphQ[i].where.v; - button = Button (); - keypressed = 1; - key = graphQ[i].message & charCodeMask; - DequeueEvent (i); - goto gotevent; - } - } - GetMouse (&pt); - if (askpoll || askmotion && (pt.h != lastpt.h || pt.v != lastpt.v)){ - mouse_x = pt.h; - mouse_y = pt.v; - button = Button (); - keypressed = 0; - goto gotevent; - } - if (askmotion){ - motion_requested = 1; - pt = lastpt; - LocalToGlobal (&pt); - motion_oldx = pt.h; - motion_oldy = pt.v; - } - GetAndProcessEvents (askmotion ? waitMove : waitEvent, - motion_oldx, motion_oldy); - } - - gotevent: - PopPort; - leave_blocking_section (); /* acquire master lock, handle signals */ - lastpt.h = mouse_x; - lastpt.v = mouse_y; - motion_requested = 0; - - result = alloc_tuple (5); - Field (result, 0) = Val_int (Cx (mouse_x)); - Field (result, 1) = Val_int (Cy (mouse_y)); - Field (result, 2) = Val_bool (button); - Field (result, 3) = Val_bool (keypressed); - Field (result, 4) = Val_int (key); - return result; -} - -value gr_sound (value vfreq, value vdur) -{ - long freq = Long_val (vfreq); - long dur = Long_val (vdur); - long scale; - Handle h; - OSErr err; - - if (dur <= 0 || freq <= 0) return Val_unit; - if (dur > 5000) dur = 5000; - if (freq > 20000) gr_fail ("sound: frequency is too high", NULL); - - if (freq > 11025) scale = 2; - else if (freq > 5513) scale = 4; - else if (freq > 1378) scale = 8; - else if (freq > 345) scale = 32; - else if (freq > 86) scale = 128; - else scale = 512; - - h = GetResource ('snd ', 1000 + scale); - if (h == NULL){ - gr_fail ("sound: resource error (code = %ld)", (void *) (long) ResError ()); - } - err = HandToHand (&h); - if (err != noErr) gr_fail ("sound: out of memory", NULL); - *(unsigned short *)((*h)+kDurationOffset) = dur * 2; - Assert (scale * freq < 0x10000); - *(unsigned short *)((*h)+kSampleRateOffset) = scale * freq; - HLock (h); - err = SndPlay (NULL, (SndListHandle) h, false); - HUnlock (h); - if (err != noErr){ - gr_fail ("sound: cannot play sound (error code %ld)", (void *) (long) err); - } - - return Val_unit; -} - -value gr_set_window_title (value title) -{ - Str255 ptitle; - - strcpy ((char *) ptitle, String_val (title)); - c2pstr ((char *) ptitle); - SetWTitle (winGraphics, ptitle); - return Val_unit; -} diff --git a/maccaml/lcontrols.c b/maccaml/lcontrols.c deleted file mode 100644 index 2d0b3c2321..0000000000 --- a/maccaml/lcontrols.c +++ /dev/null @@ -1,246 +0,0 @@ -/* - WASTE Demo Project: - Macintosh Controls with Long Values - - Copyright © 1993-1996 Marco Piovanelli - All Rights Reserved - - C port by John C. Daub -*/ - -/*************************************************************************** - This file is not subject to the O'Caml licence. - It is a slightly modified version of "LongControls.c" from - the WASTE Demo source (version 1.2). - ***************************************************************************/ -/* $Id$ */ - -#ifndef __CONTROLS__ -#include -#endif - -#ifndef __FIXMATH__ -#include -#endif - -#ifndef __TOOLUTILS__ -#include -#endif - -#include "main.h" /* The change */ -#define BSL(A, B) (((long) (A)) << (B)) /* is here */ - - -// long control auxiliary record used for keeping long settings -// a handle to this record is stored in the reference field of the control record - -struct LCAuxRec -{ - long value; // long value - long min; // long min - long max; // long max -}; -typedef struct LCAuxRec LCAuxRec, *LCAuxPtr, **LCAuxHandle; - - -OSErr LCAttach( ControlRef control ) -{ - Handle aux; - LCAuxPtr pAux; - - /* allocate the auxiliary record that will hold long settings */ - - if ( ( aux = NewHandleClear( sizeof( LCAuxRec ) ) ) == nil ) - { - return MemError( ); - } - - /* store a handle to the auxiliary record in the contrlRfCon field */ - - SetControlReference( control, (long) aux ); - - /* copy current control settings into the auxiliary record */ - - pAux = * (LCAuxHandle) aux; - pAux->value = GetControlValue( control ); - pAux->min = GetControlMinimum( control ); - pAux->max = GetControlMaximum( control ); - - return noErr; -} - -void LCDetach( ControlRef control ) -{ - Handle aux; - - if ( ( aux = (Handle) GetControlReference( control ) ) != nil ) - { - SetControlReference( control, 0L ); - DisposeHandle( aux ); - } -} - -void LCSetValue( ControlRef control, long value ) -{ - LCAuxPtr pAux; - short controlMin, controlMax, newControlValue; - - pAux = * (LCAuxHandle) GetControlReference( control ); - - /* make sure value is in the range min...max */ - - if ( value < pAux->min ) - { - value = pAux->min; - } - if ( value > pAux->max ) - { - value = pAux->max; - } - - /* save value in auxiliary record */ - - pAux->value = value; - - /* calculate new thumb position */ - - controlMin = GetControlMinimum( control ); - controlMax = GetControlMaximum( control ); - newControlValue = controlMin + FixRound( FixMul ( FixDiv( value - pAux->min, - pAux->max - pAux->min), BSL(controlMax - controlMin, 16 ))); - - /* do nothing if the thumb position hasn't changed */ - - if ( newControlValue != GetControlValue(control) ) - { - SetControlValue( control, newControlValue ); - } -} - -void LCSetMin( ControlRef control, long min ) -{ - LCAuxPtr pAux; - - pAux = * (LCAuxHandle) GetControlReference( control ); - - /* make sure min is less than or equal to max */ - - if ( min > pAux->max ) - { - min = pAux->max; - } - - /* save min in auxiliary record */ - - pAux->min = min; - - /* set control minimum to min or SHRT_MIN, whichever is greater */ - - SetControlMinimum( control, ( min >= SHRT_MIN ) ? min : SHRT_MIN ); - - /* reset value */ - - LCSetValue( control, pAux->value ); -} - -void LCSetMax( ControlRef control, long max ) -{ - LCAuxPtr pAux; - - pAux = * (LCAuxHandle) GetControlReference( control ); - - /* make sure max is greater than or equal to min */ - - if ( max < pAux->min ) - { - max = pAux->min; - } - - /* save max in auxiliary record */ - - pAux->max = max; - - /* set control maximum to max or SHRT_MAX, whichever is less */ - - SetControlMaximum( control, ( max <= SHRT_MAX ) ? max : SHRT_MAX ); - - /* reset value */ - - LCSetValue( control, pAux->value ); -} - -/* In each of these LCGetXXX() functions, there are 2 ways listed to do things. They are - both the same thing and perform the same stuff, just one is easier to read than the - other (IMHO). I asked Marco about it and he gave me the shorter code (what's commented - in each function) and gave me this explanation: - - This version [the commented code] yields smaller and faster code - (try disassembling both versions if you wish), but some people may - find it somewhat harder to read. - - I agree with Marco that his code is better overall, but in the interest of readabilty - (since this demo is a learning tool), I left my code in and put Marco's in commented - out. Pick whichever you'd like to use. -*/ - -long LCGetValue( ControlRef control ) -{ - LCAuxPtr pAux; - - pAux = *((LCAuxHandle)GetControlReference( control )); - - return pAux->value; - -// this is Marco's code. Remember, this is a little harder to read, but overall -// yields tighter code. - -// return (* (LCAuxHandle) GetControlReference(control)) -> value; - -} - -long LCGetMin( ControlRef control ) -{ - LCAuxPtr pAux; - - pAux = *((LCAuxHandle)GetControlReference( control )); - - return pAux->min; - -// this is Marco's code. Remember, this is a little harder to read, but overall -// yields tighter code. - -// return (* (LCAuxHandle)GetControlReference(control)) -> min; - -} - -long LCGetMax( ControlRef control ) -{ - LCAuxPtr pAux; - - pAux = *((LCAuxHandle)GetControlReference( control )); - - return pAux->max; - -// this is Marco's code. Remember, this is a little harder to read, but overall -// yields tighter code. - -// return (* (LCAuxHandle)GetControlReference(control)) -> max; - -} - -void LCSynch( ControlRef control ) -{ - LCAuxPtr pAux; - short controlMin, controlMax, controlValue; - - controlMin = GetControlMinimum( control ); - controlMax = GetControlMaximum( control ); - controlValue = GetControlValue( control ); - pAux = * (LCAuxHandle) GetControlReference( control ); - - /* calculate new long value */ - - pAux->value = pAux->min + FixMul( FixRatio ( controlValue - controlMin, - controlMax - controlMin), pAux->max - pAux->min ); -} - diff --git a/maccaml/lib.c b/maccaml/lib.c deleted file mode 100644 index 2c556b4982..0000000000 --- a/maccaml/lib.c +++ /dev/null @@ -1,35 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Damien Doligez, projet Para, INRIA Rocquencourt */ -/* */ -/* Copyright 1998 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 file ../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include "main.h" - -/* These are declared in TextUtils.h but not implemented in Apple's - libraries ?! -*/ - -void CopyPascalStringToC (ConstStr255Param src, char *dst) -{ - strncpy (dst, (char *) src + 1, src[0]); - dst [src[0]] = '\000'; -} - -void CopyCStringToPascal (const char *src, Str255 dst) -{ - int l = strlen (src); - - l = l > 255 ? 255 : l; - dst [0] = l; - strncpy ((char *) dst + 1, src, l); -} diff --git a/maccaml/main.c b/maccaml/main.c deleted file mode 100644 index 6a317e8c64..0000000000 --- a/maccaml/main.c +++ /dev/null @@ -1,125 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Damien Doligez, projet Para, INRIA Rocquencourt */ -/* */ -/* Copyright 1997 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 file ../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include "main.h" - -QDGlobals qd; -int gHasDragAndDrop = 0; -int gHasPowerManager = 0; -int launch_toplevel_requested = 0; - -static OSErr Initialise (void) -{ - long gestval; - int i; - OSErr err; - - SetApplLimit (GetApplLimit () - kExtraStackSpace); - MaxApplZone (); - for (i = 0; i < kMoreMasters; i++) MoreMasters (); - InitGraf (&qd.thePort); - InitFonts (); - InitWindows (); - InitMenus (); - TEInit (); - InitDialogs (nil); - InitCursor (); - FlushEvents (everyEvent, 0); - - /* Unload the clipboard to disk if it's too big. */ - if (InfoScrap ()->scrapSize > kScrapThreshold) UnloadScrap (); - - /* Check for system 7. */ - if (Gestalt (gestaltSystemVersion, &gestval) != noErr - || gestval < kMinSystemVersion){ - InitCursor (); - StopAlert (kAlertNeedSys7, NULL); - ExitToShell (); - } - - /* Check for 32-bit color QuickDraw. */ - if (Gestalt (gestaltQuickdrawVersion, &gestval) != noErr - || gestval < gestalt32BitQD){ - InitCursor (); - StopAlert (kAlertNeed32BitQD, NULL); - ExitToShell (); - } - - /* Check for Drag Manager. */ - if (Gestalt (gestaltDragMgrAttr, &gestval) == noErr - && (gestval & (1 << gestaltDragMgrPresent)) - && (&NewDrag != NULL)){ - gHasDragAndDrop = 1; - } - - /* Check for Power Manager. */ - if (Gestalt (gestaltPowerMgrAttr, &gestval) == noErr - && (gestval & (1 << gestaltPMgrExists))){ - gHasPowerManager = 1; - } - - err = InitialiseErrors (); - if (err != noErr) goto problem; - - if (gHasDragAndDrop){ - err = InstallDragHandlers (); - if (err != noErr) goto problem; - } - - err = InitialiseEvents (); - if (err != noErr) goto problem; - - err = InitialiseMenus (); - if (err != noErr) goto problem; - - err = InitialiseScroll (); - if (err != noErr) goto problem; - - err = InitialiseWindows (); - if (err != noErr) goto problem; - - err = InitialiseModalFilter (); - if (err != noErr) goto problem; - - ReadPrefs (); - - return noErr; - - problem: return err; -} - -void FinaliseAndQuit (void) -{ - if (gHasDragAndDrop) RemoveDragHandlers (); - WritePrefs (); - ExitToShell (); -} - -int main (void) -{ - OSErr err; - - err = Initialise (); - if (err != noErr){ - FinaliseAndQuit (); - } - while (!launch_toplevel_requested){ - GetAndProcessEvents (waitEvent, 0, 0); - } - err = launch_caml_main (); /* launch bytecode interp and event loop */ - if (err != noErr) ErrorAlertGeneric (err); - FinaliseAndQuit (); - return 0; /* not reached */ -} diff --git a/maccaml/main.h b/maccaml/main.h deleted file mode 100644 index a380804e24..0000000000 --- a/maccaml/main.h +++ /dev/null @@ -1,264 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Damien Doligez, projet Para, INRIA Rocquencourt */ -/* */ -/* Copyright 1997 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 file ../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include -#include -#include -#include -#include - -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include - -#include "WASTE.h" - -#include "::byterun:rotatecursor.h" - -#include "ocamlconstants.h" - -#if DEBUG -#define Assert(cond) if (!(cond)) assert_failure (#cond, __FILE__, __LINE__) -#else -#define Assert(cond) -#endif - -/* Vertical and Horizontal */ -#define V 0 -#define H 1 - -typedef struct WStatus { - int kind; - short datarefnum; /* window's file (data fork) */ - short resrefnum; /* window's file (resource fork) or -1 */ - unsigned long basemodcount; - struct menuflags { - unsigned int save : 1; - unsigned int save_as : 1; - unsigned int revert : 1; - unsigned int page_setup : 1; - unsigned int print : 1; - unsigned int cut : 1; - unsigned int copy : 1; - unsigned int paste : 1; - unsigned int clear : 1; - unsigned int select_all : 1; - unsigned int find : 1; - unsigned int replace : 1; - } menuflags; - long line_height; - ControlHandle scrollbars [2]; - LongRect viewrect, destrect; /* view and dest for the graphics window */ - WEHandle we; -} **WStatusH; - -typedef enum { closingWindow = 0, closingApp } ClosingOption; -typedef enum { noWait = 0, waitMove, waitEvent } WaitEventOption; - -#define PREF_VERSION 2 -/* Increment PREF_VERSION at each change in struct prefs. */ -struct prefs { - long version; - int asksavetop; - Rect toppos; - Rect graphpos; - Rect clippos; - TextStyle text; - TextStyle unread; - TextStyle input; - TextStyle output; - TextStyle errors; -}; - -/* aboutbox.c */ -void OpenAboutBox (void); -void CloseAboutBox (WindowPtr w); -void DrawAboutIcon (void); - -/* appleevents.c */ -OSErr InstallAEHandlers (void); - -/* clipboard.c */ -void ClipShow (void); -void ClipClose (void); -void ClipChanged (void); - -/* drag.c */ -OSErr InstallDragHandlers (void); -OSErr RemoveDragHandlers (void); - -/* errors.c */ -void assert_failure (char *condition, char *file, int line); -void XXX (void); -void ErrorAlert (short msg1, Str255 bufmsg2, short msg3, OSErr err); -void ErrorAlertCantOpen (Str255 filename, OSErr err); -void ErrorAlertGeneric (OSErr err); -OSErr InitialiseErrors (void); - -/* events.c */ -extern int intr_requested; -extern UInt32 last_event_date; -extern UInt32 evtSleep; -void GetAndProcessEvents (WaitEventOption wait, short oldx, short oldy); -OSErr InitialiseEvents (void); -extern AEIdleUPP ProcessEventUPP; - -/* files.c */ -OSErr FileDoClose (WindowPtr w, ClosingOption close); -void FileDoGetOpen (void); -void FileNew (void); -OSErr FileOpen (FSSpec *filespec); -void FileRevert (WindowPtr w); -OSErr FileDoSave (WindowPtr w, int saveasflag); - -/* glue.c */ -OSErr launch_caml_main (void); -int AdjustRotatingCursor (void); -pascal void RotateCursor (long counter); -void FlushUnreadInput (void); - -/* graph.c */ -extern int motion_requested; -extern short motion_oldx, motion_oldy; -void GraphGotEvent (EventRecord *evt); -void GraphNewSizePos (void); -void GraphScroll (long dx, long dy); -void GraphUpdate (void); - -/* gusistuff.cp */ -void InitialiseGUSI (void); - -/* lcontrols.c */ -OSErr LCAttach( ControlRef ); -void LCDetach( ControlRef ); -void LCSetValue( ControlRef, long ); -void LCSetMin( ControlRef, long ); -void LCSetMax( ControlRef, long ); -long LCGetValue( ControlRef ); -long LCGetMin( ControlRef ); -long LCGetMax( ControlRef ); -void LCSynch( ControlRef ); - -/* main.c */ -extern int gHasDragAndDrop; -extern int gHasPowerManager; -extern int launch_toplevel_requested; -void FinaliseAndQuit (void); - -/* memory.c */ -OSErr AllocHandle (Size size, Handle *result); - -/* menus.c */ -void DoMenuChoice (long item, EventModifiers mods); -OSErr DoQuit (void); -OSErr InitialiseMenus (void); -OSErr MenuWinAdd (WindowPtr w); -void MenuWinRemove (WindowPtr w); -void UpdateMenus (void); - -/* misc.c */ -void LocalToGlobalRect (Rect *r); - -/* modalfilter.c */ -extern short modalkeys; -extern ModalFilterUPP myModalFilterUPP; -OSErr InitialiseModalFilter (void); - -/* prefs.c */ -extern struct prefs prefs; -void ReadPrefs (void); -void WritePrefs (void); - -/* print.c */ -void FilePageSetup (void); -void FilePrint (void); - -/* scroll.c */ -extern WEScrollUPP scrollFollowUPP; -void AdjustScrollBars (WindowPtr w); -OSErr InitialiseScroll (void); -int ScrollAtEnd (WindowPtr w); -void ScrollCalcText (WindowPtr w, Rect *r); -void ScrollCalcGraph (WindowPtr w, Rect *r); -void ScrollDoClick (WindowPtr w, Point where, EventModifiers mods); -void ScrollNewSize (WindowPtr w); -void ScrollToEnd (WindowPtr w); - -/* windows.c */ -extern WindowPtr winToplevel; -extern WindowPtr winGraphics; -extern long wintopfrontier; -OSErr InitialiseWindows (void); -void WinActivateDeactivate (int activate, WindowPtr w); -void WinAdvanceTopFrontier (long length); -OSErr WinAllocStatus (WindowPtr w); -void WinCloseGraphics (void); -void WinCloseToplevel (void); -void WinDoContentClick (EventRecord *e, WindowPtr w); -OSErr WinDoClose (ClosingOption closing, WindowPtr w); -void WinDoDrag (Point where, WindowPtr w); -void WinDoGrow (Point where, WindowPtr w); -void WinDoIdle (WindowPtr w); -void WinDoKey (WindowPtr w, short chr, EventRecord *e); -void WinDoZoom (WindowPtr w, short partCode); -WStatusH WinGetStatus (WindowPtr w); -WEHandle WinGetWE (WindowPtr w); -int WinGetKind (WindowPtr w); -WindowPtr WinOpenDocument (StringPtr title); -OSErr WinOpenGraphics (long width, long height); -OSErr WinOpenToplevel (void); -void WinClipboardStdState (Rect *r); -void WinGraphicsStdState (Rect *r); -void WinToplevelStdState (Rect *r); -void WinUpdate (WindowPtr w); -void WinUpdateStatus (WindowPtr w); - -/* useful macros */ - -/* PushPort, PushWindowPort, and PopPort - assume that there is a local variable [saveport] -*/ -#define PushPort(p) do{ GetPort (&saveport); SetPort (p); }while(0) -#define PushWindowPort(w) \ - do{ GetPort (&saveport); SetPortWindowPort (w); }while(0) -#define PopPort do{ SetPort (saveport); }while(0) diff --git a/maccaml/mcmemory.c b/maccaml/mcmemory.c deleted file mode 100644 index 218b99f81a..0000000000 --- a/maccaml/mcmemory.c +++ /dev/null @@ -1,31 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Damien Doligez, projet Para, INRIA Rocquencourt */ -/* */ -/* Copyright 1998 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 file ../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include "main.h" - -/* Allocate from application memory or from Multifinder memory; - always leave at least kMinimumMemory free in application memory. -*/ -OSErr AllocHandle (Size size, Handle *result) -{ - OSErr err; - - if (FreeMem () >= size + kMinimumMemory){ - *result = NewHandle (size); - err = MemError (); - } - if (err != noErr) *result = TempNewHandle (size, &err); - return err; -} diff --git a/maccaml/mcmisc.c b/maccaml/mcmisc.c deleted file mode 100644 index 89adfe684e..0000000000 --- a/maccaml/mcmisc.c +++ /dev/null @@ -1,24 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Damien Doligez, projet Para, INRIA Rocquencourt */ -/* */ -/* Copyright 1998 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 file ../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include "main.h" - -void LocalToGlobalRect (Rect *r) -{ - Point *p = (Point *) r; - - LocalToGlobal (&p[0]); - LocalToGlobal (&p[1]); -} diff --git a/maccaml/menus.c b/maccaml/menus.c deleted file mode 100644 index 81751824a0..0000000000 --- a/maccaml/menus.c +++ /dev/null @@ -1,339 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Damien Doligez, projet Para, INRIA Rocquencourt */ -/* */ -/* Copyright 1998 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 file ../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include "main.h" - -static void DoAppleChoice (short item, EventModifiers mods) -{ -#pragma unused (mods) - if (item == kItemAbout){ - OpenAboutBox (); - }else{ - Str255 deskAccName; - GetMenuItemText (GetMenuHandle (kMenuApple), item, deskAccName); - OpenDeskAcc (deskAccName); - } -} - -OSErr DoQuit () -{ - WindowPtr w; - OSErr err; - - while (1){ - w = FrontWindow (); - while (1){ - if (w == NULL) goto done; - if (GetWindowGoAwayFlag (w) && w != winGraphics) break; - w = GetNextWindow (w); - } - err = WinDoClose (closingApp, w); - if (err != noErr) return err; - } - done: - if (winGraphics != NULL) WinCloseGraphics (); - WinCloseToplevel (); - rotatecursor_final (); - FinaliseAndQuit (); - return noErr; -} - -static void DoFileChoice (short item, EventModifiers mods) -{ -#pragma unused (mods) - WindowPtr w = FrontWindow (); - - switch (item){ - case kItemNew: - FileNew (); - break; - case kItemOpen: - FileDoGetOpen (); - break; - case kItemClose: - WinDoClose (closingWindow, w); - break; - case kItemSave: - FileDoSave (w, 0); - break; - case kItemSaveAs: - FileDoSave (w, 1); - break; - case kItemRevert: - FileRevert (w); - break; - case kItemPageSetup: - FilePageSetup (); - break; - case kItemPrint: - FilePrint (); - break; - case kItemQuit: - DoQuit (); - break; - default: Assert (0); - } -} - -static void DoEditChoice (short item, EventModifiers mods) -{ -#pragma unused (mods) - WindowPtr w = FrontWindow (); - WEReference we = WinGetWE (w); - - switch (item){ - case kItemUndo: - WEUndo (we); - break; - case kItemCut: - WECut (we); - ClipChanged (); - break; - case kItemCopy: - WECopy (we); - ClipChanged (); - break; - case kItemPaste: - if (w == winToplevel){ - long selstart, selend; - WEGetSelection (&selstart, &selend, we); - if (selstart < wintopfrontier){ - selstart = selend = WEGetTextLength (we); - WESetSelection (selstart, selend, we); - WEFeatureFlag (weFReadOnly, weBitClear, we); - } - if (selstart == wintopfrontier && selend == selstart){ - WESetStyle (weDoFont + weDoSize + weDoColor + weDoFace+weDoReplaceFace, - &prefs.unread, we); - } - WEFeatureFlag (weFMonoStyled, weBitSet, we); - WEPaste (we); - WEFeatureFlag (weFMonoStyled, weBitClear, we); - }else{ - WEPaste (we); - } - break; - case kItemClear: - WEDelete (we); - break; - case kItemSelectAll: - WESetSelection (0, LONG_MAX, we); - break; - case kItemShowClipboard: - ClipShow (); - break; - case kItemFind: - XXX (); - break; - case kItemReplace: - XXX (); - break; - case kItemPreferences: - XXX (); - break; - default: Assert (0); - } -} - -static WindowPtr **winTable; /* a handle */ -static long winTableLen = 0; /* number of entries in the table */ - -static void DoWindowsChoice (short item, EventModifiers mods) -{ -#pragma unused (mods) - switch (item){ - case 1: - Assert (winToplevel != NULL); - SelectWindow (winToplevel); - break; - case 2: - Assert (winGraphics != NULL); - ShowWindow (winGraphics); - SelectWindow (winGraphics); - break; - case 3: - Assert (0); - default: - Assert (item - 4 >= 0 && item - 4 < winTableLen); - SelectWindow ((*winTable)[item - 4]); - break; - } -} - -void DoMenuChoice (long choice, EventModifiers mods) -{ - short menu = HiWord (choice); - short item = LoWord (choice); - - switch (menu){ - case 0: break; - case kMenuApple: - DoAppleChoice (item, mods); - HiliteMenu (0); - break; - case kMenuFile: - DoFileChoice (item, mods); - HiliteMenu (0); - break; - case kMenuEdit: - DoEditChoice (item, mods); - HiliteMenu (0); - break; - case kMenuWindows: - DoWindowsChoice (item, mods); - HiliteMenu (0); - break; - default: Assert (0); - } -} - -OSErr InitialiseMenus (void) -{ - OSErr err; - Size s = 10; - - err = AllocHandle (s * sizeof (WindowPtr), (Handle *) &winTable); - if (err != noErr) return err; - - SetMenuBar (GetNewMBar (kMenuBar)); - AppendResMenu (GetMenuHandle (kMenuApple), 'DRVR'); - DrawMenuBar (); - return 0; -} - -static void EnableDisableItem (MenuHandle menu, short item, int enable) -{ - if (enable){ - EnableItem (menu, item); - }else{ - DisableItem (menu, item); - } -} - -/* Add w to the windows menu. */ -OSErr MenuWinAdd (WindowPtr w) -{ - MenuHandle m; - Str255 title; - Size s = GetHandleSize ((Handle) winTable) / sizeof (WindowPtr); - - if (s <= winTableLen){ - OSErr err; - SetHandleSize ((Handle) winTable, (s + 10) * sizeof (WindowPtr)); - err = MemError (); if (err != noErr) return err; - } - (*winTable)[winTableLen] = w; - ++ winTableLen; - - m = GetMenuHandle (kMenuWindows); - AppendMenu (m, "\px"); - GetWTitle (w, title); - SetMenuItemText (m, (winTableLen-1) + 4, title); - - return noErr; -} - -/* Remove w from the windows menu; do nothing if w is not there. */ -void MenuWinRemove (WindowPtr w) -{ - long i; - MenuHandle m; - - i = 0; - while (1){ - if (i >= winTableLen) return; - if ((*winTable)[i] == w) break; - ++ i; - } - Assert (i < winTableLen); - m = GetMenuHandle (kMenuWindows); - DeleteMenuItem (m, kItemDocuments + i); - for (++i; i < winTableLen; i++) (*winTable)[i-1] = (*winTable)[i]; - -- winTableLen; -} - -static void MenuWinUpdate (void) -{ - long i; - MenuHandle m = GetMenuHandle (kMenuWindows); - WindowPtr w = FrontWindow (); - - SetItemMark (m, kItemToplevel, w == winToplevel ? diamondMark : noMark); - SetItemMark (m, kItemGraphics, w == winGraphics ? diamondMark : noMark); - for (i = 0; i < winTableLen; i++){ - SetItemMark (m, kItemDocuments + i, - w == (*winTable)[i] ? diamondMark : noMark); - } -} - -void UpdateMenus (void) -{ - WindowPtr w; - WStatusH st; - WEHandle we; - MenuHandle m; - Str255 text; - struct menuflags flags = {0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0}; - - w = FrontWindow (); - st = WinGetStatus (w); - we = WinGetWE (w); - - WinUpdateStatus (w); - - if (st != NULL) flags = (*st)->menuflags; - - m = GetMenuHandle (kMenuFile); - /* New is always enabled. */ - /* Open is always enabled. */ - EnableDisableItem (m, kItemClose, w != NULL && GetWindowGoAwayFlag (w)); - EnableDisableItem (m, kItemSave, flags.save); - EnableDisableItem (m, kItemSaveAs, flags.save_as); - EnableDisableItem (m, kItemRevert, flags.revert); - EnableDisableItem (m, kItemPageSetup, flags.page_setup); - EnableDisableItem (m, kItemPrint, flags.print); - /* Quit is always enabled. */ - - m = GetMenuHandle (kMenuEdit); - DisableItem (m, kItemUndo); - GetIndString (text, kUndoStrings, 1); - SetMenuItemText (m, kItemUndo, text); - if (we != NULL){ - Boolean temp; - WEActionKind ak; - - Assert (st != NULL); - - ak = WEGetUndoInfo (&temp, we); - if (ak != weAKNone){ - GetIndString (text, kUndoStrings, 2*ak + temp); - SetMenuItemText (m, kItemUndo, text); - EnableItem (m, kItemUndo); - } - } - EnableDisableItem (m, kItemCut, flags.cut); - EnableDisableItem (m, kItemCopy, flags.copy); - EnableDisableItem (m, kItemPaste, flags.paste); - EnableDisableItem (m, kItemClear, flags.clear); - EnableDisableItem (m, kItemSelectAll, flags.select_all); - /* Show Clipboard is always enabled. */ - EnableDisableItem (m, kItemFind, flags.find); - EnableDisableItem (m, kItemReplace, flags.replace); - /* PreferencesÉ is always enabled. */ - - MenuWinUpdate (); - m = GetMenuHandle (kMenuWindows); - EnableDisableItem (m, kItemGraphics, winGraphics != NULL); -} diff --git a/maccaml/modalfilter.c b/maccaml/modalfilter.c deleted file mode 100644 index 741d120503..0000000000 --- a/maccaml/modalfilter.c +++ /dev/null @@ -1,83 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Damien Doligez, projet Para, INRIA Rocquencourt */ -/* */ -/* Copyright 1998 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 file ../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include "main.h" - -/* See ocaml.r before modifying this. */ -typedef struct { - char mod; - char chr; - char item; - char filler; -} KeyEquRecord, **KeyEquHandle; - -short modalkeys; -ModalFilterUPP myModalFilterUPP; - -/* Before calling ModalDialog with myModalFilter, set the dialog - window's refcon to the resource number of the key equivalence - list for the dialog. -*/ -static pascal Boolean myModalFilter (DialogPtr d, EventRecord *evt, - DialogItemIndex *item) -{ - Boolean result = false; - char key; - int cmdflag; - KeyEquHandle equivlist; - int equivcount, i; - short itemtype; - Handle itemhandle; - Rect itemrect; - unsigned long ticks; - - switch (evt->what){ - case updateEvt: - if ((WindowPtr) evt->message != d) WinUpdate ((WindowPtr) evt->message); - break; - case activateEvt: - if ((WindowPtr) evt->message != d){ - WinActivateDeactivate (evt->modifiers & activeFlag, - (WindowPtr) evt->message); - } - break; - case keyDown: case autoKey: - key = evt->message & charCodeMask; - cmdflag = !!(evt->modifiers & cmdKey); - equivlist = (KeyEquHandle) GetResource ('Kequ', modalkeys); - if (equivlist != NULL){ - equivcount = GetHandleSize ((Handle) equivlist) / sizeof (KeyEquRecord); - for (i = 0; i < equivcount; i++){ - if ((*equivlist)[i].chr == key && (!(*equivlist)[i].mod || cmdflag)){ - result = true; - *item = (*equivlist)[i].item; - GetDialogItem (d, *item, &itemtype, &itemhandle, &itemrect); - HiliteControl ((ControlHandle) itemhandle, kControlButtonPart); - Delay (kVisualDelay, &ticks); - HiliteControl ((ControlHandle) itemhandle, 0); - } - } - } - break; - default: break; - } - return result; -} - -OSErr InitialiseModalFilter (void) -{ - myModalFilterUPP = NewModalFilterProc (myModalFilter); - return noErr; -} diff --git a/maccaml/ocaml.r b/maccaml/ocaml.r deleted file mode 100644 index ea807fa536..0000000000 --- a/maccaml/ocaml.r +++ /dev/null @@ -1,479 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Damien Doligez, projet Para, INRIA Rocquencourt */ -/* */ -/* Copyright 1998 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 file ../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include "Types.r" - -#include "ocamlconstants.h" - -resource 'vers' (1) { -#define d development -#define a alpha -#define b beta - MAJORVNUM, MINORVNUM, STAGE, DEVVNUM, - 0, - VERSIONSTR, - "Objective Caml version " VERSIONSTR "\n" - COPYRIGHTSTR -#undef d -#undef a -#undef b -}; - -data 'Line' (1000) { /* kCommandLineTemplate */ - "%a\000" -}; - -data 'Line' (1001) { /* kEnvironmentTemplate */ - "TempFolder=%t\000" - "CAMLLIB=%dstdlib:\000" -}; - -data 'TEXT' (1000, purgeable) { /* kAboutText1 */ - "Objective Caml version " VERSIONSTR "\n" - COPYRIGHTSTR "\n" - "\n" - "Xavier Leroy, Jer™me Vouillon, Jacques Garrigue, Damien Doligez, et al.\n" - "\n" - "\n" -}; - - -/***************************************************************** - derez -m 60 caml-icons.rsrc "{rincludes}types.r" ¶ - "{rincludes}finder.r" "{rincludes}icons.r" >> ocaml.r -*/ - -resource 'icl4' (1000) { - $"0000 0000 000F FFFF F000 0000 0000 0000 0000 0000 00FF FFFF" - $"FFF0 0000 0000 0000 0000 0000 FFFF FFFF FFFF 0000 0000 0000" - $"FFFF FF0F FFFF BBBB BBBF F000 00FF FFF0 FAAA AAFF FFBB BBBB" - $"BBBB BFFF FFFF FFF0 FAAA AAAF FFFF FFFF FFFF FFFF FFFF FFF0" - $"FAAA AAAA FFFD DDFF FFFF FFFF FFFF FF00 FFAA AAAA AFFF CCFF" - $"FFFF FFFF FFFF FF00 0FFA AAAA AAFF FCFF FFFF FBBF FFFF F000" - $"00FF FAAA AAAF FFFF FFFF BBBB FFFF 0000 0000 FFAA AAAA FFFF" - $"FFFF BBBB BBFF 0000 0000 0FFA AAAA AFFF FFFA ABBB BBBF F000" - $"0000 0FFA AAAA ABBB BBFF AABB BBBB FF00 0000 FFFA AAAA BBBB" - $"BBBF FAAB BBBB BFF0 0000 FFFA AAAB BBBB BBBB FFAA BBBB BBFF" - $"0000 FFFA AAAB BBBB FFBB BFFA ABBB BBFF 0000 FFFA AAAB BBBB" - $"FFBB BBFF AABA BBFF 0000 FFFA AAAB BBBB FFBB BBBF FAAA AAFF" - $"0000 FFFA AAAB BBBB FFBB BBBB FFAA AAFF 0000 FFFA AAAA BBBB" - $"FFBB BBBB BFFA AFFF 0000 FFFF AAAA ABBB FFFB BBBB BBFF AFBF" - $"0000 0FFF AAAA AABB FFFB BBBB BBBF FFBF 0000 00FF AAAA AAA1" - $"81FB BBBB BBBF FBBF 0000 000F AAAA A81A AFFF BBBB BBBF FBBF" - $"0000 000F AAA1 8AAA AFFF FBBB BBBF FBBF 0000 00FF A81A 1AAA" - $"AAAF FFBB BBBF FBBF 0000 00FA 11AA 8AAA AAAA FFFB BBFF FBF0" - $"0000 0FF8 A8AA AAAA AAAA AFFF BFFF FBF0 0000 0F8A A8AA AAAA" - $"AAAA AAFF FFFF FF00 0000 FFAA AAAA AAAA AAAA AFFF FFF0 0000" - $"0000 FAAA AAAA AAAA AAAA FF00 0000 0000 0000 FFFF FFFF FFFF" - $"FFFF F0" -}; - -resource 'icl4' (1001) { - $"0FFF FFFF FFFF FFFF FFFF 0000 0000 0000 0F00 0000 0000 0000" - $"000F F000 0000 0000 0F00 0000 0000 0000 000F CF00 0000 0000" - $"0F00 0000 0FFF FF00 000F 0CF0 0000 0000 0F00 FFFF FFBB BFFF" - $"FFFF 00CF 0000 0000 0F00 FAAF FFFF FFFF FFFF 0CCC F000 0000" - $"0F00 FAAA FFFF FFFF FFFF FFFF FF00 0000 0F00 0FFA AFFF FFBB" - $"FF00 DDDD DF00 0000 0F00 00FF AAFF FFAB BF00 CCCC CF00 0000" - $"0F00 00FF AAAB BFAA BBF0 0000 CF00 0000 0F00 00FF AABB BBFA" - $"ABBF 0000 CF00 0000 0F00 00FF AABB FBBF AAAF 0000 CF00 0000" - $"0F00 00FF AABB FBBB FFFF 0000 CF00 0000 0F00 00FF AAAB FBBB" - $"BFBF 0000 CF00 0000 0F00 000F AA81 FBBB BFBF 0000 CF00 0000" - $"0F00 000F 818A AFBB BFBF 0000 CF00 0000 0F00 00FF 8A8A AAFB" - $"BFF0 0000 CF00 0000 0F00 00F8 AAAA AAFF FF00 0000 CF00 0000" - $"0F00 00FF FFFF FFF0 0000 0000 CF00 0000 0F00 0000 0000 0000" - $"0000 0000 CF00 0000 0F00 0000 0000 0000 0000 0000 CF00 0000" - $"0F00 0000 0000 0000 0000 0000 CF00 0000 0F00 0000 0000 0000" - $"0000 0000 CF00 0000 0F00 FF00 FF00 0000 0000 0000 CF00 0000" - $"0F00 FF00 FF00 0000 0000 0000 CF00 0000 0F00 0000 0000 0000" - $"0000 0000 CF00 0000 0F00 FF00 FF00 0000 0000 0000 CFE0 0000" - $"0F00 FF00 FF00 0000 0000 0000 CFEE E000 0F00 0F00 0F00 0000" - $"0000 0000 CFEE EEE0 0F00 F000 F000 0000 0000 0000 CFEE EEE0" - $"0F00 0000 0000 0000 0000 0000 CFEE E000 0FFF FFFF FFFF FFFF" - $"FFFF FFFF FFE0" -}; - -resource 'icl4' (1002) { - $"FFFF FFFF FFFF FFFF FFFF FFFF F000 0000 F000 0000 0000 0000" - $"0000 0000 F000 0000 F00F F00F F000 0000 0000 0000 FFF0 0000" - $"F00F F00F F000 0000 0000 0000 FDF0 0000 F000 0000 0000 0000" - $"0000 0000 FDF0 0000 F00F F00F F000 0000 0000 0000 FDF0 0000" - $"F00F F00F F000 0000 0000 0000 FDF0 0000 F000 F000 F000 0000" - $"0000 0000 FDF0 0000 F00F 000F 0000 0000 0000 0000 FDF0 0000" - $"F000 0000 0000 0000 0000 0000 FDF0 0000 F000 0000 0000 0000" - $"0000 0000 FDF0 0000 F000 0000 0000 0000 0000 0000 FDF0 0000" - $"F000 0000 FFFF F000 0000 0000 FDF0 0000 F00F FFFF FBBB FFFF" - $"FFF0 0000 FDF0 0000 F00F AAFF FFFF FFFF FFF0 0000 FDF0 0000" - $"F00F AAAF FFFF FFFF FF00 0000 FDF0 0000 F000 FFAA FFFF FBBF" - $"F000 0000 FDF0 0000 F000 0FFA AFFF FABB F000 0000 FDF0 0000" - $"F000 0FFA AABB FAAB BF00 0000 FDF0 0000 F000 0FFA ABBB BFAA" - $"BBF0 0000 FDF0 0000 F000 0FFA ABBF BBFA AAF0 0000 FDF0 0000" - $"F000 0FFA ABBF BBBF FFF0 0000 FDF0 0000 F000 0FFA AABF BBBB" - $"FBF0 0000 FDF0 0000 F000 00FA A81F BBBB FBFF FFFF FDF0 0000" - $"F000 00F8 18AA FBBB FBFC CCCF DCF0 0000 F000 0FF8 A8AA AFBB" - $"FFFC CCFD CCF0 0000 F000 0F8A AAAA AFFF F0FC CFDC CCFE 0000" - $"F000 0FFF FFFF FF00 00FC FDCC CCFE EE00 F000 0000 0000 0000" - $"00FF DCCC CCFE EEEE FFFF FFFF FFFF FFFF FFFD CCCC CCFE EEEE" - $"00FD DDDD DDDD DDDD DDDC CCCC CCFE EE00 00FF FFFF FFFF FFFF" - $"FFFF FFFF FFFE" -}; - -resource 'icl8' (1000) { - $"0000 0000 0000 0000 0000 00FF FFFF FFFF FF00 0000 0000 0000" - $"0000 0000 0000 0000 0000 0000 0000 0000 0000 FFFF FFFF FFFF" - $"FFFF FF00 0000 0000 0000 0000 0000 0000 0000 0000 0000 0000" - $"FFFF FFFF FFFF FFFF FFFF FFFF 0000 0000 0000 0000 0000 0000" - $"FFFF FFFF FFFF 00FF FFFF FFFF 0808 0808 0808 08FF FF00 0000" - $"0000 FFFF FFFF FF00 FF33 3333 3333 FFFF FFFF 0808 0808 0808" - $"0808 0808 08FF FFFF FFFF FFFF FFFF FF00 FF33 3333 3333 33FF" - $"FFFF FFFF FFFF FFFF FFFF FFFF FFFF FFFF FFFF FFFF FFFF FF00" - $"FF33 3333 3333 3333 FFFF FFF9 F9F9 FFFF FFFF FFFF FFFF FFFF" - $"FFFF FFFF FFFF 0000 FFFF 3333 3333 3333 33FF FFFF F6F6 FFFF" - $"FFFF FFFF FFFF FFFF FFFF FFFF FFFF 0000 00FF FF33 3333 3333" - $"3333 FFFF FFF6 FFFF FFFF FFFF FF08 08FF FFFF FFFF FF00 0000" - $"0000 FFFF FF33 3333 3333 33FF FFFF FFFF FFFF FFFF 0808 0808" - $"FFFF FFFF 0000 0000 0000 0000 FFFF 3333 3333 3333 FFFF FFFF" - $"FFFF FFFF 0808 0808 0808 FFFF 0000 0000 0000 0000 00FF FF33" - $"3333 3333 33FF FFFF FFFF FF33 3308 0808 0808 08FF FF00 0000" - $"0000 0000 00FF FF33 3333 3333 3308 0808 0808 FFFF 3333 0808" - $"0808 0808 FFFF 0000 0000 0000 FFFF FF33 3333 3333 0808 0808" - $"0808 08FF FF33 3308 0808 0808 08FF FF00 0000 0000 FFFF FF33" - $"3333 3308 0808 0808 0808 0808 FFFF 3333 0808 0808 0808 FFFF" - $"0000 0000 FFFF FF33 3333 3308 0808 0808 FFFF 0808 08FF FF33" - $"3308 0808 0808 FFFF 0000 0000 FFFF FF33 3333 3308 0808 0808" - $"FFFF 0808 0808 FFFF 3333 0833 0808 FFFF 0000 0000 FFFF FF33" - $"3333 3308 0808 0808 FFFF 0808 0808 08FF FF33 3333 3333 FFFF" - $"0000 0000 FFFF FF33 3333 3308 0808 0808 FFFF 0808 0808 0808" - $"FFFF 3333 3333 FFFF 0000 0000 FFFF FF33 3333 3333 0808 0808" - $"FFFF 0808 0808 0808 08FF FF33 33FF FFFF 0000 0000 FFFF FFFF" - $"3333 3333 3308 0808 FFFF FF08 0808 0808 0808 FFFF 33FF 08FF" - $"0000 0000 00FF FFFF 3333 3333 3333 0808 FFFF FF08 0808 0808" - $"0808 08FF FFFF 08FF 0000 0000 0000 FFFF 3333 3333 3333 3305" - $"E305 FF08 0808 0808 0808 08FF FF08 08FF 0000 0000 0000 00FF" - $"3333 3333 33E3 0533 33FF FFFF 0808 0808 0808 08FF FF08 08FF" - $"0000 0000 0000 00FF 3333 3305 E333 3333 33FF FFFF FF08 0808" - $"0808 08FF FF08 08FF 0000 0000 0000 FFFF 33E3 0533 0533 3333" - $"3333 33FF FFFF 0808 0808 08FF FF08 08FF 0000 0000 0000 FF33" - $"0505 3333 E333 3333 3333 3333 FFFF FF08 0808 FFFF FF08 FF00" - $"0000 0000 00FF FFE3 33E3 3333 3333 3333 3333 3333 33FF FFFF" - $"08FF FFFF FF08 FF00 0000 0000 00FF E333 33E3 3333 3333 3333" - $"3333 3333 3333 FFFF FFFF FFFF FFFF 0000 0000 0000 FFFF 3333" - $"3333 3333 3333 3333 3333 3333 33FF FFFF FFFF FF00 0000 0000" - $"0000 0000 FF33 3333 3333 3333 3333 3333 3333 3333 FFFF 0000" - $"0000 0000 0000 0000 0000 0000 FFFF FFFF FFFF FFFF FFFF FFFF" - $"FFFF FFFF FF" -}; - -resource 'icl8' (1001) { - $"00FF FFFF FFFF FFFF FFFF FFFF FFFF FFFF FFFF FFFF 0000 0000" - $"0000 0000 0000 0000 00FF F5F5 F5F5 F5F5 F5F5 F5F5 F5F5 F5F5" - $"F5F5 F5FF FF00 0000 0000 0000 0000 0000 00FF F5F5 F5F5 F5F5" - $"F5F5 F5F5 F5F5 F5F5 F5F5 F5FF F8FF 0000 0000 0000 0000 0000" - $"00FF F5F5 F5F5 F5F5 F5FF FFFF FFFF F5F5 F5F5 F5FF 00F8 FF00" - $"0000 0000 0000 0000 00FF F5F5 FFFF FFFF FFFF 0808 08FF FFFF" - $"FFFF FFFF 0000 F8FF 0000 0000 0000 0000 00FF F5F5 FF33 33FF" - $"FFFF FFFF FFFF FFFF FFFF FFFF F5F6 F6F8 FF00 0000 0000 0000" - $"00FF F5F5 FF33 3333 FFFF FFFF FFFF FFFF FFFF FFFF FFFF FFFF" - $"FFFF 0000 0000 0000 00FF F5F5 F5FF FF33 33FF FFFF FFFF 0808" - $"FFFF F5F5 F9F9 F9F9 F9FF 0000 0000 0000 00FF F5F5 F5F5 FFFF" - $"3333 FFFF FFFF 3308 08FF F5F5 F7F7 F7F7 F7FF 0000 0000 0000" - $"00FF F5F5 F5F5 FFFF 3333 3308 08FF 3333 0808 FFF5 F5F5 F5F5" - $"F7FF 0000 0000 0000 00FF F5F5 F5F5 FFFF 3333 0808 0808 FF33" - $"3308 08FF F5F5 F5F5 F7FF 0000 0000 0000 00FF F5F5 F5F5 FFFF" - $"3333 0808 FF08 08FF 3333 33FF F5F5 F5F5 F7FF 0000 0000 0000" - $"00FF F5F5 F5F5 FFFF 3333 0808 FF08 0808 FFFF FFFF F5F5 F5F5" - $"F7FF 0000 0000 0000 00FF F5F5 F5F5 FFFF 3333 3308 FF08 0808" - $"08FF 08FF F5F5 F5F5 F7FF 0000 0000 0000 00FF F5F5 F5F5 F5FF" - $"3333 E305 FF08 0808 08FF 08FF F5F5 F5F5 F7FF 0000 0000 0000" - $"00FF F5F5 F5F5 F5FF E305 E333 33FF 0808 08FF 08FF F5F5 F5F5" - $"F7FF 0000 0000 0000 00FF F5F5 F5F5 FFFF E333 E333 3333 FF08" - $"08FF FFF5 F5F5 F5F5 F7FF 0000 0000 0000 00FF F5F5 F5F5 FFE3" - $"3333 3333 3333 FFFF FFFF F5F5 F5F5 F5F5 F7FF 0000 0000 0000" - $"00FF F5F5 F5F5 FFFF FFFF FFFF FFFF FFF5 F5F5 F5F5 F5F5 F5F5" - $"F7FF 0000 0000 0000 00FF F5F5 F5F5 F5F5 F5F5 F5F5 F5F5 F5F5" - $"F5F5 F5F5 F5F5 F5F5 F7FF 0000 0000 0000 00FF F5F5 F5F5 F5F5" - $"F5F5 F5F5 F5F5 F5F5 F5F5 F5F5 F5F5 F5F5 F7FF 0000 0000 0000" - $"00FF F5F5 F5F5 F5F5 F5F5 F5F5 F5F5 F5F5 F5F5 F5F5 F5F5 F5F5" - $"F7FF 0000 0000 0000 00FF F5F5 F5F5 F5F5 F5F5 F5F5 F5F5 F5F5" - $"F5F5 F5F5 F5F5 F5F5 F7FF 0000 0000 0000 00FF F5F5 FFFF F5F5" - $"FFFF F5F5 F5F5 F5F5 F5F5 F5F5 F5F5 F5F5 F7FF 0000 0000 0000" - $"00FF F5F5 FFFF F5F5 FFFF F5F5 F5F5 F5F5 F5F5 F5F5 F5F5 F5F5" - $"F7FF 0000 0000 0000 00FF F5F5 F5F5 F5F5 F5F5 F5F5 F5F5 F5F5" - $"F5F5 F5F5 F5F5 F5F5 F7FF 0000 0000 0000 00FF F5F5 FFFF F5F5" - $"FFFF F5F5 F5F5 F5F5 F5F5 F5F5 F5F5 F5F5 F7FF FC00 0000 0000" - $"00FF F5F5 FFFF F5F5 FFFF F5F5 F5F5 F5F5 F5F5 F5F5 F5F5 F5F5" - $"F7FF FCFC FC00 0000 00FF F5F5 F5FF F5F5 F5FF F5F5 F5F5 F5F5" - $"F5F5 F5F5 F5F5 F5F5 F7FF FCFC FCFC FC00 00FF F5F5 FFF5 F5F5" - $"FFF5 F5F5 F5F5 F5F5 F5F5 F5F5 F5F5 F5F5 F7FF FCFC FCFC FC00" - $"00FF F5F5 F5F5 F5F5 F5F5 F5F5 F5F5 F5F5 F5F5 F5F5 F5F5 F5F5" - $"F7FF FCFC FC00 0000 00FF FFFF FFFF FFFF FFFF FFFF FFFF FFFF" - $"FFFF FFFF FFFF FFFF FFFF FC" -}; - -resource 'icl8' (1002) { - $"FFFF FFFF FFFF FFFF FFFF FFFF FFFF FFFF FFFF FFFF FFFF FFFF" - $"FF00 0000 0000 0000 FFF5 F5F5 F5F5 F5F5 F5F5 F5F5 F5F5 F5F5" - $"F5F5 F5F5 F5F5 F5F5 FF00 0000 0000 0000 FFF5 F5FF FFF5 F5FF" - $"FFF5 F5F5 F5F5 F5F5 F5F5 F5F5 F5F5 F5F5 FFFF FF00 0000 0000" - $"FFF5 F5FF FFF5 F5FF FFF5 F5F5 F5F5 F5F5 F5F5 F5F5 F5F5 F5F5" - $"FFF9 FF00 0000 0000 FFF5 F5F5 F5F5 F5F5 F5F5 F5F5 F5F5 F5F5" - $"F5F5 F5F5 F5F5 F5F5 FFF9 FF00 0000 0000 FFF5 F5FF FFF5 F5FF" - $"FFF5 F5F5 F5F5 F5F5 F5F5 F5F5 F5F5 F5F5 FFF9 FF00 0000 0000" - $"FFF5 F5FF FFF5 F5FF FFF5 F5F5 F5F5 F5F5 F5F5 F5F5 F5F5 F5F5" - $"FFF9 FF00 0000 0000 FFF5 F5F5 FFF5 F5F5 FFF5 F5F5 F5F5 F5F5" - $"F5F5 F5F5 F5F5 F5F5 FFF9 FF00 0000 0000 FFF5 F5FF F5F5 F5FF" - $"F5F5 F5F5 F5F5 F5F5 F5F5 F5F5 F5F5 F5F5 FFF9 FF00 0000 0000" - $"FFF5 F5F5 F5F5 F5F5 F5F5 F5F5 F5F5 F5F5 F5F5 F5F5 F5F5 F5F5" - $"FFF9 FF00 0000 0000 FFF5 F5F5 F5F5 F5F5 F5F5 F5F5 F5F5 F5F5" - $"F5F5 F5F5 F5F5 F5F5 FFF9 FF00 0000 0000 FFF5 F5F5 F5F5 F5F5" - $"F5F5 F5F5 F5F5 F5F5 F5F5 F5F5 F5F5 F5F5 FFF9 FF00 0000 0000" - $"FFF5 F5F5 F5F5 F5F5 FFFF FFFF FFF5 F5F5 F5F5 F5F5 F5F5 F5F5" - $"FFF9 FF00 0000 0000 FFF5 F5FF FFFF FFFF FF08 0808 FFFF FFFF" - $"FFFF FFF5 F5F5 F5F5 FFF9 FF00 0000 0000 FFF5 F5FF 3333 FFFF" - $"FFFF FFFF FFFF FFFF FFFF FFF5 F5F5 F5F5 FFF9 FF00 0000 0000" - $"FFF5 F5FF 3333 33FF FFFF FFFF FFFF FFFF FFFF F5F5 F5F5 F5F5" - $"FFF9 FF00 0000 0000 FFF5 F5F5 FFFF 3333 FFFF FFFF FF08 08FF" - $"FFF5 F5F5 F5F5 F5F5 FFF9 FF00 0000 0000 FFF5 F5F5 F5FF FF33" - $"33FF FFFF FF33 0808 FFF5 F5F5 F5F5 F5F5 FFF9 FF00 0000 0000" - $"FFF5 F5F5 F5FF FF33 3333 0808 FF33 3308 08FF F5F5 F5F5 F5F5" - $"FFF9 FF00 0000 0000 FFF5 F5F5 F5FF FF33 3308 0808 08FF 3333" - $"0808 FFF5 F5F5 F5F5 FFF9 FF00 0000 0000 FFF5 F5F5 F5FF FF33" - $"3308 08FF 0808 FF33 3333 FFF5 F5F5 F5F5 FFF9 FF00 0000 0000" - $"FFF5 F5F5 F5FF FF33 3308 08FF 0808 08FF FFFF FFF5 F5F5 F5F5" - $"FFF9 FF00 0000 0000 FFF5 F5F5 F5FF FF33 3333 08FF 0808 0808" - $"FF08 FFF5 F5F5 F5F5 FFF9 FF00 0000 0000 FFF5 F5F5 F5F5 FF33" - $"33E3 05FF 0808 0808 FF08 FFFF FFFF FFFF FFF9 FF00 0000 0000" - $"FFF5 F5F5 F5F5 FFE3 05E3 3333 FF08 0808 FF08 FF2B 2B2B F7FF" - $"F9F7 FF00 0000 0000 FFF5 F5F5 F5FF FFE3 33E3 3333 33FF 0808" - $"FFFF FF2B 2BF7 FFF9 F72B FF00 0000 0000 FFF5 F5F5 F5FF E333" - $"3333 3333 33FF FFFF FFF5 FF2B F7FF F9F7 2BF6 FFFC 0000 0000" - $"FFF5 F5F5 F5FF FFFF FFFF FFFF FFFF F5F5 F5F5 FFF7 FFF9 F72B" - $"F6F6 FFFC FCFC 0000 FFF5 F5F5 F5F5 F5F5 F5F5 F5F5 F5F5 F5F5" - $"F5F5 FFFF F9F7 2BF6 F6F6 FFFC FCFC FCFC FFFF FFFF FFFF FFFF" - $"FFFF FFFF FFFF FFFF FFFF FFF9 F72B F6F6 F6F6 FFFC FCFC FCFC" - $"0000 FFF9 F9F9 F9F9 F9F9 F9F9 F9F9 F9F9 F9F9 F9F7 2BF6 F6F6" - $"F6F6 FFFC FCFC 0000 0000 FFFF FFFF FFFF FFFF FFFF FFFF FFFF" - $"FFFF FFFF FFFF FFFF FFFF FFFC" -}; - -resource 'ICN#' (1000) { - { /* array: 2 elements */ - /* [1] */ - $"001F 8000 003F E000 00FF F000 FDF0 183E 83C0 07FE 81FF FFFE" - $"80E3 FFFC C073 FFFC 603B F9F8 381F F0F0 0C0F F030 0607 E018" - $"0600 300C 0E00 1806 0E00 0C03 0E00 C603 0E00 C303 0E00 C183" - $"0E00 C0C3 0E00 C067 0F00 E035 0700 E01D 0301 E019 0106 7019" - $"0118 7819 0368 1C19 02C8 0E3A 0740 077A 0640 03FC 0C00 07E0" - $"0800 0C00 0F7F F8", - /* [2] */ - $"001F 8000 003F E000 00FF F000 FDFF F83E FFFF FFFE FFFF FFFE" - $"FFFF FFFC FFFF FFFC 7FFF FFF8 3FFF FFF0 0FFF FFF0 07FF FFF8" - $"07FF FFFC 0FFF FFFE 0FFF FFFF 0FFF FFFF 0FFF FFFF 0FFF FFFF" - $"0FFF FFFF 0FFF FFFF 0FFF FFFF 07FF FFFF 03FF FFFF 01FF FFFF" - $"01FF FFFF 03FF FFFF 03FF FFFE 07FF FFFE 07FF FFFC 0FFF FFE0" - $"0FFF FC00 0FFF F8" - } -}; - -resource 'ICN#' (1001) { - { /* array: 2 elements */ - /* [1] */ - $"7FFF F000 4000 1800 4000 1400 407C 1200 4FC7 F100 49FF F080" - $"48FF FFC0 467C C040 433C 4040 4304 2040 4302 1040 4309 1040" - $"4308 F040 4308 5040 4138 5040 41E4 5040 43A2 6040 4203 C040" - $"43FE 0040 4000 0040 4000 0040 4000 0040 4000 0040 4CC0 0040" - $"4CC0 0040 4000 0040 4CC0 0060 4CC0 0078 4440 007E 4880 007E" - $"4000 0078 7FFF FFE0", - /* [2] */ - $"7FFF F000 7FFF F800 7FFF FC00 7FFF FE00 7FFF FF00 7FFF FF80" - $"7FFF FFC0 7FFF FFC0 7FFF FFC0 7FFF FFC0 7FFF FFC0 7FFF FFC0" - $"7FFF FFC0 7FFF FFC0 7FFF FFC0 7FFF FFC0 7FFF FFC0 7FFF FFC0" - $"7FFF FFC0 7FFF FFC0 7FFF FFC0 7FFF FFC0 7FFF FFC0 7FFF FFC0" - $"7FFF FFC0 7FFF FFC0 7FFF FFE0 7FFF FFF8 7FFF FFFE 7FFF FFFE" - $"7FFF FFF8 7FFF FFE0" - } -}; - -resource 'ICN#' (1002) { - { /* array: 2 elements */ - /* [1] */ - $"FFFF FF80 8000 0080 9980 00E0 9980 00A0 8000 00A0 9980 00A0" - $"9980 00A0 8880 00A0 9100 00A0 8000 00A0 8000 00A0 8000 00A0" - $"80F8 00A0 9F8F E0A0 93FF E0A0 91FF C0A0 8CF9 80A0 8678 80A0" - $"8608 40A0 8604 20A0 8612 20A0 8611 E0A0 8610 A0A0 8270 BFA0" - $"83C8 A120 8744 E220 8407 A430 87FC 283C 8000 303F FFFF E03F" - $"2000 003C 3FFF FFF0", - /* [2] */ - $"FFFF FF80 FFFF FF80 FFFF FFE0 FFFF FFE0 FFFF FFE0 FFFF FFE0" - $"FFFF FFE0 FFFF FFE0 FFFF FFE0 FFFF FFE0 FFFF FFE0 FFFF FFE0" - $"FFFF FFE0 FFFF FFE0 FFFF FFE0 FFFF FFE0 FFFF FFE0 FFFF FFE0" - $"FFFF FFE0 FFFF FFE0 FFFF FFE0 FFFF FFE0 FFFF FFE0 FFFF FFE0" - $"FFFF FFE0 FFFF FFE0 FFFF FFF0 FFFF FFFC FFFF FFFF FFFF FFFF" - $"3FFF FFFC 3FFF FFF0" - } -}; - -resource 'ics#' (1000) { - { /* array: 2 elements */ - /* [1] */ - $"07C0 FC7F 9FFF 8FFE 67CC 33C4 3042 3021 3091 308F 3085 1385" - $"1E45 3A26 203C 3FE0", - /* [2] */ - $"07C0 FFFF FFFF FFFE 7FFC 3FFC 3FFE 3FFF 3FFF 3FFF 3FFF 1FFF" - $"1FFF 3FFE 3FFC 3FE0" - } -}; - -resource 'ics#' (1001) { - { /* array: 2 elements */ - /* [1] */ - $"FFE0 8070 8058 8078 8008 8008 8008 B608 B608 8008 B608 B608" - $"9208 A40E 800F FFFE", - /* [2] */ - $"FFE0 FFF0 FFF8 FFF8 FFF8 FFF8 FFF8 FFF8 FFF8 FFF8 FFF8 FFF8" - $"FFF8 FFFE FFFF FFFE" - } -}; - -resource 'ics#' (1002) { - { /* array: 2 elements */ - /* [1] */ - $"FFF8 800C B60C B60C 800C B60C B60C 920C A40C 800C 800C 807C" - $"8054 8066 FFC7 7FFE", - /* [2] */ - $"FFF8 FFFC FFFC FFFC FFFC FFFC FFFC FFFC FFFC FFFC FFFC FFFC" - $"FFFC FFFE FFFF 7FFE" - } -}; - -resource 'ics4' (1000) { - $"0000 0FFF FF00 0000 FFFF FFBB BFFF FFFF FAAF FFFF FFFF FFFF" - $"FAAA FFFF FFFF FFF0 0FFA AFFF FFBB FF00 00FF AAFF FFAB BF00" - $"00FF AAAB BFAA BBF0 00FF AABB BBFA ABBF 00FF AABB FBBF AAAF" - $"00FF AABB FBBB FFFF 00FF AAAB FBBB BFBF 000F AA81 FBBB BFBF" - $"000F 818A AFBB BFBF 00FF 8A8A AAFB BFF0 00F8 AAAA AAFF FF00" - $"00FF FFFF FFF0" -}; - -resource 'ics4' (1001) { - $"FFFF FFFF FFF0 0000 F000 0000 0FFF 0000 F000 0000 0FCF F000" - $"F000 0000 0FFF F000 F000 0000 00CC F000 F000 0000 000C F000" - $"F000 0000 000C F000 F0FF 0FF0 000C F000 F0FF 0FF0 000C F000" - $"F000 0000 000C F000 F0FF 0FF0 000C F000 F0FF 0FF0 000C F000" - $"F00F 00F0 000C F000 F0F0 0F00 000C FEE0 F000 0000 000C FEEE" - $"FFFF FFFF FFFF FEE0" -}; - -resource 'ics4' (1002) { - $"FFFF FFFF FFFF F000 F000 0000 0000 FF00 F0FF 0FF0 0000 FF00" - $"F0FF 0FF0 0000 FF00 F000 0000 0000 FF00 F0FF 0FF0 0000 FF00" - $"F0FF 0FF0 0000 FF00 F00F 00F0 0000 FF00 F0F0 0F00 0000 FF00" - $"F000 0000 0000 FF00 F000 0000 0000 FF00 F000 0000 0FFF FF00" - $"F000 0000 0FCF DF00 F000 0000 0FFD CFE0 FFFF FFFF FFDC CFEE" - $"0FFF FFFF FFFF FFE0" -}; - -resource 'ics8' (1000) { - $"0000 0000 00FF FFFF FFFF 0000 0000 0000 FFFF FFFF FFFF 0808" - $"08FF FFFF FFFF FFFF FF33 33FF FFFF FFFF FFFF FFFF FFFF FFFF" - $"FF33 3333 FFFF FFFF FFFF FFFF FFFF FF00 00FF FF33 33FF FFFF" - $"FFFF 0808 FFFF 0000 0000 FFFF 3333 FFFF FFFF 3308 08FF 0000" - $"0000 FFFF 3333 3308 08FF 3333 0808 FF00 0000 FFFF 3333 0808" - $"0808 FF33 3308 08FF 0000 FFFF 3333 0808 FF08 08FF 3333 33FF" - $"0000 FFFF 3333 0808 FF08 0808 FFFF FFFF 0000 FFFF 3333 3308" - $"FF08 0808 08FF 08FF 0000 00FF 3333 E305 FF08 0808 08FF 08FF" - $"0000 00FF E305 E333 33FF 0808 08FF 08FF 0000 FFFF E333 E333" - $"3333 FF08 08FF FF00 0000 FFE3 3333 3333 3333 FFFF FFFF 0000" - $"0000 FFFF FFFF FFFF FFFF FF" -}; - -resource 'ics8' (1001) { - $"FFFF FFFF FFFF FFFF FFFF FF00 0000 0000 FFF5 F5F5 F5F5 F5F5" - $"F5FF FFFF 0000 0000 FFF5 F5F5 F5F5 F5F5 F5FF F6FF FF00 0000" - $"FFF5 F5F5 F5F5 F5F5 F5FF FFFF FF00 0000 FFF5 F5F5 F5F5 F5F5" - $"F5F5 F7F7 FF00 0000 FFF5 F5F5 F5F5 F5F5 F5F5 F5F7 FF00 0000" - $"FFF5 F5F5 F5F5 F5F5 F5F5 F5F7 FF00 0000 FFF5 FFFF F5FF FFF5" - $"F5F5 F5F7 FF00 0000 FFF5 FFFF F5FF FFF5 F5F5 F5F7 FF00 0000" - $"FFF5 F5F5 F5F5 F5F5 F5F5 F5F7 FF00 0000 FFF5 FFFF F5FF FFF5" - $"F5F5 F5F7 FF00 0000 FFF5 FFFF F5FF FFF5 F5F5 F5F7 FF00 0000" - $"FFF5 F5FF F5F5 FFF5 F5F5 F5F7 FF00 0000 FFF5 FFF5 F5FF F5F5" - $"F5F5 F5F7 FFFC FC00 FFF5 F5F5 F5F5 F5F5 F5F5 F5F7 FFFC FCFC" - $"FFFF FFFF FFFF FFFF FFFF FFFF FFFC FC" -}; - -resource 'ics8' (1002) { - $"FFFF FFFF FFFF FFFF FFFF FFFF FF00 0000 FFF5 F5F5 F5F5 F500" - $"F5F5 F5F5 FFFF 0000 FFF5 FFFF F5FF FF00 F5F5 F5F5 FFFF 0000" - $"FFF5 FFFF F5FF FF00 F5F5 F5F5 FFFF 0000 FFF5 F5F5 F5F5 F500" - $"F5F5 F5F5 FFFF 0000 FFF5 FFFF F5FF FF00 F5F5 F5F5 FFFF 0000" - $"FFF5 FFFF F5FF FF00 F5F5 F5F5 FFFF 0000 FFF5 F5FF F5F5 FF00" - $"F5F5 F5F5 FFFF 0000 FFF5 FFF5 F5FF F500 F5F5 F5F5 FFFF 0000" - $"FFF5 F5F5 F5F5 F500 F5F5 F5F5 FFFF 0000 FFF5 F5F5 F5F5 F5F5" - $"F5F5 F5F5 FFFF 0000 FFF5 F5F5 F5F5 F5F5 F5FF FFFF FFFF 0000" - $"FFF5 F5F5 F5F5 F5F5 F5FF F5FF F9FF 0000 FFF5 F5F5 F5F5 F5F5" - $"F5FF FFF9 F7FF FC00 FFFF FFFF FFFF FFFF FFFF F9F7 F7FF FCFC" - $"00FF FFFF FFFF FFFF FFFF FFFF FFFF FC" -}; - -resource 'ICON' (1000) { - $"001F 8000 003F E000 00FF F000 FDF0 183E 83C0 07FE 81FF FFFE" - $"80E3 FFFC C073 FFFC 603B F9F8 381F F0F0 0C0F F030 0607 E018" - $"0600 300C 0E00 1806 0E00 0C03 0E00 C603 0E00 C303 0E00 C183" - $"0E00 C0C3 0E00 C067 0F00 E035 0700 E01D 0301 E019 0106 7019" - $"0118 7819 0368 1C19 02C8 0E3A 0740 077A 0640 03FC 0C00 07E0" - $"0800 0C00 0FFF F8" -}; - -data 'cicn' (1000) { - $"0000 0000 8010 0000 0000 0020 0020 0000 0000 0000 0000 0048" - $"0000 0048 0000 0000 0004 0001 0004 0000 0000 0000 0000 0000" - $"0000 0000 0000 0004 0000 0000 0020 0020 0000 0000 0004 0000" - $"0000 0020 0020 0000 0000 001F 8000 003F E000 00FF F000 FDFF" - $"F83E FFFF FFFE FFFF FFFE FFFF FFFC FFFF FFFC 7FFF FFF8 3FFF" - $"FFF0 0FFF FFF0 07FF FFF8 07FF FFFC 0FFF FFFE 0FFF FFFF 0FFF" - $"FFFF 0FFF FFFF 0FFF FFFF 0FFF FFFF 0FFF FFFF 0FFF FFFF 07FF" - $"FFFF 03FF FFFF 01FF FFFF 01FF FFFF 03FF FFFF 03FF FFFE 07FF" - $"FFFE 07FF FFFC 0FFF FFE0 0FFF FC00 0FFF F800 001F 8000 003F" - $"E000 00FF F000 FDF0 183E 83C0 07FE 81FF FFFE 80E3 FFFC C073" - $"FFFC 603B F9F8 381F F0F0 0C0F F030 0607 E018 0600 300C 0E00" - $"1806 0E00 0C03 0E00 C603 0E00 C303 0E00 C183 0E00 C0C3 0E00" - $"C067 0F00 E035 0700 E01D 0301 E019 0106 7019 0118 7819 0368" - $"1C19 02C8 0E3A 0740 077A 0640 03FC 0C00 07E0 0800 0C00 0FFF" - $"F800 0000 0000 0000 0007 0000 FFFF FFFF FFFF 0001 FFFF FFFF" - $"0000 0002 CCCC 9999 6666 0003 8888 8888 8888 0004 DDDD DDDD" - $"DDDD 0005 FFFF CCCC 9999 0006 0000 BBBB 0000 000F 0000 0000" - $"0000 0000 0000 000F FFFF F000 0000 0000 0000 0000 0000 00FF" - $"FFFF FFF0 0000 0000 0000 0000 0000 FFFF FFFF FFFF 0000 0000" - $"0000 FFFF FF0F FFFF 5555 555F F000 00FF FFF0 F222 22FF FF55" - $"5555 5555 5FFF FFFF FFF0 F222 222F FFFF FFFF FFFF FFFF FFFF" - $"FFF0 F222 2222 FFF3 33FF FFFF FFFF FFFF FF00 FF22 2222 2FFF" - $"44FF FFFF FFFF FFFF FF00 0FF2 2222 22FF F4FF FFFF F55F FFFF" - $"F000 00FF F222 222F FFFF FFFF 5555 FFFF 0000 0000 FF22 2222" - $"FFFF FFFF 5555 55FF 0000 0000 0FF2 2222 2FFF FFF2 2555 555F" - $"F000 0000 0FF2 2222 2555 55FF 2255 5555 FF00 0000 FFF2 2222" - $"5555 555F F225 5555 5FF0 0000 FFF2 2225 5555 5555 FF22 5555" - $"55FF 0000 FFF2 2225 5555 FF55 5FF2 2555 55FF 0000 FFF2 2225" - $"5555 FF55 55FF 2252 55FF 0000 FFF2 2225 5555 FF55 555F F222" - $"22FF 0000 FFF2 2225 5555 FF55 5555 FF22 22FF 0000 FFF2 2222" - $"5555 FF55 5555 5FF2 2FFF 0000 FFFF 2222 2555 FFF5 5555 55FF" - $"2F5F 0000 0FFF 2222 2255 FFF5 5555 555F FF5F 0000 00FF 2222" - $"2221 61F5 5555 555F F55F 0000 000F 2222 2612 2FFF 5555 555F" - $"F55F 0000 000F 2221 6222 2FFF F555 555F F55F 0000 00FF 2612" - $"1222 222F FF55 555F F55F 0000 00F2 1122 6222 2222 FFF5 55FF" - $"F5F0 0000 0FF6 2622 2222 2222 2FFF 5FFF F5F0 0000 0F62 2622" - $"2222 2222 22FF FFFF FF00 0000 FF22 2222 2222 2222 2FFF FFF0" - $"0000 0000 F222 2222 2222 2222 FF00 0000 0000 0000 FFFF FFFF" - $"FFFF FFFF F000 0000 0000" -}; diff --git a/maccaml/ocamlconstants.h b/maccaml/ocamlconstants.h deleted file mode 100644 index 1b3e1e6515..0000000000 --- a/maccaml/ocamlconstants.h +++ /dev/null @@ -1,187 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Damien Doligez, projet Para, INRIA Rocquencourt */ -/* */ -/* Copyright 1998 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 file ../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#define kMinSystemVersion 0x700 - -#define kExtraStackSpace (128 * 1024) -#define kMoreMasters 6 -#define kScrapThreshold (4 * 1024) -#define kMinimumMemory (32 * 1024) - -#define kTitleBarSpace 20 -#define kWinBorderSpace 5 -#define kPowerStripSpace 20 -#define kVisualDelay 8UL /* XXX use double-click time ?? */ - -#define ktextwidth 32000 -#define kHorizScrollDelta 32 -#define kGraphScrollDelta 8 -#define kScrollBarWidth 15 /* not counting one of the borders. */ -#define kTextMarginV 3 -#define kTextMarginH 6 -#define kMinWindowWidth 64 -#define kMinWindowHeight 64 - -#define keyPgUp 0x74 -#define keyPgDn 0x79 -#define keyHome 0x73 -#define keyEnd 0x77 -#define keyF1 0x7A -#define keyF2 0x78 -#define keyF3 0x63 -#define keyF4 0x76 - -#define charEnter 0x03 -#define charBackspace 0x08 -#define charReturn 0x0D -#define charEscape 0x1B -#define charArrowLeft 0x1C -#define charArrowRight 0x1D -#define charArrowUp 0x1E -#define charArrowDown 0x1F -#define charDelete 0x7F - -#define kWinUnknown 0 -#define kWinUninitialised 1 -#define kWinAbout 2 -#define kWinToplevel 3 -#define kWinGraphics 4 -#define kWinDocument 5 -#define kWinPrefs 6 -#define kWinClipboard 7 - -#define kCreatorCaml 'Caml' -#define kTypeText 'TEXT' - -/* Resource IDs */ - -#define kToplevelWinTemplate 1000 -#define kGraphicsWinTemplate 1001 -#define kDocumentWinTemplate 1002 - -#define kScrollBarTemplate 1000 - -/* DO NOT CHANGE this definition. */ -#define kApplicationIcon 1000 - -#define kDialogAbout 1000 -#define kAlertNeedSys7 1001 -#define kAlertBug 1002 -#define kAlertGeneric 1003 -#define kAlertExit 1004 -#define kDialogPrefs 1005 -#define kAlertNotYet 1006 -#define kAlertSaveAsk 1007 -#define kAlertErrorMsg 1008 -#define kAlertErrorNum 1009 -#define kAlertNeed32BitQD 1010 - -#define kKeysOK 1000 -#define kKeysSaveDontCancel 1001 - -#define kPrefsDescriptionStr 1000 -#define kApplicationMissing -16397 - -#define kUndoStrings 1000 - -#define kMiscStrings 1001 -#define kPrefsFileNameIdx 1 -#define kUntitledIdx 2 -#define kClosingIdx 3 -#define kQuittingIdx (kClosingIdx + 1) -#define kCannotOpenIdx 5 -#define kCloseQuoteIdx 6 -#define kSaveAsPromptIdx 7 -#define kEmptyIdx 8 -#define kCannotWriteIdx 9 -#define kWithErrorCodeIdx 10 - -#define kErrorStrings 1002 -#define kMemFull 1 -#define kDiskFull 2 -#define kDirFull 3 -#define kTooManyFiles 4 -#define kFileNotFound 5 -#define kWriteProtect 6 -#define kFileLocked 7 -#define kVolLocked 8 -#define kFileBusy 9 -#define kFileOpen 10 -#define kVolOffLine 11 -#define kPermDenied 12 -#define kWritePermDenied 13 -#define kDirNotFound 14 -#define kDisconnected 15 -#define kIOError 16 - -#define kAboutText1 1000 -#define kAboutText2 1001 - -#define kMenuBar 1000 - -#define kCommandLineTemplate 1000 -#define kEnvironmentTemplate 1001 - - -/* Sound stuff */ - -#define kDurationOffset 0x1E -#define kSampleRateOffset 0x34 - - -/* Menus */ - -#define kMenuApple 1000 -#define kMenuFile 1001 -#define kMenuEdit 1002 -#define kMenuWindows 1003 - -/***** Apple menu */ -#define kItemAbout 1 - -/***** File menu */ -#define kItemNew 1 -#define kItemOpen 2 -/* - */ -#define kItemClose 4 -#define kItemSave 5 -#define kItemSaveAs 6 -#define kItemRevert 7 -/* - */ -#define kItemPageSetup 9 -#define kItemPrint 10 -/* - */ -#define kItemQuit 12 - -/***** Edit menu */ -#define kItemUndo 1 -/* - */ -#define kItemCut 3 -#define kItemCopy 4 -#define kItemPaste 5 -#define kItemClear 6 -#define kItemSelectAll 7 -#define kItemShowClipboard 8 -/* - */ -#define kItemFind 10 -#define kItemReplace 11 -/* - */ -#define kItemPreferences 13 - -/***** Windows menu */ -#define kItemToplevel 1 -#define kItemGraphics 2 -/* - */ -#define kItemDocuments 4 diff --git a/maccaml/ocamlmkappli b/maccaml/ocamlmkappli deleted file mode 100644 index c300c16a6c..0000000000 --- a/maccaml/ocamlmkappli +++ /dev/null @@ -1,89 +0,0 @@ -######################################################################### -# # -# Objective Caml # -# # -# Damien Doligez, projet Moscova, INRIA Rocquencourt # -# # -# Copyright 2000 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### - -# $Id$ - - -# ocamlmkappli -- build a standalone application - -# usage: ocamlmkappli [optionÉ] fileÉ -# options: -# -creator use this creator code (default '????') -# -ocamlc use as O'Caml compiler (default ocamlc) -# -d pass "-d " option to Rez -# -prefsize set preferred memory size (kilobytes, default 4000) -# -lib use library files from (default {CAMLLIB}) -# -minsize set minimum memory size (megabytes, default 2000) -# -name set the name of the application (default a.out) -# -r add resources from this file (or rez source file) - -set echo 0 - -set creator '????' -set ocamlc ocamlc -set rezopt '' -set prefsize 4000 -set lib "{{CAMLLIB}}" -set minsize 2000 -set name a.out -set rezfiles '' - -set files '' - -loop - break if {#} == 0 - if "{{1}}" == "-creator" - set creator "{{2}}" - shift - else if "{{1}}" == "-ocamlc" - set ocamlc "{{2}}" - shift - else if "{{1}}" == "-d" - set rezopt "{{rezopt}} -d ``quote "{{2}}"``" - shift - else if "{{1}}" == "-prefsize" - set prefsize {2} - shift - else if "{{1}}" == "-lib" - set lib "{{2}}" - shift - else if "{{1}}" == "-minsize" - set minsize {2} - shift - else if "{{1}}" == "-name" - set name "{{2}}" - shift - else if "{{1}}" == "-r" - set rezfiles "{{rezfiles}} ``quote "{{2}}"``" - shift - else - set files "{{files}} ``quote "{{1}}"``" - end - shift -end - -if {prefsize} < {minsize} - set prefsize {minsize} -end - -set tmp "{{tempfolder}}ocamlmkappli-`date -n`" -delete -y -ay -i "{{tmp}}" - -duplicate -y "{{lib}}appli" "{{name}}" -rez -d SystemSevenOrLater=1 -d PREFSIZE="{prefsize}" -d MINSIZE="{minsize}" ¶ - -d APPLNAME="¶"{{name}}¶"" -d CREATOR="'{{creator}}'" ¶ - -a -o "{{name}}" "{{lib}}appli.r" {rezopt} {rezfiles} -{ocamlc} -use-prims "{{lib}}appliprims" {files} -o "{{tmp}}" -catenate "{{tmp}}" >> "{{name}}" -setfile -t APPL -c "{{creator}}" -a iB "{{name}}" - -delete -i "{{tmp}}" diff --git a/maccaml/prefs.c b/maccaml/prefs.c deleted file mode 100644 index 70f208550a..0000000000 --- a/maccaml/prefs.c +++ /dev/null @@ -1,127 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Damien Doligez, projet Para, INRIA Rocquencourt */ -/* */ -/* Copyright 1998 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 file ../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include "main.h" - -#define kPrefResource 1000 - -struct prefs prefs; -static struct prefs defpref; - -static void InitPrefs (void) -{ - TextStyle defstyle; - - defpref.version = PREF_VERSION; - defpref.asksavetop = 0; - WinToplevelStdState (&defpref.toppos); - WinGraphicsStdState (&defpref.graphpos); - WinClipboardStdState (&defpref.clippos); - GetFNum ("\pmonaco", &defstyle.tsFont); - defstyle.tsSize = 9; - defstyle.tsFace = 0; - defstyle.tsColor.red = 0; - defstyle.tsColor.green = 0; - defstyle.tsColor.blue = 0; - defpref.text = defpref.unread = defpref.input = defpref.output - = defpref.errors = defstyle; - - defpref.unread.tsColor.green = 35000; - defpref.input.tsColor.blue = 65535; - defpref.errors.tsColor.red = 50000; - defpref.errors.tsFace = underline; -} - -void ReadPrefs (void) -{ - short err; - short vrefnum; - long dirid; - short refnum = -1; - Handle prefsH = NULL; - Str255 prefsfilename; - FSSpec spec; - - InitPrefs (); - GetIndString (prefsfilename, kMiscStrings, kPrefsFileNameIdx); - err = FindFolder (kOnSystemDisk, kPreferencesFolderType, kCreateFolder, - &vrefnum, &dirid); - if (err != noErr) goto cantread; - err = FSMakeFSSpec (vrefnum, dirid, prefsfilename, &spec); - if (err != noErr) goto cantread; - refnum = FSpOpenResFile (&spec, fsRdPerm); - if (refnum == -1) goto cantread; - prefsH = Get1Resource ('Oprf', kPrefResource); - if (prefsH == NULL) goto cantread; - if (GetHandleSize (prefsH) != sizeof (prefs)) goto cantread; - if (**(long **)prefsH != PREF_VERSION) goto cantread; - memmove (&prefs, *prefsH, sizeof (prefs)); - CloseResFile (refnum); - return; - - cantread: - if (refnum != -1) CloseResFile (refnum); - prefs = defpref; -} - -void WritePrefs (void) -{ - short err; - short vrefnum; - long dirid; - short refnum = -1; - Handle prefsH = NULL; - Str255 prefsfilename; - FSSpec spec; - Handle h; - - GetIndString (prefsfilename, kMiscStrings, kPrefsFileNameIdx); - err = FindFolder (kOnSystemDisk, kPreferencesFolderType, kCreateFolder, - &vrefnum, &dirid); - if (err != noErr) goto cantwrite; - err = FSMakeFSSpec (vrefnum, dirid, prefsfilename, &spec); - if (err != noErr && err != fnfErr) goto cantwrite; - - if (err == fnfErr){ - if (!memcmp (&prefs, &defpref, sizeof (prefs))) return; - else FSpCreateResFile (&spec, 0, 0, smSystemScript); - } - refnum = FSpOpenResFile (&spec, fsRdWrPerm); - if (refnum == -1) goto cantwrite; - - prefsH = Get1Resource ('Oprf', kPrefResource); - if (prefsH == NULL){ - err = AllocHandle (sizeof (prefs), (Handle *) &prefsH); - if (err != noErr) goto cantwrite; - AddResource (prefsH, 'Oprf', kPrefResource, "\pO'Caml prefs"); - } - SetHandleSize (prefsH, sizeof (prefs)); - if (MemError () != noErr) goto cantwrite; - memmove (*prefsH, &prefs, sizeof (prefs)); - ChangedResource (prefsH); - - h = GetResource ('STR ', kPrefsDescriptionStr); - if (h != NULL){ - DetachResource (h); - AddResource (h, 'STR ', kApplicationMissing, NULL); - ChangedResource (h); - } - - CloseResFile (refnum); - return; - - cantwrite: - if (refnum != -1) CloseResFile (refnum); -} diff --git a/maccaml/prim_bigarray b/maccaml/prim_bigarray deleted file mode 100644 index abec389025..0000000000 --- a/maccaml/prim_bigarray +++ /dev/null @@ -1,18 +0,0 @@ -bigarray_blit -bigarray_create -bigarray_dim -bigarray_fill -bigarray_get_1 -bigarray_get_2 -bigarray_get_3 -bigarray_get_generic -bigarray_init -bigarray_map_file -bigarray_num_dims -bigarray_reshape -bigarray_set_1 -bigarray_set_2 -bigarray_set_3 -bigarray_set_generic -bigarray_slice -bigarray_sub diff --git a/maccaml/prim_graph b/maccaml/prim_graph deleted file mode 100644 index 35c00284e9..0000000000 --- a/maccaml/prim_graph +++ /dev/null @@ -1,41 +0,0 @@ -gr_blit_image -gr_clear_graph -gr_close_graph -gr_close_subwindow -gr_create_image -gr_current_x -gr_current_y -gr_display_mode -gr_draw_arc -gr_draw_arc_nat -gr_draw_char -gr_draw_image -gr_draw_rect -gr_draw_string -gr_dump_image -gr_fill_arc -gr_fill_arc_nat -gr_fill_poly -gr_fill_rect -gr_lineto -gr_make_image -gr_moveto -gr_open_graph -gr_open_subwindow -gr_plot -gr_point_color -gr_remember_mode -gr_set_color -gr_set_font -gr_set_line_width -gr_set_text_size -gr_set_window_title -gr_sigio_handler -gr_sigio_signal -gr_size_x -gr_size_y -gr_sound -gr_synchronize -gr_text_size -gr_wait_event -gr_window_id diff --git a/maccaml/prim_num b/maccaml/prim_num deleted file mode 100644 index 9a30b25382..0000000000 --- a/maccaml/prim_num +++ /dev/null @@ -1,28 +0,0 @@ -add_nat -blit_nat -compare_digits_nat -compare_nat -complement_nat -create_nat -decr_nat -div_digit_nat -div_nat -incr_nat -initialize_nat -is_digit_int -is_digit_normalized -is_digit_odd -is_digit_zero -land_digit_nat -lor_digit_nat -lxor_digit_nat -mult_digit_nat -mult_nat -nth_digit_nat -num_digits_nat -num_leading_zero_bits_in_digit -set_digit_nat -set_to_zero_nat -shift_left_nat -shift_right_nat -sub_nat diff --git a/maccaml/prim_str b/maccaml/prim_str deleted file mode 100644 index 00e31ec574..0000000000 --- a/maccaml/prim_str +++ /dev/null @@ -1,8 +0,0 @@ -str_compile_regexp -str_string_match -str_string_partial_match -str_search_forward -str_search_backward -str_beginning_group -str_end_group -str_replacement_text diff --git a/maccaml/print.c b/maccaml/print.c deleted file mode 100644 index 43263add96..0000000000 --- a/maccaml/print.c +++ /dev/null @@ -1,131 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Damien Doligez, projet Para, INRIA Rocquencourt */ -/* */ -/* Copyright 1999 Institut National de Recherche en Informatique et */ -/* en Automatique. All rights reserved. This file is distributed */ -/* under the terms of the GNU Library General Public License, with */ -/* the special exception on linking described in file ../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include "main.h" - -static short (*get_npages) (THPrint printrec); -static short (*draw_page) (THPrint printrec, TPPrPort port, int pagenum); - -static THPrint curjobprintrec = NULL; - -/* - dojobdialog = 0 -> no job dialog (use default settings) - dojobdialog = 1 -> use job dialog - dojobdialog = 2 -> no job dialog (use previous dialog settings) -*/ -static short print_loop (int dojobdialog, THPrint docprintrec) -{ - short ncopies, fstpage, lstpage, npages; - OSErr err; - GrafPtr saveport; - TPPrPort printerport; - TPrStatus prstatus; - int copy, page, pgrun; - - GetPort (&saveport); - - PrOpen (); - err = PrError (); if (err != noErr) goto failed_PrOpen; - - PrValidate (docprintrec); - err = PrError (); if (err != noErr) goto failed_PrValidate; - - npages = (*get_npages) (docprintrec); - switch (dojobdialog){ - case 0: - if (curjobprintrec != NULL) DisposeHandle ((Handle) curjobprintrec); - curjobprintrec = (THPrint) NewHandle (sizeof (TPrint)); - if (curjobprintrec == NULL) goto failed_alloc_curjobprintrec; - PrintDefault (curjobprintrec); - PrJobMerge (curjobprintrec, docprintrec); - break; - case 1: - err = PrJobDialog (docprintrec); - if (err) goto failed_PrJobDialog; - if (curjobprintrec != NULL) DisposeHandle ((Handle) curjobprintrec); - curjobprintrec = docprintrec; - HandToHand ((Handle *) &curjobprintrec); - if (curjobprintrec == NULL) goto failed_alloc_curjobprintrec; - break; - case 2: - PrJobMerge (curjobprintrec, docprintrec); - break; - } - ncopies = (*docprintrec)->prJob.iCopies; - fstpage = (*docprintrec)->prJob.iFstPage; - lstpage = (*docprintrec)->prJob.iLstPage; - if (lstpage > npages) lstpage = npages; - - /* XXX Should display a status dialog box and use a IdleProc function */ - - for (copy = 0; copy < ncopies; copy++){ - printerport = PrOpenDoc (docprintrec, NULL, NULL); - err = PrError (); if (err != noErr) goto failed_PrOpenDoc; - pgrun = 0; - for (page = fstpage; page <= lstpage; page++){ - if (pgrun >= iPFMaxPgs){ - PrCloseDoc (printerport); - err = PrError (); if (err != noErr) goto failed_PrCloseDoc; - if ((*docprintrec)->prJob.bJDocLoop == bSpoolLoop){ - PrPicFile (docprintrec, NULL, NULL, NULL, &prstatus); - } - printerport = PrOpenDoc (docprintrec, NULL, NULL); - err = PrError (); if (err != noErr) goto failed_PrOpenDoc; - pgrun = 0; - } - PrOpenPage (printerport, NULL); - err = PrError (); if (err != noErr) goto failed_PrOpenPage; - err = (*draw_page) (docprintrec, printerport, page); - if (err != noErr) goto failed_draw_page; - PrClosePage (printerport); - ++ pgrun; - } - PrCloseDoc (printerport); - err = PrError (); if (err != noErr) goto failed_PrCloseDoc; - if ((*docprintrec)->prJob.bJDocLoop == bSpoolLoop){ - PrPicFile (docprintrec, NULL, NULL, NULL, &prstatus); - } - } - PrClose (); - /*XXX close status dialog box here */ - SetPort (saveport); - return noErr; - - failed_draw_page: - PrClosePage (printerport); - /* fall through */ - failed_PrOpenPage: - PrCloseDoc (printerport); - /* fall through */ - failed_PrOpenDoc: - failed_PrCloseDoc: - failed_alloc_curjobprintrec: - failed_PrJobDialog: - failed_PrValidate: - PrClose (); - /* fall through */ - failed_PrOpen: - return err; -} - -void FilePageSetup (void) -{ - XXX (); -} - -void FilePrint (void) -{ - XXX (); -} diff --git a/maccaml/scroll.c b/maccaml/scroll.c deleted file mode 100644 index e91a79bb01..0000000000 --- a/maccaml/scroll.c +++ /dev/null @@ -1,325 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Damien Doligez, projet Para, INRIA Rocquencourt */ -/* */ -/* Copyright 1998 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 file ../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include "main.h" - -WEScrollUPP scrollFollowUPP; -static ControlActionUPP scrollUPP, scrollGraphUPP; - -static long scroll_step = 1; - -/* Bring destRect in sync with the scroll bars. */ -static void AdjustView (WStatusH st) -{ - WEReference we = (*st)->we; - ControlHandle hbar = (*st)->scrollbars[H]; - ControlHandle vbar = (*st)->scrollbars[V]; - LongRect view, dest; - long dx, dy; - - Assert (hbar != NULL && vbar != NULL); - if ((*st)->kind != kWinGraphics){ - Assert (we != NULL); - WEGetViewRect (&view, we); - WEGetDestRect (&dest, we); - dx = view.left - dest.left - LCGetValue (hbar); - dy = view.top - dest.top - LCGetValue (vbar); - WEScroll (dx, dy, we); - }else{ - dx = (*st)->viewrect.left - (*st)->destrect.left - LCGetValue (hbar); - dy = (*st)->viewrect.top - (*st)->destrect.top - LCGetValue (vbar); - GraphScroll (dx, dy); - } -} - -/* Recompute the max values and the thumb positions. */ -void AdjustScrollBars (WindowPtr w) -{ - GrafPtr saveport; - WStatusH st; - LongRect view, dest; - long xmax, xval, ymax, yval; - long h; - - PushWindowPort (w); - - st = WinGetStatus (w); - Assert (st != NULL); - if ((*st)->kind == kWinGraphics){ - view = (*st)->viewrect; - dest = (*st)->destrect; - }else{ - WEGetViewRect (&view, (*st)->we); - WEGetDestRect (&dest, (*st)->we); - } - - yval = view.top - dest.top; - ymax = yval + (dest.bottom - view.bottom); - if (ymax < 0) ymax = 0; - - /* round up to nearest line_height */ - h = (*st)->line_height; - ymax = (ymax + h - 1) / h * h; - - LCSetMax ((*st)->scrollbars[V], ymax); - LCSetValue ((*st)->scrollbars[V], yval); - - xval = view.left - dest.left; - xmax = xval + (dest.right - view.right); - if (xmax < 0) xmax = 0; - LCSetMax ((*st)->scrollbars[H], xmax); - LCSetValue ((*st)->scrollbars[H], xval); - - if (xval > xmax || yval > ymax) AdjustView (st); - - PopPort; -} - -/* Callback procedure for auto-scrolling the text. (called by WASTE) */ -static pascal void Follow (WEReference we) -{ - WindowPtr w; - OSErr err; - - err = WEGetInfo (weRefCon, &w, we); - Assert (err == noErr); - AdjustScrollBars (w); -} - -/* Callback procedure for scrolling the text. (called by the Control Manager) */ -static pascal void Scroll (ControlHandle bar, ControlPartCode partcode) -{ - long value; - - if (partcode == kControlNoPart) return; - value = LCGetValue (bar); - if (value < LCGetMax (bar) && scroll_step > 0 - || value > 0 && scroll_step < 0){ - LCSetValue (bar, value + scroll_step); - AdjustView (WinGetStatus (FrontWindow ())); - } -} - -/* Callback procedure for scrolling the graphics. */ -static pascal void ScrollGraph (ControlHandle bar, ControlPartCode partcode) -{ - long value; - - if (partcode == kControlNoPart) return; - value = LCGetValue (bar); - if (value < LCGetMax (bar) && scroll_step > 0 - || value > 0 && scroll_step < 0){ - LCSetValue (bar, value + scroll_step); - AdjustView (WinGetStatus (FrontWindow ())); - } -} - -OSErr InitialiseScroll (void) -{ - scrollFollowUPP = NewWEScrollProc (Follow); - scrollUPP = NewControlActionProc (Scroll); - scrollGraphUPP = NewControlActionProc (ScrollGraph); - return noErr; -} - -/* Calculate the contents rectangle for a text window with scrollbars. */ -void ScrollCalcText (WindowPtr w, Rect *r) -{ - *r = w->portRect; - r->bottom -= kScrollBarWidth; - r->right -= kScrollBarWidth; - InsetRect (r, kTextMarginH, kTextMarginV); -} - -/* Calculate the contents rectangle for the graphics window. */ -void ScrollCalcGraph (WindowPtr w, Rect *r) -{ - *r = w->portRect; - r->bottom -= kScrollBarWidth; - r->right -= kScrollBarWidth; -} - -void ScrollDoClick (WindowPtr w, Point where, EventModifiers mods) -{ - switch (WinGetKind (w)){ - case kWinToplevel: - case kWinDocument: { - WEReference we = WinGetWE (w); - WStatusH st = WinGetStatus (w); - LongRect view; - ControlPartCode partcode; - ControlHandle bar; - long scrolldelta, pagesize; - - Assert (we != NULL && st != NULL); - WEGetViewRect (&view, we); - partcode = FindControl (where, w, &bar); - if (bar == (*st)->scrollbars[V]){ - pagesize = view.bottom - view.top; - scrolldelta = (*st)->line_height; - }else if (bar == (*st)->scrollbars [H]){ - pagesize = view.right - view.left; - scrolldelta = kHorizScrollDelta; - }else{ - return; - } - switch (partcode){ - case kControlIndicatorPart: - TrackControl (bar, where, NULL); - LCSynch (bar); - AdjustView (st); - return; - case kControlUpButtonPart: - scroll_step = - (mods & optionKey ? 1 : scrolldelta); - break; - case kControlDownButtonPart: - scroll_step = + (mods & optionKey ? 1 : scrolldelta); - break; - case kControlPageUpPart: - scroll_step = - (pagesize - scrolldelta) / scrolldelta * scrolldelta; - break; - case kControlPageDownPart: - scroll_step = + (pagesize - scrolldelta) / scrolldelta * scrolldelta; - break; - } - TrackControl (bar, where, scrollUPP); - break; - } - case kWinGraphics: { - WStatusH st = WinGetStatus (w); - ControlPartCode partcode; - ControlHandle bar; - long scrolldelta, pagesize; - - Assert (st != NULL); - partcode = FindControl (where, w, &bar); - scrolldelta = kGraphScrollDelta; - if (bar == (*st)->scrollbars[V]){ - pagesize = (*st)->viewrect.bottom - (*st)->viewrect.top; - }else if (bar == (*st)->scrollbars [H]){ - pagesize = (*st)->viewrect.right - (*st)->viewrect.left; - }else{ - return; - } - switch (partcode){ - case kControlIndicatorPart: - TrackControl (bar, where, NULL); - LCSynch (bar); - AdjustView (st); - return; - case kControlUpButtonPart: - scroll_step = - (mods & optionKey ? 1 : scrolldelta); - break; - case kControlDownButtonPart: - scroll_step = + (mods & optionKey ? 1 : scrolldelta); - break; - case kControlPageUpPart: - scroll_step = - (pagesize - scrolldelta) / scrolldelta * scrolldelta; - break; - case kControlPageDownPart: - scroll_step = + (pagesize - scrolldelta) / scrolldelta * scrolldelta; - break; - } - TrackControl (bar, where, scrollGraphUPP); - break; - } - case kWinPrefs: - case kWinAbout: - case kWinClipboard: - default: - Assert (0); /* These windows have no scroll bars. */ - break; - } -} - -/* Calculate and set the position of the scroll bars for w. - Draw the scroll bars and the grow icon, and validate their region. - Where applicable, this function must be called after WinWEResize or - WinGraphResize. - */ -void ScrollNewSize (WindowPtr w) -{ - Rect port = w->portRect; - WStatusH st = WinGetStatus (w); - Rect r; - ControlHandle bar; - GrafPtr saveport; - - Assert (st != NULL); - - PushWindowPort (w); - - bar = (*st)->scrollbars[H]; - r.left = port.left - 1; - r.right = port.right - kScrollBarWidth + 1; - r.top = port.bottom - kScrollBarWidth; - r.bottom = port.bottom + 1; - HideControl (bar); /* Invalidates the rectangle */ - MoveControl (bar, r.left, r.top); - SizeControl (bar, r.right - r.left, r.bottom - r.top); - /* Only show the scrollbar if the window is active. */ - if (FrontWindow () == w){ - ValidRect (&r); - ShowControl (bar); - } - - bar = (*st)->scrollbars[V]; - r.left = port.right - kScrollBarWidth; - r.right = port.right + 1; - r.top = port.top - 1; - r.bottom = port.bottom - kScrollBarWidth + 1; - HideControl (bar); /* Invalidates the rectangle */ - MoveControl (bar, r.left, r.top); - SizeControl (bar, r.right - r.left, r.bottom - r.top); - /* Only show the scrollbar if the window is active. */ - if (FrontWindow () == w){ - ValidRect (&r); - ShowControl (bar); - } - - r = w->portRect; - r.left = r.right - kScrollBarWidth; - r.top = r.bottom - kScrollBarWidth; - ValidRect (&r); - DrawGrowIcon (w); - - AdjustScrollBars (w); - - PopPort; -} - -/* Return 1 if the vertical scroll bar is at its max setting, 0 otherwise. - (With 1 line fudge factor.) -*/ -int ScrollAtEnd (WindowPtr w) -{ - WStatusH st = WinGetStatus (w); - long val, max; - - Assert (st != NULL); - val = LCGetValue ((*st)->scrollbars[V]); - max = LCGetMax ((*st)->scrollbars[V]); - return val >= max - (*st)->line_height; -} - -/* Scroll to the bottom of the document. */ -void ScrollToEnd (WindowPtr w) -{ - WStatusH st = WinGetStatus (w); - - Assert (st != NULL); - LCSetValue ((*st)->scrollbars[V], LCGetMax ((*st)->scrollbars[V])); - AdjustView (st); -} diff --git a/maccaml/windows.c b/maccaml/windows.c deleted file mode 100644 index 73d8b297fa..0000000000 --- a/maccaml/windows.c +++ /dev/null @@ -1,852 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Damien Doligez, projet Para, INRIA Rocquencourt */ -/* */ -/* Copyright 1998 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 file ../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include "main.h" - -WindowPtr winToplevel = NULL; -WindowPtr winGraphics = NULL; -long wintopfrontier = 0; - -static WELineBreakUPP charBreakUPP; - -/* WE hook for breaking line at char (not word) boundaries. */ -static pascal StyledLineBreakCode CharBreak - (Ptr pText, SInt32 textLength, SInt32 textStart, SInt32 textEnd, - Fixed *textWidth, SInt32 *textOffset, WEHandle hWE) -{ -#pragma unused (textLength, hWE) - long base = textStart; - long len = textEnd - textStart; - long l = 0; - long i; - short w; - short text_width = HiWord (*textWidth); - - while (len > 0){ - if (pText [base] == '\n'){ - *textOffset = base + 1; - return smBreakWord; - } - - l = len >= 128 ? 128 : len; - for (i = 0; i < l; i++){ - if (pText [base + i] == '\n') l = i; - } - - w = TextWidth (pText, base, l); - if (w > text_width){ - short locs [129]; - long i; - MeasureText (l, pText + base, (Ptr) locs); - for (i = 0; i < l; i++){ - if (locs [i+1] > text_width) break; - } - *textOffset = base + i; - return smBreakChar; - } - - len -= l; - base += l; - text_width -= w; - } - *textOffset = base; - *textWidth = FixRatio (text_width, 1); - return smBreakOverflow; -} - -static void UpdateToplevelRO (void) -{ - WEReference we = WinGetWE (winToplevel); - long selstart, selend; - - Assert (we != NULL); - WEGetSelection (&selstart, &selend, we); - if (selstart >= wintopfrontier){ - WEFeatureFlag (weFReadOnly, weBitClear, we); - }else{ - WEFeatureFlag (weFReadOnly, weBitSet, we); - } -} - -OSErr InitialiseWindows (void) -{ - charBreakUPP = NewWELineBreakProc (CharBreak); - return noErr; -} - -/* The window becomes active if [activate] is true, - inactive if false. -*/ -void WinActivateDeactivate (int activate, WindowPtr w) -{ - WStatusH st = WinGetStatus (w); - WEHandle we = WinGetWE (w); - VHSelect axis; - GrafPtr saveport; - - if (st == NULL) return; - - PushWindowPort (w); - - if (we != NULL){ - if (activate) WEActivate (we); else WEDeactivate (we); - } - for (axis = V; axis <= H; axis++){ - ControlHandle bar = (*st)->scrollbars[axis]; - if (bar != NULL){ - if (activate) ShowControl (bar); else HideControl (bar); - /* We sometimes get an activate without any previous deactivate. - In this case, ShowControl will do nothing, but the control - still needs to be redrawn. It will be done with the normal - update mechanism. In the normal case, the control will be - drawn twice, but what the hell. */ - /* ValidRect (&(*bar)->contrlRect); */ - } - } - /* There seems to be a bug in DrawGrowIcon that makes it draw an icon - for non-resizable windows when processing a suspend/resume event. - */ - if (GetWVariant (w) != noGrowDocProc) DrawGrowIcon (w); - - PopPort; -} - -void WinAdvanceTopFrontier (long length) -{ - wintopfrontier += length; - UpdateToplevelRO (); -} - -OSErr WinAllocStatus (WindowPtr w) -{ - WStatusH st = NULL; - OSErr err; - struct menuflags f; - - err = AllocHandle (sizeof (struct WStatus), (Handle *) &st); - if (err != noErr) return err; - HLock ((Handle) st); - (*st)->kind = kWinUninitialised; - (*st)->datarefnum = -1; - (*st)->resrefnum = -1; - (*st)->basemodcount = 0; - f.save = f.save_as = f.revert = f.page_setup = f.print = f.cut = f.copy = - f.paste = f.clear = f.select_all = f.find = f.replace = 0; - (*st)->menuflags = f; - (*st)->scrollbars [V] = NULL; - (*st)->scrollbars [H] = NULL; - /* XXX initialiser les rectangles */ - (*st)->line_height = 1; - (*st)->we = NULL; - HUnlock ((Handle) st); - SetWRefCon (w, (long) st); - return noErr; -} - -void WinCloseGraphics (void) -{ - Rect r; - GrafPtr saveport; - - Assert (winGraphics != NULL); - - PushWindowPort (winGraphics); - r = winGraphics->portRect; - LocalToGlobalRect (&r); - prefs.graphpos = r; - PopPort; - - DisposeWindow (winGraphics); - winGraphics = NULL; -} - -void WinCloseToplevel (void) -{ - Rect r; - GrafPtr saveport; - - if (winToplevel != NULL){ - PushWindowPort (winToplevel); - - r = winToplevel->portRect; - LocalToGlobalRect (&r); - prefs.toppos = r; - if (prefs.asksavetop){ - XXX (); - } - PopPort; - } - DisposeWindow (winToplevel); - winToplevel = NULL; -} - -void WinDoContentClick (EventRecord *event, WindowPtr w) -{ - int k = WinGetKind (w); - int inback = !IsWindowHilited (w); - - switch (k){ - - case kWinUnknown: - case kWinAbout: - case kWinClipboard: - if (inback) SelectWindow (w); - break; - - case kWinGraphics: { - Point hitPt = event->where; - GrafPtr saveport; - - PushWindowPort (w); - GlobalToLocal (&hitPt); - if (inback){ - SelectWindow (w); - }else{ - Rect r; - ScrollCalcGraph (w, &r); - if (PtInRect (hitPt, &r)){ - GraphGotEvent (event); - }else{ - ScrollDoClick (w, hitPt, event->modifiers); - } - } - PopPort; - break; - } - - case kWinToplevel: - case kWinDocument: { - int handleit = !inback; - GrafPtr saveport; - Point hitPt = event->where; - WEReference we = WinGetWE (w); - - Assert (we != NULL); - PushWindowPort (w); - GlobalToLocal (&hitPt); - - if (inback && gHasDragAndDrop){ - long selStart, selEnd; - RgnHandle selRgn; - - WEGetSelection (&selStart, &selEnd, we); - selRgn = WEGetHiliteRgn (selStart, selEnd, we); - handleit = PtInRgn (hitPt, selRgn) && WaitMouseMoved (event->where); - DisposeRgn (selRgn); - } - if (!handleit){ - SelectWindow (w); - }else{ - Rect r; - ScrollCalcText (w, &r); - InsetRect (&r, -kTextMarginH, 0); - if (PtInRect (hitPt, &r)){ - WEClick (hitPt, event->modifiers, event->when, we); - if (w == winToplevel) UpdateToplevelRO (); - }else{ - ScrollDoClick (w, hitPt, event->modifiers); - } - } - PopPort; - break; - } - - default: - Assert (0); /* There is no other window kind. */ - break; - } -} - -OSErr WinDoClose (ClosingOption close, WindowPtr w) -{ - int k = WinGetKind (w); - OSErr err; - WStatusH st; - WEHandle we; - - switch (k){ - - case kWinUnknown: - case kWinToplevel: - default: - Assert (0); - return noErr; - - case kWinAbout: - CloseAboutBox (w); - return noErr; - - case kWinGraphics: - HideWindow (winGraphics); - return noErr; - - case kWinDocument: - err = FileDoClose (w, close); - if (err != noErr) return err; - st = WinGetStatus (w); Assert (st != NULL); - we = WinGetWE (w); Assert (we != NULL); - LCDetach ((*st)->scrollbars[V]); - LCDetach ((*st)->scrollbars[H]); - WEDispose (we); - DisposeHandle ((Handle) st); - MenuWinRemove (w); - DisposeWindow (w); - return noErr; - - case kWinClipboard: - XXX (); - return noErr; - } -} - -void WinDoDrag (Point where, WindowPtr w) -{ - Rect limits; - - limits = (*GetGrayRgn ())->rgnBBox; - InsetRect (&limits, 4, 4); - DragWindow (w, where, &limits); - if (w == winGraphics) GraphNewSizePos (); -} - -/* Invalidate the bottom and right margins. */ -static void WinInvalMargins (WindowPtr w) -{ - Rect r; - - r = w->portRect; - r.right -= kScrollBarWidth; - r.left = r.right - kTextMarginH; - r.bottom -= kScrollBarWidth; - InvalRect (&r); - r = w->portRect; - r.bottom -= kScrollBarWidth; - r.top = r.bottom - kTextMarginV; - r.right -= kScrollBarWidth; - InvalRect (&r); -} - -static void WinGraphNewSize (WindowPtr w) -{ - Rect r; - WStatusH st = WinGetStatus (w); - - Assert (st != NULL); - ScrollCalcGraph (w, &r); - WERectToLongRect (&r, &(*st)->viewrect); -} - -static void WinWENewSize (WindowPtr w, WEReference we) -{ - Rect r; - LongRect lr; - - ScrollCalcText (w, &r); - WERectToLongRect (&r, &lr); - WESetViewRect (&lr, we); - WEGetDestRect (&lr, we); - if (lr.right - lr.left != r.right - r.left){ - lr.right = lr.left + r.right - r.left; - WESetDestRect (&lr, we); - WECalText (we); - InvalRect (&r); - } -} - -static void WinResize (WindowPtr w, short x, short y) -{ - GrafPtr saveport; - WEReference we = WinGetWE (w); - Rect r; - - PushWindowPort (w); - - /* Invalidate the old grow icon and the text margin. */ - r = w->portRect; - r.left = r.right - kScrollBarWidth; - r.top = r.bottom - kScrollBarWidth; - InvalRect (&r); - if (we != NULL) WinInvalMargins (w); - - SizeWindow (w, x, y, true); - - /* Redraw the controls and invalidate whatever is needed. */ - if (we != NULL){ - WinWENewSize (w, we); - WinInvalMargins (w); - } - if (w == winGraphics) WinGraphNewSize (w); - ScrollNewSize (w); - PopPort; -} - -void WinDoGrow (Point where, WindowPtr w) -{ - Rect r; - long newsize; - short x, y; - WStatusH st; - - switch (WinGetKind (w)){ - - case kWinUnknown: - case kWinAbout: - case kWinPrefs: - Assert (0); - break; - - case kWinToplevel: - case kWinDocument: - case kWinClipboard: - SetRect (&r, kMinWindowWidth, kMinWindowHeight, SHRT_MAX, SHRT_MAX); - break; - - case kWinGraphics: - st = WinGetStatus (w); - Assert (st != NULL); - x = (*st)->destrect.right - (*st)->destrect.left + kScrollBarWidth + 1; - y = (*st)->destrect.bottom - (*st)->destrect.top + kScrollBarWidth + 1; - SetRect (&r, kMinWindowWidth, kMinWindowHeight, x, y); - break; - } - newsize = GrowWindow (w, where, &r); - if (newsize != 0) WinResize (w, LoWord (newsize), HiWord (newsize)); -} - -void WinDoIdle (WindowPtr w) -{ - WEHandle we = WinGetWE (w); - - if (we != NULL) WEIdle (&evtSleep, we); else evtSleep = LONG_MAX; -} - -void WinDoKey (WindowPtr w, short chr, EventRecord *e) -{ - WEReference we; - long selstart, selend; - - switch (WinGetKind (w)){ - - case kWinToplevel: - we = WinGetWE (w); Assert (we != NULL); - WEGetSelection (&selstart, &selend, we); - if (chr == charBackspace || chr == charDelete){ - if (selstart < wintopfrontier || selend == wintopfrontier) break; - } - if (chr == charEnter){ - long sel = WEGetTextLength (we); - WESetSelection (sel, sel, we); - chr = charReturn; - } - if (chr != charArrowLeft && chr != charArrowRight - && chr != charArrowUp && chr != charArrowDown - && selstart < wintopfrontier){ - selstart = selend = WEGetTextLength (we); - WESetSelection (selstart, selend, we); - WEFeatureFlag (weFReadOnly, weBitClear, we); - } - if (selstart == selend){ - WESetStyle (weDoFont + weDoFace + weDoSize + weDoColor + weDoReplaceFace, - &prefs.unread, we); - } - /*XXX intercepter option-up/down, command-up/down, option-command-up/down */ - WEKey (chr, e->modifiers, we); - UpdateToplevelRO (); - break; - - case kWinDocument: - we = WinGetWE (w); Assert (we != NULL); - if (chr == charEnter){ - XXX (); /* XXX envoyer la phrase courante au toplevel */ - } - /*XXX intercepter option-up/down, command-up/down, option-command-up/down - -> myWEKey pour partager avec le toplevel */ - WEKey (chr, e->modifiers, we); - break; - - case kWinGraphics: - GraphGotEvent (e); - break; - - case kWinAbout: - CloseAboutBox (w); - break; - - case kWinPrefs: - XXX (); - break; - - case kWinClipboard: - break; - - default: - Assert (0); - break; - } -} - -void WinDoZoom (WindowPtr w, short partCode) -{ -#pragma unused (w, partCode) - XXX (); -} - -/* Return a pointer to the window's descriptor record, - NULL if there is none or w is NULL. -*/ -WStatusH WinGetStatus (WindowPtr w) -{ - WStatusH st; - short wk; - - if (w == NULL) return NULL; - wk = GetWindowKind (w); - if (wk != kApplicationWindowKind && wk != kDialogWindowKind) return NULL; - st = (WStatusH) GetWRefCon (w); - Assert (st != NULL); - return st; -} - -WEHandle WinGetWE (WindowPtr w) -{ - WStatusH st = WinGetStatus (w); - - if (st == NULL) return NULL; - return (*st)->we; -} - -int WinGetKind (WindowPtr w) -{ - WStatusH st = WinGetStatus (w); - - if (st == NULL) return kWinUnknown; - return (*st)->kind; -} - -/* Initialize all the data structures associated with a text - window: WE record and scroll bars. -*/ -static OSErr WinTextInit (WindowPtr w, TextStyle *style) -{ - OSErr err; - WEReference we = NULL; - WStatusH st = NULL; - Rect viewrect; - LongRect lviewrect, ldestrect; - WERunInfo runinfo; - int i; - ControlHandle bar; - - err = WinAllocStatus (w); - if (err != noErr) goto failed; - - st = WinGetStatus (w); Assert (st != NULL); - HLock ((Handle) st); - - ScrollCalcText (w, &viewrect); - WERectToLongRect (&viewrect, &lviewrect); - ldestrect = lviewrect; - ldestrect.right = ldestrect.left + ktextwidth; - err = WENew (&ldestrect, &lviewrect, - weDoAutoScroll + weDoOutlineHilite + weDoUndo - + weDoDragAndDrop + weDoUseTempMem + weDoDrawOffscreen - + weDoMonoStyled, - &we); - if (err != noErr) goto failed; - WESetAlignment (weFlushLeft, we); - WESetStyle (weDoFont + weDoFace + weDoSize + weDoColor + weDoReplaceFace, - style, we); - err = WESetInfo (weRefCon, &w, we); Assert (err == noErr); - err = WESetInfo (weScrollProc, &scrollFollowUPP, we); Assert (err == noErr); - err = WESetInfo (weLineBreakHook, &charBreakUPP, we); Assert (err == noErr); - /* XXX ajouter un hiliteDropAreaHook pour les marges asymetriques. */ - (*st)->we = we; - - WEGetRunInfo (0, &runinfo, we); - (*st)->line_height = runinfo.runHeight; - - (*st)->scrollbars [H] = (*st)->scrollbars [V] = NULL; - for (i = V; i <= H; i++){ - bar = GetNewControl (kScrollBarTemplate, w); - if (bar == NULL){ err = memFullErr; goto failed; } - err = LCAttach (bar); - if (err != noErr) goto failed; - (*st)->scrollbars [i] = bar; - } - - HUnlock ((Handle) st); - - WinWENewSize (w, we); - ScrollNewSize (w); - - return noErr; - - failed: - if (we != NULL) WEDispose (we); - if (st != NULL){ - if ((*st)->scrollbars [V] != NULL) LCDetach ((*st)->scrollbars[V]); - if ((*st)->scrollbars [H] != NULL) LCDetach ((*st)->scrollbars[H]); - DisposeHandle ((Handle) st); - } - return err; -} - -/* Open a new empty document window. - In case of failure, display an alert and return NULL. -*/ -WindowPtr WinOpenDocument (StringPtr name) -{ - WStatusH st = NULL; - WindowPtr w = NULL; - OSErr err; - - w = GetNewCWindow (kDocumentWinTemplate, NULL, (WindowPtr) -1L); - if (w == NULL){ err = memFullErr; goto failed; } - - SetWTitle (w, name); - ShowWindow (w); - SetPort (w); - - err = WinTextInit (w, &prefs.text); - if (err != noErr) goto failed; - - st = WinGetStatus (w); Assert (st != NULL); - (*st)->kind = kWinDocument; - (*st)->menuflags.save_as = (*st)->menuflags.page_setup = - (*st)->menuflags.print = (*st)->menuflags.paste = (*st)->menuflags.find = - (*st)->menuflags.replace = 1; - - err = MenuWinAdd (w); - if (err != noErr) goto failed; - - return w; - - failed: - if (w != NULL) DisposeWindow (w); /* Also deallocates the scroll bars. */ - ErrorAlertGeneric (err); - return NULL; -} - -OSErr WinOpenGraphics (long width, long height) -{ - WindowPtr w = NULL; - WStatusH st = NULL; - OSErr err; - Rect r; - int i; - ControlHandle bar; - long ww, hh; - - w = GetNewCWindow (kGraphicsWinTemplate, NULL, (WindowPtr) -1L); - if (w == NULL){ err = memFullErr; goto failed; } - - /*XXX Calculer si la fenetre est hors de l'ecran -> stdstate */ - MoveWindow (w, prefs.graphpos.left, prefs.graphpos.top, false); - ww = prefs.graphpos.right - prefs.graphpos.left; - hh = prefs.graphpos.bottom - prefs.graphpos.top; - if (ww < kMinWindowWidth) ww = kMinWindowWidth; - if (ww > width + kScrollBarWidth) ww = width + kScrollBarWidth; - if (hh < kMinWindowHeight) hh = kMinWindowHeight; - if (hh > height + kScrollBarWidth) hh = height + kScrollBarWidth; - SizeWindow (w, ww, hh, false); - ShowWindow (w); - SetPort (w); - - err = WinAllocStatus (w); - if (err != noErr) goto failed; - - st = WinGetStatus (w); Assert (st != NULL); - HLock ((Handle) st); - - ScrollCalcGraph (w, &r); - WERectToLongRect (&r, &(*st)->viewrect); - r.right = r.left + width; - r.bottom = r.top + height; - WERectToLongRect (&r, &(*st)->destrect); - st = WinGetStatus (w); Assert (st != NULL); - (*st)->kind = kWinGraphics; - (*st)->menuflags.save_as = (*st)->menuflags.page_setup = - (*st)->menuflags.print = 1; - - (*st)->scrollbars [H] = (*st)->scrollbars [V] = NULL; - for (i = V; i <= H; i++){ - bar = GetNewControl (kScrollBarTemplate, w); - if (bar == NULL){ err = memFullErr; goto failed; } - err = LCAttach (bar); - if (err != noErr) goto failed; - (*st)->scrollbars [i] = bar; - } - - HUnlock ((Handle) st); - - ScrollNewSize (w); - winGraphics = w; - return noErr; - - failed: - if (st != NULL){ - if ((*st)->scrollbars [V] != NULL) LCDetach ((*st)->scrollbars[V]); - if ((*st)->scrollbars [H] != NULL) LCDetach ((*st)->scrollbars[H]); - DisposeHandle ((Handle) st); - } - winGraphics = NULL; - if (w != NULL) DisposeWindow (w); /* Also deallocates the scroll bars. */ - return err; -} - -OSErr WinOpenToplevel (void) -{ - WindowPtr w = NULL; - WStatusH st = NULL; - WEHandle we = NULL; - OSErr err; - - /* Open the toplevel behind all other windows. */ - w = GetNewCWindow (kToplevelWinTemplate, NULL, NULL); - if (w == NULL){ err = memFullErr; goto failed; } - - /*XXX Calculer si la fenetre est hors de l'ecran -> stdstate */ - MoveWindow (w, prefs.toppos.left, prefs.toppos.top, false); - SizeWindow (w, prefs.toppos.right - prefs.toppos.left, - prefs.toppos.bottom - prefs.toppos.top, false); - ShowWindow (w); - SetPort (w); - - err = WinTextInit (w, &prefs.unread); - if (err != noErr) goto failed; - - st = WinGetStatus (w); Assert (st != NULL); - (*st)->kind = kWinToplevel; - (*st)->menuflags.save_as = (*st)->menuflags.page_setup = - (*st)->menuflags.print = (*st)->menuflags.find = 1; - - we = WinGetWE (w); Assert (we != NULL); - WEFeatureFlag (weFUndo, weBitClear, we); - WEFeatureFlag (weFMonoStyled, weBitClear, we); - - winToplevel = w; - return noErr; - - failed: - winToplevel = NULL; - if (w != NULL) DisposeWindow (w); /* Also deallocates the scroll bars. */ - ErrorAlertGeneric (err); - return err; -} - -void WinClipboardStdState (Rect *r) -{ - *r = (*GetGrayRgn ())->rgnBBox; - r->bottom -= kWinBorderSpace; - r->top = r->bottom - kMinWindowHeight; - r->left += kWinBorderSpace; - r->right -= 100; -} - -void WinGraphicsStdState (Rect *r) -{ - if (winGraphics == NULL){ - *r = (*GetGrayRgn ())->rgnBBox; - r->top += kTitleBarSpace; - r->left += kWinBorderSpace; - r->bottom -= kWinBorderSpace; - r->right -= kWinBorderSpace; - }else{ - /* XXX To do for zoom */ - Assert (0); - } -} - -void WinToplevelStdState (Rect *r) -{ - *r = (*GetGrayRgn ())->rgnBBox; - r->top += kTitleBarSpace; - r->bottom -= kPowerStripSpace; - r->left += kWinBorderSpace; - if (r->right > r->left + 506) r->right = r->left + 506; -} - -void WinUpdate (WindowPtr w) -{ - int k = WinGetKind (w); - WEHandle we = WinGetWE (w); - GrafPtr saveport; - RgnHandle updateRgn; - - Assert (k != kWinUnknown); - - PushWindowPort (w); - BeginUpdate (w); - updateRgn = w->visRgn; - if (!EmptyRgn (updateRgn)){ - EraseRgn (updateRgn); - UpdateControls (w, updateRgn); - DrawGrowIcon (w); - if (k == kWinGraphics) GraphUpdate (); - if (we != NULL) WEUpdate (updateRgn, we); - } - EndUpdate (w); - PopPort; -} - -void WinUpdateStatus (WindowPtr w) -{ - long selstart, selend; - WStatusH st = WinGetStatus (w); - WEHandle we = WinGetWE (w); - int readonly; - - if (st == NULL) return; - switch ((*st)->kind){ - case kWinUnknown: - case kWinAbout: - case kWinPrefs: - case kWinClipboard: - case kWinGraphics: - break; - case kWinToplevel: - Assert (we != NULL); - WEGetSelection (&selstart, &selend, we); - if (selend == selstart){ - (*st)->menuflags.cut = 0; - (*st)->menuflags.copy = 0; - (*st)->menuflags.clear = 0; - }else{ - (*st)->menuflags.copy = 1; - (*st)->menuflags.cut = (*st)->menuflags.clear = - selstart >= wintopfrontier; - } - (*st)->menuflags.select_all = WEGetTextLength (we) != 0; - readonly = WEFeatureFlag (weFReadOnly, weBitTest, we); - WEFeatureFlag (weFReadOnly, weBitClear, we); - (*st)->menuflags.paste = WECanPaste (we); - if (readonly) WEFeatureFlag (weFReadOnly, weBitSet, we); - break; - case kWinDocument: - Assert (we != NULL); - WEGetSelection (&selstart, &selend, we); - (*st)->menuflags.save = (*st)->menuflags.revert = - (*st)->basemodcount != WEGetModCount (we); - (*st)->menuflags.cut = (*st)->menuflags.copy = (*st)->menuflags.clear = - selstart != selend; - (*st)->menuflags.paste = WECanPaste (we); - (*st)->menuflags.select_all = WEGetTextLength (we) != 0; - break; - case kWinUninitialised: - default: - Assert (0); - break; - } -} diff --git a/man/Makefile b/man/Makefile deleted file mode 100644 index 4753c202ea..0000000000 --- a/man/Makefile +++ /dev/null @@ -1,22 +0,0 @@ -######################################################################### -# # -# Objective Caml # -# # -# Xavier Leroy, projet Cristal, INRIA Rocquencourt # -# # -# Copyright 1999 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### - -# $Id$ - -include ../config/Makefile - -DIR=$(MANDIR)/man$(MANEXT) - -install: - for i in *.m; do cp $$i $(DIR)/`basename $$i .m`.$(MANEXT); done - echo '.so man$(MANEXT)/ocamlc.$(MANEXT)' > $(DIR)/ocamlc.opt.$(MANEXT) - echo '.so man$(MANEXT)/ocamlopt.$(MANEXT)' > $(DIR)/ocamlopt.opt.$(MANEXT) diff --git a/man/ocaml.help b/man/ocaml.help deleted file mode 100644 index 466896dcc7..0000000000 --- a/man/ocaml.help +++ /dev/null @@ -1,138 +0,0 @@ -- -OCaml # Objective Caml toplevel -Usage: ocaml -options are: - -I Add to the list of include directories - -unsafe No bound checking on array and string access - -drawlambda (undocumented) - -dlambda (undocumented) - -dinstr (undocumented) - -rectypes (undocumented) - -- -OCamlc # Objective Caml compiler -Usage: ocamlc -Options are: - -a Build a library - -c Compile only (do not link) - -cc Use as the C compiler and linker - -cclib Pass option to the C linker - -ccopt Pass option to the C compiler and linker - -g Save debugging information - -i Print the types - -I Add to the list of include directories - -impl Compile as a .ml file - -intf Compile as a .mli file - -intf-suffix Suffix for interface file (default: .mli) - -intf_suffix (deprecated) same as -intf-suffix - -linkall Link all modules, even unused ones - -make-runtime Build a runtime system with given C objects and libraries - -make_runtime (deprecated) same as -make-runtime - -noassert Do not compile assertion checks - -o Set output file name to - -output-obj Output a C object file instead of an executable - -pp Pipe sources through preprocessor - -thread Use thread-safe standard library - -unsafe No bounds checking on array and string access - -use-runtime Generate bytecode for the given runtime system - -use_runtime (deprecated) same as -use-runtime - -v Print compiler version number - -verbose Print calls to external commands - -w Enable or disable warnings according to : - A/a enable/disable all warnings - C/c enable/disable suspicious comment - F/f enable/disable partially applied function - M/m enable/disable overriden method - P/p enable/disable partial match - S/s enable/disable non-unit statement - U/u enable/disable unused match case - V/v enable/disable hidden instance variable - X/x enable/disable all other warnings - default setting is A (all warnings enabled) - -nopervasives (undocumented) - -dparsetree (undocumented) - -drawlambda (undocumented) - -dlambda (undocumented) - -dinstr (undocumented) - -use-prims (undocumented) - -rectypes (undocumented) - - Treat as a file name (even if it starts with `-') - -- -OCamlc-custom # Objective Caml compiler for custom runtime mode -Usage: ocamlc-custom -Options are: - -a Build a library - -c Compile only (do not link) - -cc Use as the C compiler and linker - -cclib Pass option to the C linker - -ccopt Pass option to the C compiler and linker - -g Save debugging information - -i Print the types - -I Add to the list of include directories - -impl Compile as a .ml file - -intf Compile as a .mli file - -intf-suffix Suffix for interface file (default: .mli) - -intf_suffix (deprecated) same as -intf-suffix - -linkall Link all modules, even unused ones - -make-runtime Build a runtime system with given C objects and libraries - -make_runtime (deprecated) same as -make-runtime - -noassert Do not compile assertion checks - -o Set output file name to - -output-obj Output a C object file instead of an executable - -pp Pipe sources through preprocessor - -thread Use thread-safe standard library - -unsafe No bounds checking on array and string access - -use-runtime Generate bytecode for the given runtime system - -use_runtime (deprecated) same as -use-runtime - -v Print compiler version number - -verbose Print calls to external commands - -w Enable or disable warnings according to : - A/a enable/disable all warnings - C/c enable/disable suspicious comment - F/f enable/disable partially applied function - M/m enable/disable overriden method - P/p enable/disable partial match - S/s enable/disable non-unit statement - U/u enable/disable unused match case - V/v enable/disable hidden instance variable - X/x enable/disable all other warnings - default setting is A (all warnings enabled) - -nopervasives (undocumented) - -dparsetree (undocumented) - -drawlambda (undocumented) - -dlambda (undocumented) - -dinstr (undocumented) - -use-prims (undocumented) - -rectypes (undocumented) - - Treat as a file name (even if it starts with `-') - -- -OCamlDep # Objective Caml dependency generator -Usage: ocamldep [-I ] - -I Add to the list of include directories - -- -OCamlLex # Objective Caml lexer generator -OCamlLex name.mll - -- -OCamlRun # Objective Caml bytecode interpreter -OCamlRun [-v] file [argumentsÉ] - -v # print GC messages - -Environment variable: -Set -e OCamlRunParam "