From fa164163e679d9d3c683f8442008bb03745d0e89 Mon Sep 17 00:00:00 2001 From: Sven Luther Date: Thu, 7 Aug 2003 12:13:58 +0000 Subject: [PATCH] Imported Upstream version 3.06.99.beta1 --- .cvsignore | 14 + .depend | 772 +++ Changes | 1644 ++++++ INSTALL | 260 + INSTALL.MPW | 89 + LICENSE | 618 +++ Makefile | 671 +++ Makefile.Mac | 488 ++ Makefile.Mac.depend | 548 ++ Makefile.nt | 614 +++ README | 144 + README.win32 | 246 + Upgrading | 109 + asmcomp/.cvsignore | 6 + asmcomp/alpha/arch.ml | 83 + asmcomp/alpha/emit.mlp | 862 +++ asmcomp/alpha/proc.ml | 217 + asmcomp/alpha/reload.ml | 18 + asmcomp/alpha/scheduling.ml | 70 + asmcomp/alpha/selection.ml | 83 + asmcomp/amd64/arch.ml | 105 + asmcomp/amd64/emit.mlp | 682 +++ asmcomp/amd64/proc.ml | 199 + asmcomp/amd64/reload.ml | 113 + asmcomp/amd64/scheduling.ml | 20 + asmcomp/amd64/selection.ml | 229 + asmcomp/arm/arch.ml | 86 + asmcomp/arm/emit.mlp | 678 +++ asmcomp/arm/proc.ml | 196 + asmcomp/arm/reload.ml | 18 + asmcomp/arm/scheduling.ml | 53 + asmcomp/arm/selection.ml | 132 + asmcomp/asmgen.ml | 113 + asmcomp/asmgen.mli | 24 + asmcomp/asmlibrarian.ml | 74 + asmcomp/asmlibrarian.mli | 27 + asmcomp/asmlink.ml | 360 ++ asmcomp/asmlink.mli | 37 + asmcomp/asmpackager.ml | 315 ++ asmcomp/asmpackager.mli | 30 + asmcomp/clambda.ml | 66 + asmcomp/clambda.mli | 66 + asmcomp/closure.ml | 737 +++ asmcomp/closure.mli | 18 + asmcomp/cmm.ml | 132 + asmcomp/cmm.mli | 118 + asmcomp/cmmgen.ml | 1839 +++++++ asmcomp/cmmgen.mli | 27 + asmcomp/codegen.ml | 101 + asmcomp/codegen.mli | 29 + asmcomp/coloring.ml | 299 ++ asmcomp/coloring.mli | 17 + asmcomp/comballoc.ml | 89 + asmcomp/comballoc.mli | 17 + asmcomp/compilenv.ml | 169 + asmcomp/compilenv.mli | 82 + asmcomp/emit.mli | 20 + asmcomp/emitaux.ml | 88 + asmcomp/emitaux.mli | 26 + asmcomp/hppa/arch.ml | 74 + asmcomp/hppa/emit.mlp | 1103 ++++ asmcomp/hppa/proc.ml | 223 + asmcomp/hppa/reload.ml | 18 + asmcomp/hppa/scheduling.ml | 59 + asmcomp/hppa/selection.ml | 109 + asmcomp/i386/arch.ml | 147 + asmcomp/i386/emit.mlp | 871 +++ asmcomp/i386/emit_nt.mlp | 865 +++ asmcomp/i386/proc.ml | 176 + asmcomp/i386/proc_nt.ml | 178 + asmcomp/i386/reload.ml | 83 + asmcomp/i386/scheduling.ml | 22 + asmcomp/i386/selection.ml | 310 ++ asmcomp/ia64/arch.ml | 88 + asmcomp/ia64/emit.mlp | 1326 +++++ asmcomp/ia64/proc.ml | 216 + asmcomp/ia64/reload.ml | 18 + asmcomp/ia64/scheduling.ml | 20 + asmcomp/ia64/selection.ml | 175 + asmcomp/interf.ml | 209 + asmcomp/interf.mli | 18 + asmcomp/linearize.ml | 262 + asmcomp/linearize.mli | 54 + asmcomp/liveness.ml | 120 + asmcomp/liveness.mli | 20 + asmcomp/m68k/README | 8 + asmcomp/mach.ml | 128 + asmcomp/mach.mli | 92 + asmcomp/mips/arch.ml | 71 + asmcomp/mips/emit.mlp | 594 +++ asmcomp/mips/proc.ml | 211 + asmcomp/mips/reload.ml | 18 + asmcomp/mips/scheduling.ml | 20 + asmcomp/mips/selection.ml | 43 + asmcomp/power/arch.ml | 101 + asmcomp/power/emit.mlp | 1099 ++++ asmcomp/power/proc.ml | 252 + asmcomp/power/reload.ml | 18 + asmcomp/power/scheduling.ml | 66 + asmcomp/power/selection.ml | 107 + asmcomp/printcmm.ml | 203 + asmcomp/printcmm.mli | 27 + asmcomp/printlinear.ml | 74 + asmcomp/printlinear.mli | 21 + asmcomp/printmach.ml | 217 + asmcomp/printmach.mli | 31 + asmcomp/proc.mli | 50 + asmcomp/reg.ml | 144 + asmcomp/reg.mli | 56 + asmcomp/reload.mli | 18 + asmcomp/reloadgen.ml | 140 + asmcomp/reloadgen.mli | 26 + asmcomp/schedgen.ml | 358 ++ asmcomp/schedgen.mli | 46 + asmcomp/scheduling.mli | 17 + asmcomp/selectgen.ml | 821 +++ asmcomp/selectgen.mli | 67 + asmcomp/selection.mli | 18 + asmcomp/sparc/arch.ml | 75 + asmcomp/sparc/emit.mlp | 752 +++ asmcomp/sparc/proc.ml | 214 + asmcomp/sparc/reload.ml | 18 + asmcomp/sparc/scheduling.ml | 65 + asmcomp/sparc/selection.ml | 86 + asmcomp/spill.ml | 403 ++ asmcomp/spill.mli | 18 + asmcomp/split.ml | 210 + asmcomp/split.mli | 17 + 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 | 178 + 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 0 -> 916988 bytes boot/ocamllex | Bin 0 -> 146250 bytes bytecomp/.cvsignore | 2 + bytecomp/bytegen.ml | 837 +++ bytecomp/bytegen.mli | 21 + bytecomp/bytelibrarian.ml | 122 + bytecomp/bytelibrarian.mli | 34 + bytecomp/bytelink.ml | 575 ++ bytecomp/bytelink.mli | 36 + bytecomp/bytepackager.ml | 224 + bytecomp/bytepackager.mli | 29 + bytecomp/bytesections.ml | 93 + bytecomp/bytesections.mli | 51 + bytecomp/dll.ml | 168 + bytecomp/dll.mli | 55 + bytecomp/emitcode.ml | 437 ++ bytecomp/emitcode.mli | 85 + bytecomp/instruct.ml | 108 + bytecomp/instruct.mli | 123 + bytecomp/lambda.ml | 337 ++ bytecomp/lambda.mli | 199 + bytecomp/matching.ml | 2547 +++++++++ bytecomp/matching.mli | 37 + bytecomp/meta.ml | 23 + bytecomp/meta.mli | 25 + bytecomp/printinstr.ml | 111 + bytecomp/printinstr.mli | 22 + bytecomp/printlambda.ml | 299 ++ bytecomp/printlambda.mli | 20 + bytecomp/runtimedef.mli | 18 + bytecomp/simplif.ml | 412 ++ bytecomp/simplif.mli | 19 + bytecomp/switch.ml | 812 +++ bytecomp/switch.mli | 82 + bytecomp/symtable.ml | 349 ++ bytecomp/symtable.mli | 57 + bytecomp/translclass.ml | 334 ++ bytecomp/translclass.mli | 29 + bytecomp/translcore.ml | 902 ++++ bytecomp/translcore.mli | 48 + bytecomp/translmod.ml | 684 +++ bytecomp/translmod.mli | 38 + bytecomp/translobj.ml | 62 + bytecomp/translobj.mli | 20 + bytecomp/typeopt.ml | 133 + bytecomp/typeopt.mli | 22 + byterun/.cvsignore | 14 + byterun/.depend | 249 + byterun/Makefile | 110 + byterun/Makefile.Mac | 118 + byterun/Makefile.Mac.depend | 1180 +++++ byterun/Makefile.nt | 105 + byterun/alloc.c | 164 + byterun/alloc.h | 44 + byterun/array.c | 197 + byterun/backtrace.c | 212 + byterun/backtrace.h | 15 + byterun/callback.c | 211 + byterun/callback.h | 47 + byterun/compact.c | 433 ++ byterun/compact.h | 27 + byterun/compare.c | 255 + byterun/config.h | 146 + byterun/custom.c | 100 + byterun/custom.h | 55 + byterun/debugger.c | 338 ++ byterun/debugger.h | 112 + byterun/dynlink.c | 251 + byterun/dynlink.h | 34 + byterun/exec.h | 62 + byterun/extern.c | 623 +++ byterun/fail.c | 137 + byterun/fail.h | 76 + byterun/finalise.c | 182 + byterun/finalise.h | 24 + byterun/fix_code.c | 162 + byterun/fix_code.h | 42 + byterun/floats.c | 406 ++ byterun/freelist.c | 316 ++ byterun/freelist.h | 35 + byterun/gc.h | 55 + byterun/gc_ctrl.c | 428 ++ byterun/gc_ctrl.h | 42 + byterun/globroots.c | 129 + byterun/globroots.h | 40 + byterun/hash.c | 156 + byterun/instrtrace.c | 77 + byterun/instrtrace.h | 31 + byterun/instruct.h | 55 + byterun/int64_emul.h | 259 + byterun/int64_format.h | 102 + byterun/int64_native.h | 44 + byterun/intern.c | 706 +++ byterun/interp.c | 1053 ++++ byterun/interp.h | 28 + byterun/intext.h | 174 + byterun/ints.c | 690 +++ byterun/io.c | 753 +++ byterun/io.h | 112 + byterun/lexing.c | 231 + byterun/macintosh.c | 319 ++ byterun/macintosh.h | 19 + byterun/main.c | 46 + byterun/major_gc.c | 458 ++ byterun/major_gc.h | 73 + byterun/md5.c | 309 ++ byterun/md5.h | 41 + byterun/memory.c | 360 ++ byterun/memory.h | 377 ++ byterun/meta.c | 160 + byterun/minor_gc.c | 266 + byterun/minor_gc.h | 46 + byterun/misc.c | 139 + byterun/misc.h | 142 + byterun/mlvalues.h | 299 ++ byterun/mpwtool.c | 39 + byterun/obj.c | 160 + byterun/osdeps.h | 64 + byterun/parsing.c | 290 + byterun/prims.h | 33 + byterun/printexc.c | 138 + byterun/printexc.h | 27 + byterun/reverse.h | 88 + byterun/roots.c | 111 + byterun/roots.h | 38 + byterun/rotatecursor.c | 120 + byterun/rotatecursor.h | 124 + byterun/signals.c | 295 ++ byterun/signals.h | 45 + byterun/stacks.c | 102 + byterun/stacks.h | 43 + byterun/startup.c | 456 ++ byterun/startup.h | 21 + byterun/str.c | 149 + byterun/sys.c | 349 ++ byterun/sys.h | 29 + byterun/terminfo.c | 132 + byterun/ui.h | 23 + byterun/unix.c | 377 ++ byterun/weak.c | 122 + byterun/weak.h | 20 + byterun/win32.c | 392 ++ camlp4/CHANGES | 751 +++ camlp4/ICHANGES | 17 + 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 | 866 +++ 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 | 478 ++ 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 | 26 + camlp4/config/.cvsignore | 2 + camlp4/config/Makefile-nt.cnf | 0 camlp4/config/Makefile.tpl | 28 + camlp4/config/config.mpw | 50 + camlp4/config/configure_batch | 111 + camlp4/etc/.cvsignore | 6 + camlp4/etc/.depend | 67 + camlp4/etc/Makefile | 99 + 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 | 24 + 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 | 1275 +++++ 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 | 322 ++ camlp4/etc/pr_extend.ml | 514 ++ camlp4/etc/pr_extfun.ml | 92 + camlp4/etc/pr_null.ml | 16 + camlp4/etc/pr_o.ml | 2060 ++++++++ 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 | 52 + 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 | 993 ++++ camlp4/lib/plexer.mli | 72 + camlp4/lib/stdpp.ml | 79 + camlp4/lib/stdpp.mli | 37 + camlp4/lib/token.ml | 225 + camlp4/lib/token.mli | 128 + 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 | 14 + 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 | 936 ++++ camlp4/meta/pa_rp.ml | 318 ++ camlp4/meta/pr_dump.ml | 52 + camlp4/meta/q_MLast.ml | 1479 ++++++ 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 | 840 +++ camlp4/ocaml_src/camlp4/ast2pt.mli | 23 + camlp4/ocaml_src/camlp4/mLast.mli | 208 + 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 | 333 ++ 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 | 52 + 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 | 1221 +++++ 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 | 220 + camlp4/ocaml_src/lib/token.mli | 128 + camlp4/ocaml_src/meta/.cvsignore | 2 + camlp4/ocaml_src/meta/.depend | 14 + camlp4/ocaml_src/meta/Makefile | 51 + 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 | 2830 ++++++++++ camlp4/ocaml_src/meta/pa_rp.ml | 641 +++ camlp4/ocaml_src/meta/pr_dump.ml | 48 + camlp4/ocaml_src/meta/q_MLast.ml | 4687 +++++++++++++++++ camlp4/ocaml_src/odyl/.cvsignore | 2 + camlp4/ocaml_src/odyl/.depend | 6 + camlp4/ocaml_src/odyl/Makefile | 60 + 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 | 28 + camlp4/tools/camlp4_comm.mpw | 53 + camlp4/tools/camlp4_comm.sh | 37 + 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 | 12 + 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 | 589 +++ camlp4/top/rprint.ml | 414 ++ 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/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 | 72 + config/auto-aux/tclversion.c | 7 + 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 | 1522 ++++++ debugger/.cvsignore | 4 + debugger/.depend | 186 + debugger/Makefile | 113 + debugger/breakpoints.ml | 237 + debugger/breakpoints.mli | 61 + debugger/checkpoints.ml | 85 + debugger/checkpoints.mli | 58 + debugger/command_line.ml | 1071 ++++ 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/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 | 118 + 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 | 109 + 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 | 54 + emacs/README | 198 + emacs/README.itz | 177 + emacs/caml-compat.el | 28 + emacs/caml-font.el | 125 + emacs/caml-help.el | 799 +++ emacs/caml-hilit.el | 53 + emacs/caml-types.el | 196 + emacs/caml.el | 1840 +++++++ 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 | 145 + lex/common.mli | 23 + 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 | 101 + lex/output.ml | 138 + lex/output.mli | 25 + lex/outputbis.ml | 188 + lex/outputbis.mli | 21 + lex/parser.mly | 176 + 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 | 45 + man/ocamlmktop.m | 85 + man/ocamlopt.m | 230 + man/ocamlprof.m | 57 + man/ocamlrun.m | 130 + man/ocamlyacc.m | 71 + ocamldoc/.cvsignore | 13 + ocamldoc/.depend | 222 + ocamldoc/Changes.txt | 84 + ocamldoc/Makefile | 352 ++ ocamldoc/Makefile.nt | 344 ++ ocamldoc/ocamldoc.hva | 10 + ocamldoc/ocamldoc.sty | 60 + ocamldoc/odoc.ml | 126 + ocamldoc/odoc_analyse.ml | 446 ++ ocamldoc/odoc_analyse.mli | 31 + ocamldoc/odoc_args.ml | 301 ++ ocamldoc/odoc_args.mli | 177 + ocamldoc/odoc_ast.ml | 1504 ++++++ ocamldoc/odoc_ast.mli | 103 + ocamldoc/odoc_class.ml | 251 + ocamldoc/odoc_comments.ml | 312 ++ ocamldoc/odoc_comments.mli | 56 + ocamldoc/odoc_comments_global.ml | 46 + ocamldoc/odoc_comments_global.mli | 46 + ocamldoc/odoc_control.ml | 13 + ocamldoc/odoc_cross.ml | 812 +++ ocamldoc/odoc_cross.mli | 16 + ocamldoc/odoc_dag2html.ml | 1755 ++++++ ocamldoc/odoc_dag2html.mli | 30 + ocamldoc/odoc_dep.ml | 217 + ocamldoc/odoc_dot.ml | 128 + ocamldoc/odoc_env.ml | 242 + ocamldoc/odoc_env.mli | 75 + ocamldoc/odoc_exception.ml | 30 + ocamldoc/odoc_global.ml | 21 + ocamldoc/odoc_global.mli | 18 + ocamldoc/odoc_html.ml | 1939 +++++++ ocamldoc/odoc_info.ml | 214 + ocamldoc/odoc_info.mli | 979 ++++ ocamldoc/odoc_inherit.ml | 13 + ocamldoc/odoc_latex.ml | 953 ++++ ocamldoc/odoc_latex_style.ml | 74 + ocamldoc/odoc_lexer.mll | 409 ++ ocamldoc/odoc_man.ml | 934 ++++ ocamldoc/odoc_merge.ml | 939 ++++ ocamldoc/odoc_merge.mli | 31 + ocamldoc/odoc_messages.ml | 303 ++ ocamldoc/odoc_misc.ml | 484 ++ ocamldoc/odoc_misc.mli | 115 + ocamldoc/odoc_module.ml | 504 ++ ocamldoc/odoc_name.ml | 161 + ocamldoc/odoc_name.mli | 65 + ocamldoc/odoc_ocamlhtml.mll | 542 ++ ocamldoc/odoc_opt.ml | 82 + ocamldoc/odoc_parameter.ml | 130 + ocamldoc/odoc_parser.mly | 156 + ocamldoc/odoc_scan.ml | 154 + ocamldoc/odoc_search.ml | 629 +++ ocamldoc/odoc_search.mli | 198 + ocamldoc/odoc_see_lexer.mll | 100 + ocamldoc/odoc_sig.ml | 1317 +++++ ocamldoc/odoc_sig.mli | 175 + ocamldoc/odoc_str.ml | 128 + ocamldoc/odoc_str.mli | 28 + ocamldoc/odoc_texi.ml | 1172 +++++ ocamldoc/odoc_text.ml | 30 + ocamldoc/odoc_text.mli | 20 + ocamldoc/odoc_text_lexer.mll | 708 +++ ocamldoc/odoc_text_parser.mly | 213 + ocamldoc/odoc_to_text.ml | 519 ++ ocamldoc/odoc_type.ml | 50 + ocamldoc/odoc_types.ml | 129 + ocamldoc/odoc_types.mli | 128 + ocamldoc/odoc_value.ml | 132 + 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 | 1000 ++++ 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 | 24 + 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 | 75 + 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 | 869 +++ 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 + .../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 + .../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 + .../labltk/builtin/builtini_GetBitmap.ml | 28 + .../labltk/builtin/builtini_GetCursor.ml | 55 + otherlibs/labltk/builtin/builtini_GetPixel.ml | 43 + .../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 + .../labltk/builtin/selection_handle_set.ml | 41 + .../labltk/builtin/selection_handle_set.mli | 13 + otherlibs/labltk/builtin/selection_own_set.ml | 29 + .../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/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 + .../labltk/examples_camltk/helloworld.ml | 37 + .../examples_camltk/images/CamlBook.gif | Bin 0 -> 15168 bytes .../examples_camltk/images/Lambda2.back.gif | Bin 0 -> 53442 bytes .../examples_camltk/images/dojoji.back.gif | Bin 0 -> 49935 bytes otherlibs/labltk/examples_camltk/jptest.ml | 23 + otherlibs/labltk/examples_camltk/mytext.ml | 63 + .../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 + .../labltk/examples_labltk/Lambda2.back.gif | Bin 0 -> 53442 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 0 -> 1533 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 0 -> 18501 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 | 28 + otherlibs/num/.depend.nt | 56 + otherlibs/num/Makefile | 90 + otherlibs/num/Makefile.Mac | 64 + otherlibs/num/Makefile.Mac.depend | 33 + otherlibs/num/Makefile.nt | 101 + otherlibs/num/README | 64 + 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/bignum/Makefile | 343 ++ otherlibs/num/bignum/Makefile.Mac | 78 + otherlibs/num/bignum/Makefile.nt | 87 + otherlibs/num/bignum/README | 97 + otherlibs/num/bignum/c/KerN.c | 860 +++ otherlibs/num/bignum/c/bn/bnCmp.c | 77 + otherlibs/num/bignum/c/bn/bnDivide.c | 156 + otherlibs/num/bignum/c/bn/bnInit.c | 74 + otherlibs/num/bignum/c/bn/bnMult.c | 84 + otherlibs/num/bignum/c/bz.c | 833 +++ otherlibs/num/bignum/c/bzf.c | 50 + otherlibs/num/bignum/c/bztest.c | 167 + otherlibs/num/bignum/c/testKerN.c | 1085 ++++ otherlibs/num/bignum/h/BigNum.h | 144 + otherlibs/num/bignum/h/BigZ.h | 97 + otherlibs/num/bignum/h/BntoBnn.h | 105 + otherlibs/num/bignum/o/.cvsignore | 1 + otherlibs/num/bignum/o/EMPTY | 0 otherlibs/num/bignum/s/68KerN.s | 403 ++ otherlibs/num/bignum/s/68KerN_mot.s | 410 ++ otherlibs/num/bignum/s/68KerN_sony.s | 426 ++ otherlibs/num/bignum/s/RS6000KerN.s | 468 ++ otherlibs/num/bignum/s/alphaKerN.s | 2511 +++++++++ otherlibs/num/bignum/s/hpKerN.s | 814 +++ otherlibs/num/bignum/s/i960KerN.s | 928 ++++ otherlibs/num/bignum/s/mipsKerN.s | 1382 +++++ otherlibs/num/bignum/s/nsKerN.s | 427 ++ otherlibs/num/bignum/s/pyramidKerN.s | 454 ++ otherlibs/num/bignum/s/sparcKerN.s | 643 +++ otherlibs/num/bignum/s/sparcfpuKerN.s | 741 +++ otherlibs/num/bignum/s/supersparcKerN.s | 472 ++ otherlibs/num/bignum/s/unix2vms.sed | 28 + otherlibs/num/bignum/s/vaxKerN.mar | 701 +++ otherlibs/num/bignum/s/vaxKerN.s | 700 +++ otherlibs/num/bignum/s/x86KerN.s | 520 ++ otherlibs/num/int_misc.ml | 36 + otherlibs/num/int_misc.mli | 25 + otherlibs/num/nat.h | 19 + otherlibs/num/nat.ml | 564 ++ otherlibs/num/nat.mli | 71 + otherlibs/num/nat_stubs.c | 334 ++ 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 | 56 + otherlibs/num/test/Makefile.Mac | 40 + otherlibs/num/test/Makefile.Mac.depend | 10 + otherlibs/num/test/Makefile.nt | 54 + 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_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 | 5 + 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 | 235 + 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/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 | 815 +++ 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/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 | 527 ++ otherlibs/threads/scheduler.c | 874 +++ 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 | 162 + 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 | 66 + 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 | 1202 +++++ 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 | 35 + parsing/lexer.mll | 498 ++ parsing/linenum.mli | 23 + parsing/linenum.mll | 74 + parsing/location.ml | 240 + parsing/location.mli | 54 + parsing/longident.ml | 38 + parsing/longident.mli | 23 + parsing/parse.ml | 64 + parsing/parse.mli | 21 + parsing/parser.mly | 1540 ++++++ parsing/parsetree.mli | 271 + parsing/printast.ml | 681 +++ parsing/printast.mli | 20 + parsing/syntaxerr.ml | 41 + parsing/syntaxerr.mli | 26 + stdlib/.cvsignore | 4 + stdlib/.depend | 100 + stdlib/Makefile | 167 + stdlib/Makefile.Mac | 74 + stdlib/Makefile.Mac.depend | 74 + stdlib/Makefile.nt | 112 + stdlib/StdlibModules | 46 + stdlib/arg.ml | 195 + stdlib/arg.mli | 125 + stdlib/array.ml | 279 + stdlib/array.mli | 205 + stdlib/arrayLabels.ml | 18 + stdlib/arrayLabels.mli | 192 + stdlib/buffer.ml | 150 + stdlib/buffer.mli | 95 + stdlib/callback.ml | 24 + stdlib/callback.mli | 34 + stdlib/camlinternalOO.ml | 494 ++ stdlib/camlinternalOO.mli | 77 + stdlib/char.ml | 66 + stdlib/char.mli | 48 + stdlib/complex.ml | 87 + stdlib/complex.mli | 86 + stdlib/digest.ml | 51 + stdlib/digest.mli | 53 + stdlib/filename.ml | 247 + stdlib/filename.mli | 99 + stdlib/format.ml | 1132 ++++ stdlib/format.mli | 648 +++ stdlib/gc.ml | 99 + stdlib/gc.mli | 245 + stdlib/genlex.ml | 202 + stdlib/genlex.mli | 68 + stdlib/hashtbl.ml | 273 + stdlib/hashtbl.mli | 167 + stdlib/header.c | 191 + stdlib/headernt.c | 175 + stdlib/int32.ml | 52 + stdlib/int32.mli | 151 + stdlib/int64.ml | 59 + stdlib/int64.mli | 185 + stdlib/lazy.ml | 96 + stdlib/lazy.mli | 72 + stdlib/lexing.ml | 220 + stdlib/lexing.mli | 152 + stdlib/list.ml | 315 ++ stdlib/list.mli | 277 + stdlib/listLabels.ml | 18 + stdlib/listLabels.mli | 283 + stdlib/map.ml | 161 + stdlib/map.mli | 99 + stdlib/marshal.ml | 52 + stdlib/marshal.mli | 138 + stdlib/moreLabels.ml | 22 + stdlib/moreLabels.mli | 118 + stdlib/nativeint.ml | 55 + stdlib/nativeint.mli | 181 + stdlib/obj.ml | 52 + stdlib/obj.mli | 55 + stdlib/oo.ml | 19 + stdlib/oo.mli | 29 + stdlib/parsing.ml | 195 + stdlib/parsing.mli | 96 + stdlib/pervasives.ml | 432 ++ stdlib/pervasives.mli | 845 +++ stdlib/printexc.ml | 76 + stdlib/printexc.mli | 39 + stdlib/printf.ml | 243 + stdlib/printf.mli | 124 + stdlib/queue.ml | 168 + stdlib/queue.mli | 78 + stdlib/random.ml | 268 + stdlib/random.mli | 101 + stdlib/scanf.ml | 765 +++ stdlib/scanf.mli | 220 + stdlib/set.ml | 326 ++ stdlib/set.mli | 146 + stdlib/sharpbang | 1 + stdlib/sort.ml | 97 + stdlib/sort.mli | 42 + stdlib/stack.ml | 42 + stdlib/stack.mli | 58 + stdlib/stdLabels.ml | 22 + stdlib/stdLabels.mli | 136 + stdlib/std_exit.ml | 18 + stdlib/stream.ml | 190 + stdlib/stream.mli | 106 + stdlib/string.ml | 177 + stdlib/string.mli | 160 + stdlib/stringLabels.ml | 18 + stdlib/stringLabels.mli | 154 + stdlib/sys.ml | 81 + stdlib/sys.mli | 193 + stdlib/weak.ml | 243 + stdlib/weak.mli | 154 + 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 | 290 + 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 | 479 ++ 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 | 413 ++ toplevel/toploop.mli | 107 + toplevel/topmain.ml | 89 + toplevel/topmain.mli | 17 + toplevel/topstart.ml | 15 + toplevel/trace.ml | 144 + toplevel/trace.mli | 35 + typing/btype.ml | 436 ++ typing/btype.mli | 145 + typing/ctype.ml | 3242 ++++++++++++ typing/ctype.mli | 236 + typing/datarepr.ml | 96 + typing/datarepr.mli | 34 + typing/env.ml | 770 +++ typing/env.mli | 138 + typing/ident.ml | 161 + typing/ident.mli | 56 + typing/includeclass.ml | 104 + typing/includeclass.mli | 31 + typing/includecore.ml | 123 + typing/includecore.mli | 31 + typing/includemod.ml | 378 ++ typing/includemod.mli | 46 + typing/mtype.ml | 179 + typing/mtype.mli | 32 + typing/oprint.ml | 433 ++ typing/oprint.mli | 24 + typing/outcometree.mli | 96 + typing/parmatch.ml | 1564 ++++++ 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 | 894 ++++ typing/printtyp.mli | 66 + typing/stypes.ml | 94 + typing/stypes.mli | 32 + typing/subst.ml | 294 ++ typing/subst.mli | 51 + typing/typeclass.ml | 1389 +++++ typing/typeclass.mli | 77 + typing/typecore.ml | 2000 +++++++ typing/typecore.mli | 104 + typing/typedecl.ml | 715 +++ typing/typedecl.mli | 69 + typing/typedtree.ml | 217 + typing/typedtree.mli | 159 + typing/typemod.ml | 838 +++ 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 | 44 + win32caml/inria.h | 115 + win32caml/inriares.h | 48 + win32caml/libgraph.h | 108 + win32caml/menu.c | 591 +++ win32caml/ocaml.c | 815 +++ win32caml/ocaml.ico | Bin 0 -> 766 bytes win32caml/ocaml.rc | 114 + win32caml/startocaml.c | 363 ++ yacc/.cvsignore | 3 + yacc/Makefile | 46 + yacc/Makefile.Mac | 54 + yacc/Makefile.nt | 49 + yacc/closure.c | 283 + yacc/defs.h | 376 ++ yacc/error.c | 313 ++ yacc/lalr.c | 663 +++ yacc/lr0.c | 621 +++ yacc/main.c | 393 ++ yacc/mkpar.c | 366 ++ yacc/output.c | 984 ++++ yacc/reader.c | 1838 +++++++ yacc/skeleton.c | 58 + yacc/symtab.c | 129 + yacc/verbose.c | 350 ++ yacc/warshall.c | 96 + 1644 files changed, 304068 insertions(+) create mode 100644 .cvsignore create mode 100644 .depend create mode 100644 Changes create mode 100644 INSTALL create mode 100644 INSTALL.MPW create mode 100644 LICENSE create mode 100644 Makefile create mode 100644 Makefile.Mac create mode 100644 Makefile.Mac.depend create mode 100644 Makefile.nt create mode 100644 README create mode 100644 README.win32 create mode 100644 Upgrading create mode 100644 asmcomp/.cvsignore create mode 100644 asmcomp/alpha/arch.ml create mode 100644 asmcomp/alpha/emit.mlp create mode 100644 asmcomp/alpha/proc.ml create mode 100644 asmcomp/alpha/reload.ml create mode 100644 asmcomp/alpha/scheduling.ml create mode 100644 asmcomp/alpha/selection.ml create mode 100644 asmcomp/amd64/arch.ml create mode 100644 asmcomp/amd64/emit.mlp create mode 100644 asmcomp/amd64/proc.ml create mode 100644 asmcomp/amd64/reload.ml create mode 100644 asmcomp/amd64/scheduling.ml create mode 100644 asmcomp/amd64/selection.ml create mode 100644 asmcomp/arm/arch.ml create mode 100644 asmcomp/arm/emit.mlp create mode 100644 asmcomp/arm/proc.ml create mode 100644 asmcomp/arm/reload.ml create mode 100644 asmcomp/arm/scheduling.ml create mode 100644 asmcomp/arm/selection.ml create mode 100644 asmcomp/asmgen.ml create mode 100644 asmcomp/asmgen.mli create mode 100644 asmcomp/asmlibrarian.ml create mode 100644 asmcomp/asmlibrarian.mli create mode 100644 asmcomp/asmlink.ml create mode 100644 asmcomp/asmlink.mli create mode 100644 asmcomp/asmpackager.ml create mode 100644 asmcomp/asmpackager.mli create mode 100644 asmcomp/clambda.ml create mode 100644 asmcomp/clambda.mli create mode 100644 asmcomp/closure.ml create mode 100644 asmcomp/closure.mli create mode 100644 asmcomp/cmm.ml create mode 100644 asmcomp/cmm.mli create mode 100644 asmcomp/cmmgen.ml create mode 100644 asmcomp/cmmgen.mli create mode 100644 asmcomp/codegen.ml create mode 100644 asmcomp/codegen.mli create mode 100644 asmcomp/coloring.ml create mode 100644 asmcomp/coloring.mli create mode 100644 asmcomp/comballoc.ml create mode 100644 asmcomp/comballoc.mli create mode 100644 asmcomp/compilenv.ml create mode 100644 asmcomp/compilenv.mli create mode 100644 asmcomp/emit.mli create mode 100644 asmcomp/emitaux.ml create mode 100644 asmcomp/emitaux.mli create mode 100644 asmcomp/hppa/arch.ml create mode 100644 asmcomp/hppa/emit.mlp create mode 100644 asmcomp/hppa/proc.ml create mode 100644 asmcomp/hppa/reload.ml create mode 100644 asmcomp/hppa/scheduling.ml create mode 100644 asmcomp/hppa/selection.ml create mode 100644 asmcomp/i386/arch.ml create mode 100644 asmcomp/i386/emit.mlp create mode 100644 asmcomp/i386/emit_nt.mlp create mode 100644 asmcomp/i386/proc.ml create mode 100644 asmcomp/i386/proc_nt.ml create mode 100644 asmcomp/i386/reload.ml create mode 100644 asmcomp/i386/scheduling.ml create mode 100644 asmcomp/i386/selection.ml create mode 100644 asmcomp/ia64/arch.ml create mode 100644 asmcomp/ia64/emit.mlp create mode 100644 asmcomp/ia64/proc.ml create mode 100644 asmcomp/ia64/reload.ml create mode 100644 asmcomp/ia64/scheduling.ml create mode 100644 asmcomp/ia64/selection.ml create mode 100644 asmcomp/interf.ml create mode 100644 asmcomp/interf.mli create mode 100644 asmcomp/linearize.ml create mode 100644 asmcomp/linearize.mli create mode 100644 asmcomp/liveness.ml create mode 100644 asmcomp/liveness.mli create mode 100644 asmcomp/m68k/README create mode 100644 asmcomp/mach.ml create mode 100644 asmcomp/mach.mli create mode 100644 asmcomp/mips/arch.ml create mode 100644 asmcomp/mips/emit.mlp create mode 100644 asmcomp/mips/proc.ml create mode 100644 asmcomp/mips/reload.ml create mode 100644 asmcomp/mips/scheduling.ml create mode 100644 asmcomp/mips/selection.ml create mode 100644 asmcomp/power/arch.ml create mode 100644 asmcomp/power/emit.mlp create mode 100644 asmcomp/power/proc.ml create mode 100644 asmcomp/power/reload.ml create mode 100644 asmcomp/power/scheduling.ml create mode 100644 asmcomp/power/selection.ml create mode 100644 asmcomp/printcmm.ml create mode 100644 asmcomp/printcmm.mli create mode 100644 asmcomp/printlinear.ml create mode 100644 asmcomp/printlinear.mli create mode 100644 asmcomp/printmach.ml create mode 100644 asmcomp/printmach.mli create mode 100644 asmcomp/proc.mli create mode 100644 asmcomp/reg.ml create mode 100644 asmcomp/reg.mli create mode 100644 asmcomp/reload.mli create mode 100644 asmcomp/reloadgen.ml create mode 100644 asmcomp/reloadgen.mli create mode 100644 asmcomp/schedgen.ml create mode 100644 asmcomp/schedgen.mli create mode 100644 asmcomp/scheduling.mli create mode 100644 asmcomp/selectgen.ml create mode 100644 asmcomp/selectgen.mli create mode 100644 asmcomp/selection.mli create mode 100644 asmcomp/sparc/arch.ml create mode 100644 asmcomp/sparc/emit.mlp create mode 100644 asmcomp/sparc/proc.ml create mode 100644 asmcomp/sparc/reload.ml create mode 100644 asmcomp/sparc/scheduling.ml create mode 100644 asmcomp/sparc/selection.ml create mode 100644 asmcomp/spill.ml create mode 100644 asmcomp/spill.mli create mode 100644 asmcomp/split.ml create mode 100644 asmcomp/split.mli create mode 100644 asmrun/.cvsignore create mode 100644 asmrun/.depend create mode 100644 asmrun/Makefile create mode 100644 asmrun/Makefile.nt create mode 100644 asmrun/alpha.S create mode 100644 asmrun/amd64.S create mode 100644 asmrun/arm.S create mode 100644 asmrun/fail.c create mode 100644 asmrun/hppa.S create mode 100644 asmrun/i386.S create mode 100644 asmrun/i386nt.asm create mode 100644 asmrun/ia64.S create mode 100644 asmrun/m68k.S create mode 100644 asmrun/mips.s create mode 100644 asmrun/power-aix.S create mode 100644 asmrun/power-elf.S create mode 100644 asmrun/power-rhapsody.S create mode 100644 asmrun/roots.c create mode 100644 asmrun/signals.c create mode 100644 asmrun/sparc.S create mode 100644 asmrun/stack.h create mode 100644 asmrun/startup.c create mode 100644 boot/.cvsignore create mode 100755 boot/ocamlc create mode 100755 boot/ocamllex create mode 100644 bytecomp/.cvsignore create mode 100644 bytecomp/bytegen.ml create mode 100644 bytecomp/bytegen.mli create mode 100644 bytecomp/bytelibrarian.ml create mode 100644 bytecomp/bytelibrarian.mli create mode 100644 bytecomp/bytelink.ml create mode 100644 bytecomp/bytelink.mli create mode 100644 bytecomp/bytepackager.ml create mode 100644 bytecomp/bytepackager.mli create mode 100644 bytecomp/bytesections.ml create mode 100644 bytecomp/bytesections.mli create mode 100644 bytecomp/dll.ml create mode 100644 bytecomp/dll.mli create mode 100644 bytecomp/emitcode.ml create mode 100644 bytecomp/emitcode.mli create mode 100644 bytecomp/instruct.ml create mode 100644 bytecomp/instruct.mli create mode 100644 bytecomp/lambda.ml create mode 100644 bytecomp/lambda.mli create mode 100644 bytecomp/matching.ml create mode 100644 bytecomp/matching.mli create mode 100644 bytecomp/meta.ml create mode 100644 bytecomp/meta.mli create mode 100644 bytecomp/printinstr.ml create mode 100644 bytecomp/printinstr.mli create mode 100644 bytecomp/printlambda.ml create mode 100644 bytecomp/printlambda.mli create mode 100644 bytecomp/runtimedef.mli create mode 100644 bytecomp/simplif.ml create mode 100644 bytecomp/simplif.mli create mode 100644 bytecomp/switch.ml create mode 100644 bytecomp/switch.mli create mode 100644 bytecomp/symtable.ml create mode 100644 bytecomp/symtable.mli create mode 100644 bytecomp/translclass.ml create mode 100644 bytecomp/translclass.mli create mode 100644 bytecomp/translcore.ml create mode 100644 bytecomp/translcore.mli create mode 100644 bytecomp/translmod.ml create mode 100644 bytecomp/translmod.mli create mode 100644 bytecomp/translobj.ml create mode 100644 bytecomp/translobj.mli create mode 100644 bytecomp/typeopt.ml create mode 100644 bytecomp/typeopt.mli create mode 100644 byterun/.cvsignore create mode 100644 byterun/.depend create mode 100644 byterun/Makefile create mode 100644 byterun/Makefile.Mac create mode 100644 byterun/Makefile.Mac.depend create mode 100644 byterun/Makefile.nt create mode 100644 byterun/alloc.c create mode 100644 byterun/alloc.h create mode 100644 byterun/array.c create mode 100644 byterun/backtrace.c create mode 100644 byterun/backtrace.h create mode 100644 byterun/callback.c create mode 100644 byterun/callback.h create mode 100644 byterun/compact.c create mode 100644 byterun/compact.h create mode 100644 byterun/compare.c create mode 100644 byterun/config.h create mode 100644 byterun/custom.c create mode 100644 byterun/custom.h create mode 100644 byterun/debugger.c create mode 100644 byterun/debugger.h create mode 100644 byterun/dynlink.c create mode 100644 byterun/dynlink.h create mode 100644 byterun/exec.h create mode 100644 byterun/extern.c create mode 100644 byterun/fail.c create mode 100644 byterun/fail.h create mode 100644 byterun/finalise.c create mode 100644 byterun/finalise.h create mode 100644 byterun/fix_code.c create mode 100644 byterun/fix_code.h create mode 100644 byterun/floats.c create mode 100644 byterun/freelist.c create mode 100644 byterun/freelist.h create mode 100644 byterun/gc.h create mode 100644 byterun/gc_ctrl.c create mode 100644 byterun/gc_ctrl.h create mode 100644 byterun/globroots.c create mode 100644 byterun/globroots.h create mode 100644 byterun/hash.c create mode 100644 byterun/instrtrace.c create mode 100644 byterun/instrtrace.h create mode 100644 byterun/instruct.h create mode 100644 byterun/int64_emul.h create mode 100644 byterun/int64_format.h create mode 100644 byterun/int64_native.h create mode 100644 byterun/intern.c create mode 100644 byterun/interp.c create mode 100644 byterun/interp.h create mode 100644 byterun/intext.h create mode 100644 byterun/ints.c create mode 100644 byterun/io.c create mode 100644 byterun/io.h create mode 100644 byterun/lexing.c create mode 100644 byterun/macintosh.c create mode 100644 byterun/macintosh.h create mode 100644 byterun/main.c create mode 100644 byterun/major_gc.c create mode 100644 byterun/major_gc.h create mode 100644 byterun/md5.c create mode 100644 byterun/md5.h create mode 100644 byterun/memory.c create mode 100644 byterun/memory.h create mode 100644 byterun/meta.c create mode 100644 byterun/minor_gc.c create mode 100644 byterun/minor_gc.h create mode 100644 byterun/misc.c create mode 100644 byterun/misc.h create mode 100644 byterun/mlvalues.h create mode 100644 byterun/mpwtool.c create mode 100644 byterun/obj.c create mode 100644 byterun/osdeps.h create mode 100644 byterun/parsing.c create mode 100644 byterun/prims.h create mode 100644 byterun/printexc.c create mode 100644 byterun/printexc.h create mode 100644 byterun/reverse.h create mode 100644 byterun/roots.c create mode 100644 byterun/roots.h create mode 100644 byterun/rotatecursor.c create mode 100644 byterun/rotatecursor.h create mode 100644 byterun/signals.c create mode 100644 byterun/signals.h create mode 100644 byterun/stacks.c create mode 100644 byterun/stacks.h create mode 100644 byterun/startup.c create mode 100644 byterun/startup.h create mode 100644 byterun/str.c create mode 100644 byterun/sys.c create mode 100644 byterun/sys.h create mode 100644 byterun/terminfo.c create mode 100644 byterun/ui.h create mode 100644 byterun/unix.c create mode 100644 byterun/weak.c create mode 100644 byterun/weak.h create mode 100644 byterun/win32.c create mode 100644 camlp4/CHANGES create mode 100644 camlp4/ICHANGES create mode 100644 camlp4/Makefile create mode 100644 camlp4/Makefile.Mac create mode 100644 camlp4/boot/.cvsignore create mode 100644 camlp4/camlp4/.cvsignore create mode 100644 camlp4/camlp4/.depend create mode 100644 camlp4/camlp4/Makefile create mode 100644 camlp4/camlp4/Makefile.Mac create mode 100644 camlp4/camlp4/Makefile.Mac.depend create mode 100644 camlp4/camlp4/argl.ml create mode 100644 camlp4/camlp4/ast2pt.ml create mode 100644 camlp4/camlp4/ast2pt.mli create mode 100644 camlp4/camlp4/mLast.mli create mode 100644 camlp4/camlp4/pcaml.ml create mode 100644 camlp4/camlp4/pcaml.mli create mode 100644 camlp4/camlp4/quotation.ml create mode 100644 camlp4/camlp4/quotation.mli create mode 100644 camlp4/camlp4/reloc.ml create mode 100644 camlp4/camlp4/reloc.mli create mode 100644 camlp4/camlp4/spretty.ml create mode 100644 camlp4/camlp4/spretty.mli create mode 100644 camlp4/compile/.cvsignore create mode 100644 camlp4/compile/.depend create mode 100644 camlp4/compile/Makefile create mode 100644 camlp4/compile/comp_head.ml create mode 100644 camlp4/compile/comp_trail.ml create mode 100644 camlp4/compile/compile.ml create mode 100755 camlp4/compile/compile.sh create mode 100644 camlp4/config/.cvsignore create mode 100644 camlp4/config/Makefile-nt.cnf create mode 100644 camlp4/config/Makefile.tpl create mode 100644 camlp4/config/config.mpw create mode 100755 camlp4/config/configure_batch create mode 100644 camlp4/etc/.cvsignore create mode 100644 camlp4/etc/.depend create mode 100644 camlp4/etc/Makefile create mode 100644 camlp4/etc/Makefile.Mac create mode 100644 camlp4/etc/Makefile.Mac.depend create mode 100644 camlp4/etc/lib.sml create mode 100644 camlp4/etc/mkcamlp4.mpw.tpl create mode 100755 camlp4/etc/mkcamlp4.sh.tpl create mode 100644 camlp4/etc/pa_extfold.ml create mode 100644 camlp4/etc/pa_extfun.ml create mode 100644 camlp4/etc/pa_format.ml create mode 100644 camlp4/etc/pa_fstream.ml create mode 100644 camlp4/etc/pa_ifdef.ml create mode 100644 camlp4/etc/pa_lefteval.ml create mode 100644 camlp4/etc/pa_lisp.ml create mode 100644 camlp4/etc/pa_lispr.ml create mode 100644 camlp4/etc/pa_o.ml create mode 100644 camlp4/etc/pa_ocamllex.ml create mode 100644 camlp4/etc/pa_olabl.ml create mode 100644 camlp4/etc/pa_oop.ml create mode 100644 camlp4/etc/pa_op.ml create mode 100644 camlp4/etc/pa_ru.ml create mode 100644 camlp4/etc/pa_scheme.ml create mode 100644 camlp4/etc/pa_schemer.ml create mode 100644 camlp4/etc/pa_sml.ml create mode 100644 camlp4/etc/parserify.ml create mode 100644 camlp4/etc/parserify.mli create mode 100644 camlp4/etc/pr_depend.ml create mode 100644 camlp4/etc/pr_extend.ml create mode 100644 camlp4/etc/pr_extfun.ml create mode 100644 camlp4/etc/pr_null.ml create mode 100644 camlp4/etc/pr_o.ml create mode 100644 camlp4/etc/pr_op.ml create mode 100644 camlp4/etc/pr_op_main.ml create mode 100644 camlp4/etc/pr_r.ml create mode 100644 camlp4/etc/pr_rp.ml create mode 100644 camlp4/etc/pr_rp_main.ml create mode 100644 camlp4/etc/pr_scheme.ml create mode 100644 camlp4/etc/pr_schp_main.ml create mode 100644 camlp4/etc/q_phony.ml create mode 100644 camlp4/lib/.cvsignore create mode 100644 camlp4/lib/.depend create mode 100644 camlp4/lib/Makefile create mode 100644 camlp4/lib/Makefile.Mac create mode 100644 camlp4/lib/Makefile.Mac.depend create mode 100644 camlp4/lib/extfold.ml create mode 100644 camlp4/lib/extfold.mli create mode 100644 camlp4/lib/extfun.ml create mode 100644 camlp4/lib/extfun.mli create mode 100644 camlp4/lib/fstream.ml create mode 100644 camlp4/lib/fstream.mli create mode 100644 camlp4/lib/gramext.ml create mode 100644 camlp4/lib/gramext.mli create mode 100644 camlp4/lib/grammar.ml create mode 100644 camlp4/lib/grammar.mli create mode 100644 camlp4/lib/plexer.ml create mode 100644 camlp4/lib/plexer.mli create mode 100644 camlp4/lib/stdpp.ml create mode 100644 camlp4/lib/stdpp.mli create mode 100644 camlp4/lib/token.ml create mode 100644 camlp4/lib/token.mli create mode 100644 camlp4/man/.cvsignore create mode 100644 camlp4/man/Makefile create mode 100644 camlp4/man/Makefile.Mac create mode 100644 camlp4/man/camlp4.1.tpl create mode 100644 camlp4/man/camlp4.help.tpl create mode 100644 camlp4/meta/.cvsignore create mode 100644 camlp4/meta/.depend create mode 100644 camlp4/meta/Makefile create mode 100644 camlp4/meta/Makefile.Mac create mode 100644 camlp4/meta/Makefile.Mac.depend create mode 100755 camlp4/meta/mk_q_MLast.sh create mode 100644 camlp4/meta/pa_extend.ml create mode 100644 camlp4/meta/pa_extend_m.ml create mode 100644 camlp4/meta/pa_ifdef.ml create mode 100644 camlp4/meta/pa_macro.ml create mode 100644 camlp4/meta/pa_r.ml create mode 100644 camlp4/meta/pa_rp.ml create mode 100644 camlp4/meta/pr_dump.ml create mode 100644 camlp4/meta/q_MLast.ml create mode 100644 camlp4/ocaml_src/.cvsignore create mode 100644 camlp4/ocaml_src/camlp4/.cvsignore create mode 100644 camlp4/ocaml_src/camlp4/.depend create mode 100644 camlp4/ocaml_src/camlp4/Makefile create mode 100644 camlp4/ocaml_src/camlp4/Makefile.Mac create mode 100644 camlp4/ocaml_src/camlp4/Makefile.Mac.depend create mode 100644 camlp4/ocaml_src/camlp4/argl.ml create mode 100644 camlp4/ocaml_src/camlp4/ast2pt.ml create mode 100644 camlp4/ocaml_src/camlp4/ast2pt.mli create mode 100644 camlp4/ocaml_src/camlp4/mLast.mli create mode 100644 camlp4/ocaml_src/camlp4/pcaml.ml create mode 100644 camlp4/ocaml_src/camlp4/pcaml.mli create mode 100644 camlp4/ocaml_src/camlp4/quotation.ml create mode 100644 camlp4/ocaml_src/camlp4/quotation.mli create mode 100644 camlp4/ocaml_src/camlp4/reloc.ml create mode 100644 camlp4/ocaml_src/camlp4/reloc.mli create mode 100644 camlp4/ocaml_src/camlp4/spretty.ml create mode 100644 camlp4/ocaml_src/camlp4/spretty.mli create mode 100644 camlp4/ocaml_src/lib/.depend create mode 100644 camlp4/ocaml_src/lib/Makefile create mode 100644 camlp4/ocaml_src/lib/Makefile.Mac create mode 100644 camlp4/ocaml_src/lib/Makefile.Mac.depend create mode 100644 camlp4/ocaml_src/lib/extfold.ml create mode 100644 camlp4/ocaml_src/lib/extfold.mli create mode 100644 camlp4/ocaml_src/lib/extfun.ml create mode 100644 camlp4/ocaml_src/lib/extfun.mli create mode 100644 camlp4/ocaml_src/lib/fstream.ml create mode 100644 camlp4/ocaml_src/lib/fstream.mli create mode 100644 camlp4/ocaml_src/lib/gramext.ml create mode 100644 camlp4/ocaml_src/lib/gramext.mli create mode 100644 camlp4/ocaml_src/lib/grammar.ml create mode 100644 camlp4/ocaml_src/lib/grammar.mli create mode 100644 camlp4/ocaml_src/lib/plexer.ml create mode 100644 camlp4/ocaml_src/lib/plexer.mli create mode 100644 camlp4/ocaml_src/lib/stdpp.ml create mode 100644 camlp4/ocaml_src/lib/stdpp.mli create mode 100644 camlp4/ocaml_src/lib/token.ml create mode 100644 camlp4/ocaml_src/lib/token.mli create mode 100644 camlp4/ocaml_src/meta/.cvsignore create mode 100644 camlp4/ocaml_src/meta/.depend create mode 100644 camlp4/ocaml_src/meta/Makefile create mode 100644 camlp4/ocaml_src/meta/Makefile.Mac create mode 100644 camlp4/ocaml_src/meta/Makefile.Mac.depend create mode 100644 camlp4/ocaml_src/meta/pa_extend.ml create mode 100644 camlp4/ocaml_src/meta/pa_extend_m.ml create mode 100644 camlp4/ocaml_src/meta/pa_ifdef.ml create mode 100644 camlp4/ocaml_src/meta/pa_macro.ml create mode 100644 camlp4/ocaml_src/meta/pa_r.ml create mode 100644 camlp4/ocaml_src/meta/pa_rp.ml create mode 100644 camlp4/ocaml_src/meta/pr_dump.ml create mode 100644 camlp4/ocaml_src/meta/q_MLast.ml create mode 100644 camlp4/ocaml_src/odyl/.cvsignore create mode 100644 camlp4/ocaml_src/odyl/.depend create mode 100644 camlp4/ocaml_src/odyl/Makefile create mode 100644 camlp4/ocaml_src/odyl/Makefile.Mac create mode 100644 camlp4/ocaml_src/odyl/Makefile.Mac.depend create mode 100644 camlp4/ocaml_src/odyl/odyl.ml create mode 100644 camlp4/ocaml_src/odyl/odyl_main.ml create mode 100644 camlp4/ocaml_src/odyl/odyl_main.mli create mode 100644 camlp4/ocaml_src/tools/camlp4_comm.mpw create mode 100755 camlp4/ocaml_src/tools/camlp4_comm.sh create mode 100644 camlp4/ocaml_src/tools/extract_crc.mpw create mode 100755 camlp4/ocaml_src/tools/extract_crc.sh create mode 100644 camlp4/ocaml_src/tools/ocamlc.mpw create mode 100755 camlp4/ocaml_src/tools/ocamlc.sh create mode 100755 camlp4/ocaml_src/tools/ocamlopt.sh create mode 100644 camlp4/ocaml_stuff/otherlibs/dynlink/.depend create mode 100644 camlp4/ocaml_stuff/parsing/.depend create mode 100644 camlp4/ocaml_stuff/utils/.depend create mode 100644 camlp4/ocpp/.cvsignore create mode 100644 camlp4/ocpp/.depend create mode 100644 camlp4/ocpp/Makefile create mode 100644 camlp4/ocpp/Makefile.Mac create mode 100644 camlp4/ocpp/ocpp.ml create mode 100644 camlp4/odyl/.cvsignore create mode 100644 camlp4/odyl/.depend create mode 100644 camlp4/odyl/Makefile create mode 100644 camlp4/odyl/Makefile.Mac create mode 100644 camlp4/odyl/Makefile.Mac.depend create mode 100644 camlp4/odyl/odyl.ml create mode 100644 camlp4/odyl/odyl_main.ml create mode 100644 camlp4/odyl/odyl_main.mli create mode 100755 camlp4/tools/apply.sh create mode 100644 camlp4/tools/camlp4_comm.mpw create mode 100755 camlp4/tools/camlp4_comm.sh create mode 100755 camlp4/tools/conv.sh create mode 100644 camlp4/tools/extract_crc.mpw create mode 100755 camlp4/tools/extract_crc.sh create mode 100644 camlp4/tools/ocamlc.mpw create mode 100755 camlp4/tools/ocamlc.sh create mode 100755 camlp4/tools/ocamlopt.sh create mode 100644 camlp4/top/.cvsignore create mode 100644 camlp4/top/.depend create mode 100644 camlp4/top/Makefile create mode 100644 camlp4/top/Makefile.Mac create mode 100644 camlp4/top/Makefile.Mac.depend create mode 100644 camlp4/top/camlp4_top.ml create mode 100644 camlp4/top/oprint.ml create mode 100644 camlp4/top/rprint.ml create mode 100644 config/.cvsignore create mode 100644 config/Makefile-templ create mode 100644 config/Makefile.mingw create mode 100644 config/Makefile.msvc create mode 100644 config/auto-aux/align.c create mode 100644 config/auto-aux/ansi.c create mode 100644 config/auto-aux/async_io.c create mode 100644 config/auto-aux/bytecopy.c create mode 100644 config/auto-aux/dblalign.c create mode 100644 config/auto-aux/divmod.c create mode 100644 config/auto-aux/elf.c create mode 100644 config/auto-aux/endian.c create mode 100644 config/auto-aux/getgroups.c create mode 100644 config/auto-aux/gethostbyaddr.c create mode 100644 config/auto-aux/gethostbyname.c create mode 100755 config/auto-aux/hasgot create mode 100644 config/auto-aux/int64align.c create mode 100644 config/auto-aux/longlong.c create mode 100755 config/auto-aux/runtest create mode 100644 config/auto-aux/schar.c create mode 100644 config/auto-aux/schar2.c create mode 100755 config/auto-aux/searchpath create mode 100755 config/auto-aux/sharpbang create mode 100755 config/auto-aux/sharpbang2 create mode 100644 config/auto-aux/sighandler.c create mode 100644 config/auto-aux/signals.c create mode 100644 config/auto-aux/sizes.c create mode 100644 config/auto-aux/solaris-ld create mode 100644 config/auto-aux/stackov.c create mode 100644 config/auto-aux/tclversion.c create mode 100755 config/auto-aux/trycompile create mode 100644 config/config.Mac create mode 100755 config/gnu/config.guess create mode 100755 config/gnu/config.sub create mode 100644 config/m-MacOS.h create mode 100644 config/m-nt.h create mode 100644 config/m-templ.h create mode 100644 config/s-MacOS.h create mode 100644 config/s-nt.h create mode 100644 config/s-templ.h create mode 100755 configure create mode 100644 debugger/.cvsignore create mode 100644 debugger/.depend create mode 100644 debugger/Makefile create mode 100644 debugger/breakpoints.ml create mode 100644 debugger/breakpoints.mli create mode 100644 debugger/checkpoints.ml create mode 100644 debugger/checkpoints.mli create mode 100644 debugger/command_line.ml create mode 100644 debugger/command_line.mli create mode 100644 debugger/debugcom.ml create mode 100644 debugger/debugcom.mli create mode 100644 debugger/debugger_config.ml create mode 100644 debugger/debugger_config.mli create mode 100644 debugger/envaux.ml create mode 100644 debugger/envaux.mli create mode 100644 debugger/eval.ml create mode 100644 debugger/eval.mli create mode 100644 debugger/events.ml create mode 100644 debugger/events.mli create mode 100644 debugger/exec.ml create mode 100644 debugger/exec.mli create mode 100644 debugger/frames.ml create mode 100644 debugger/frames.mli create mode 100644 debugger/history.ml create mode 100644 debugger/history.mli create mode 100644 debugger/input_handling.ml create mode 100644 debugger/input_handling.mli create mode 100644 debugger/int64ops.ml create mode 100644 debugger/int64ops.mli create mode 100644 debugger/lexer.mll create mode 100644 debugger/loadprinter.ml create mode 100644 debugger/loadprinter.mli create mode 100644 debugger/main.ml create mode 100644 debugger/parameters.ml create mode 100644 debugger/parameters.mli create mode 100644 debugger/parser.mly create mode 100644 debugger/parser_aux.mli create mode 100644 debugger/pattern_matching.ml create mode 100644 debugger/pattern_matching.mli create mode 100644 debugger/primitives.ml create mode 100644 debugger/primitives.mli create mode 100644 debugger/printval.ml create mode 100644 debugger/printval.mli create mode 100644 debugger/program_loading.ml create mode 100644 debugger/program_loading.mli create mode 100644 debugger/program_management.ml create mode 100644 debugger/program_management.mli create mode 100644 debugger/show_information.ml create mode 100644 debugger/show_information.mli create mode 100644 debugger/show_source.ml create mode 100644 debugger/show_source.mli create mode 100644 debugger/source.ml create mode 100644 debugger/source.mli create mode 100644 debugger/symbols.ml create mode 100644 debugger/symbols.mli create mode 100644 debugger/time_travel.ml create mode 100644 debugger/time_travel.mli create mode 100644 debugger/trap_barrier.ml create mode 100644 debugger/trap_barrier.mli create mode 100644 debugger/unix_tools.ml create mode 100644 debugger/unix_tools.mli create mode 100644 driver/compile.ml create mode 100644 driver/compile.mli create mode 100644 driver/errors.ml create mode 100644 driver/errors.mli create mode 100644 driver/main.ml create mode 100644 driver/main.mli create mode 100644 driver/main_args.ml create mode 100644 driver/main_args.mli create mode 100644 driver/ocamlcomp.sh.in create mode 100644 driver/optcompile.ml create mode 100644 driver/optcompile.mli create mode 100644 driver/opterrors.ml create mode 100644 driver/opterrors.mli create mode 100644 driver/optmain.ml create mode 100644 driver/optmain.mli create mode 100644 driver/pparse.ml create mode 100644 driver/pparse.mli create mode 100644 emacs/.cvsignore create mode 100644 emacs/Makefile create mode 100644 emacs/README create mode 100644 emacs/README.itz create mode 100644 emacs/caml-compat.el create mode 100644 emacs/caml-font.el create mode 100644 emacs/caml-help.el create mode 100644 emacs/caml-hilit.el create mode 100644 emacs/caml-types.el create mode 100644 emacs/caml.el create mode 100644 emacs/camldebug.el create mode 100644 emacs/inf-caml.el create mode 100644 emacs/ocamltags.in create mode 100644 lex/.cvsignore create mode 100644 lex/.depend create mode 100644 lex/Makefile create mode 100644 lex/Makefile.Mac create mode 100644 lex/Makefile.Mac.depend create mode 100644 lex/Makefile.nt create mode 100644 lex/common.ml create mode 100644 lex/common.mli create mode 100644 lex/compact.ml create mode 100644 lex/compact.mli create mode 100644 lex/cset.ml create mode 100644 lex/cset.mli create mode 100644 lex/lexer.mli create mode 100644 lex/lexer.mll create mode 100644 lex/lexgen.ml create mode 100644 lex/lexgen.mli create mode 100644 lex/main.ml create mode 100644 lex/output.ml create mode 100644 lex/output.mli create mode 100644 lex/outputbis.ml create mode 100644 lex/outputbis.mli create mode 100644 lex/parser.mly create mode 100644 lex/syntax.ml create mode 100644 lex/syntax.mli create mode 100644 lex/table.ml create mode 100644 lex/table.mli create mode 100644 maccaml/.cvsignore create mode 100644 maccaml/Makefile.Mac create mode 100644 maccaml/Makefile.Mac.depend create mode 100644 maccaml/SHORTCUTS create mode 100644 maccaml/WASTE/.cvsignore create mode 100644 maccaml/WASTE/Makefile create mode 100644 maccaml/WASTE/README create mode 100644 maccaml/aboutbox.c create mode 100644 maccaml/appleevents.c create mode 100644 maccaml/appli.r create mode 100644 maccaml/clipboard.c create mode 100644 maccaml/drag.c create mode 100644 maccaml/dummy_fragment.c create mode 100644 maccaml/errors.c create mode 100644 maccaml/events.c create mode 100644 maccaml/files.c create mode 100644 maccaml/glue.c create mode 100644 maccaml/graph.c create mode 100644 maccaml/lcontrols.c create mode 100644 maccaml/lib.c create mode 100644 maccaml/main.c create mode 100644 maccaml/main.h create mode 100644 maccaml/mcmemory.c create mode 100644 maccaml/mcmisc.c create mode 100644 maccaml/menus.c create mode 100644 maccaml/modalfilter.c create mode 100644 maccaml/ocaml.r create mode 100644 maccaml/ocamlconstants.h create mode 100644 maccaml/ocamlmkappli create mode 100644 maccaml/prefs.c create mode 100644 maccaml/prim_bigarray create mode 100644 maccaml/prim_graph create mode 100644 maccaml/prim_num create mode 100644 maccaml/prim_str create mode 100644 maccaml/print.c create mode 100644 maccaml/scroll.c create mode 100644 maccaml/windows.c create mode 100644 man/Makefile create mode 100644 man/ocaml.help create mode 100644 man/ocaml.m create mode 100644 man/ocamlc.m create mode 100644 man/ocamlcp.m create mode 100644 man/ocamldebug.m create mode 100644 man/ocamldep.m create mode 100644 man/ocamllex.m create mode 100644 man/ocamlmktop.m create mode 100644 man/ocamlopt.m create mode 100644 man/ocamlprof.m create mode 100644 man/ocamlrun.m create mode 100644 man/ocamlyacc.m create mode 100644 ocamldoc/.cvsignore create mode 100644 ocamldoc/.depend create mode 100644 ocamldoc/Changes.txt create mode 100644 ocamldoc/Makefile create mode 100644 ocamldoc/Makefile.nt create mode 100644 ocamldoc/ocamldoc.hva create mode 100644 ocamldoc/ocamldoc.sty create mode 100644 ocamldoc/odoc.ml create mode 100644 ocamldoc/odoc_analyse.ml create mode 100644 ocamldoc/odoc_analyse.mli create mode 100644 ocamldoc/odoc_args.ml create mode 100644 ocamldoc/odoc_args.mli create mode 100644 ocamldoc/odoc_ast.ml create mode 100644 ocamldoc/odoc_ast.mli create mode 100644 ocamldoc/odoc_class.ml create mode 100644 ocamldoc/odoc_comments.ml create mode 100644 ocamldoc/odoc_comments.mli create mode 100644 ocamldoc/odoc_comments_global.ml create mode 100644 ocamldoc/odoc_comments_global.mli create mode 100644 ocamldoc/odoc_control.ml create mode 100644 ocamldoc/odoc_cross.ml create mode 100644 ocamldoc/odoc_cross.mli create mode 100644 ocamldoc/odoc_dag2html.ml create mode 100644 ocamldoc/odoc_dag2html.mli create mode 100644 ocamldoc/odoc_dep.ml create mode 100644 ocamldoc/odoc_dot.ml create mode 100644 ocamldoc/odoc_env.ml create mode 100644 ocamldoc/odoc_env.mli create mode 100644 ocamldoc/odoc_exception.ml create mode 100644 ocamldoc/odoc_global.ml create mode 100644 ocamldoc/odoc_global.mli create mode 100644 ocamldoc/odoc_html.ml create mode 100644 ocamldoc/odoc_info.ml create mode 100644 ocamldoc/odoc_info.mli create mode 100644 ocamldoc/odoc_inherit.ml create mode 100644 ocamldoc/odoc_latex.ml create mode 100644 ocamldoc/odoc_latex_style.ml create mode 100644 ocamldoc/odoc_lexer.mll create mode 100644 ocamldoc/odoc_man.ml create mode 100644 ocamldoc/odoc_merge.ml create mode 100644 ocamldoc/odoc_merge.mli create mode 100644 ocamldoc/odoc_messages.ml create mode 100644 ocamldoc/odoc_misc.ml create mode 100644 ocamldoc/odoc_misc.mli create mode 100644 ocamldoc/odoc_module.ml create mode 100644 ocamldoc/odoc_name.ml create mode 100644 ocamldoc/odoc_name.mli create mode 100644 ocamldoc/odoc_ocamlhtml.mll create mode 100644 ocamldoc/odoc_opt.ml create mode 100644 ocamldoc/odoc_parameter.ml create mode 100644 ocamldoc/odoc_parser.mly create mode 100644 ocamldoc/odoc_scan.ml create mode 100644 ocamldoc/odoc_search.ml create mode 100644 ocamldoc/odoc_search.mli create mode 100644 ocamldoc/odoc_see_lexer.mll create mode 100644 ocamldoc/odoc_sig.ml create mode 100644 ocamldoc/odoc_sig.mli create mode 100644 ocamldoc/odoc_str.ml create mode 100644 ocamldoc/odoc_str.mli create mode 100644 ocamldoc/odoc_texi.ml create mode 100644 ocamldoc/odoc_text.ml create mode 100644 ocamldoc/odoc_text.mli create mode 100644 ocamldoc/odoc_text_lexer.mll create mode 100644 ocamldoc/odoc_text_parser.mly create mode 100644 ocamldoc/odoc_to_text.ml create mode 100644 ocamldoc/odoc_type.ml create mode 100644 ocamldoc/odoc_types.ml create mode 100644 ocamldoc/odoc_types.mli create mode 100644 ocamldoc/odoc_value.ml create mode 100644 ocamldoc/runocamldoc create mode 100644 otherlibs/bigarray/.cvsignore create mode 100644 otherlibs/bigarray/.depend create mode 100644 otherlibs/bigarray/Makefile create mode 100644 otherlibs/bigarray/Makefile.Mac create mode 100644 otherlibs/bigarray/Makefile.Mac.depend create mode 100644 otherlibs/bigarray/Makefile.nt create mode 100644 otherlibs/bigarray/bigarray.h create mode 100644 otherlibs/bigarray/bigarray.ml create mode 100644 otherlibs/bigarray/bigarray.mli create mode 100644 otherlibs/bigarray/bigarray_stubs.c create mode 100644 otherlibs/bigarray/mmap_unix.c create mode 100644 otherlibs/bigarray/mmap_win32.c create mode 100644 otherlibs/db/.depend create mode 100644 otherlibs/dbm/.cvsignore create mode 100644 otherlibs/dbm/.depend create mode 100644 otherlibs/dbm/Makefile create mode 100644 otherlibs/dbm/cldbm.c create mode 100644 otherlibs/dbm/dbm.ml create mode 100644 otherlibs/dbm/dbm.mli create mode 100644 otherlibs/dynlink/.cvsignore create mode 100644 otherlibs/dynlink/.depend create mode 100644 otherlibs/dynlink/Makefile create mode 100644 otherlibs/dynlink/Makefile.Mac create mode 100644 otherlibs/dynlink/Makefile.Mac.depend create mode 100644 otherlibs/dynlink/Makefile.nt create mode 100644 otherlibs/dynlink/dynlink.ml create mode 100644 otherlibs/dynlink/dynlink.mli create mode 100644 otherlibs/dynlink/extract_crc.ml create mode 100644 otherlibs/graph/.cvsignore create mode 100644 otherlibs/graph/.depend create mode 100644 otherlibs/graph/Makefile create mode 100644 otherlibs/graph/Makefile.Mac create mode 100644 otherlibs/graph/Makefile.Mac.depend create mode 100644 otherlibs/graph/color.c create mode 100644 otherlibs/graph/draw.c create mode 100644 otherlibs/graph/dump_img.c create mode 100644 otherlibs/graph/events.c create mode 100644 otherlibs/graph/fill.c create mode 100644 otherlibs/graph/graphics.ml create mode 100644 otherlibs/graph/graphics.mli create mode 100644 otherlibs/graph/graphicsX11.ml create mode 100644 otherlibs/graph/graphicsX11.mli create mode 100644 otherlibs/graph/image.c create mode 100644 otherlibs/graph/image.h create mode 100644 otherlibs/graph/libgraph.h create mode 100644 otherlibs/graph/make_img.c create mode 100644 otherlibs/graph/open.c create mode 100644 otherlibs/graph/point_col.c create mode 100644 otherlibs/graph/sound.c create mode 100644 otherlibs/graph/subwindow.c create mode 100644 otherlibs/graph/text.c create mode 100644 otherlibs/labltk/.cvsignore create mode 100644 otherlibs/labltk/Changes create mode 100644 otherlibs/labltk/Makefile create mode 100644 otherlibs/labltk/Makefile.nt create mode 100644 otherlibs/labltk/README create mode 100644 otherlibs/labltk/Widgets.src create mode 100644 otherlibs/labltk/browser/.cvsignore create mode 100644 otherlibs/labltk/browser/.depend create mode 100644 otherlibs/labltk/browser/Makefile create mode 100644 otherlibs/labltk/browser/Makefile.nt create mode 100644 otherlibs/labltk/browser/README create mode 100644 otherlibs/labltk/browser/dummyUnix.mli create mode 100644 otherlibs/labltk/browser/dummyWin.mli create mode 100644 otherlibs/labltk/browser/editor.ml create mode 100644 otherlibs/labltk/browser/editor.mli create mode 100644 otherlibs/labltk/browser/fileselect.ml create mode 100644 otherlibs/labltk/browser/fileselect.mli create mode 100644 otherlibs/labltk/browser/help.ml create mode 100644 otherlibs/labltk/browser/help.txt create mode 100644 otherlibs/labltk/browser/jg_bind.ml create mode 100644 otherlibs/labltk/browser/jg_bind.mli create mode 100644 otherlibs/labltk/browser/jg_box.ml create mode 100644 otherlibs/labltk/browser/jg_button.ml create mode 100644 otherlibs/labltk/browser/jg_completion.ml create mode 100644 otherlibs/labltk/browser/jg_completion.mli create mode 100644 otherlibs/labltk/browser/jg_config.ml create mode 100644 otherlibs/labltk/browser/jg_config.mli create mode 100644 otherlibs/labltk/browser/jg_entry.ml create mode 100644 otherlibs/labltk/browser/jg_memo.ml create mode 100644 otherlibs/labltk/browser/jg_memo.mli create mode 100644 otherlibs/labltk/browser/jg_menu.ml create mode 100644 otherlibs/labltk/browser/jg_message.ml create mode 100644 otherlibs/labltk/browser/jg_message.mli create mode 100644 otherlibs/labltk/browser/jg_multibox.ml create mode 100644 otherlibs/labltk/browser/jg_multibox.mli create mode 100644 otherlibs/labltk/browser/jg_text.ml create mode 100644 otherlibs/labltk/browser/jg_text.mli create mode 100644 otherlibs/labltk/browser/jg_tk.ml create mode 100644 otherlibs/labltk/browser/jg_toplevel.ml create mode 100644 otherlibs/labltk/browser/lexical.ml create mode 100644 otherlibs/labltk/browser/lexical.mli create mode 100644 otherlibs/labltk/browser/list2.ml create mode 100644 otherlibs/labltk/browser/main.ml create mode 100644 otherlibs/labltk/browser/mytypes.mli create mode 100644 otherlibs/labltk/browser/searchid.ml create mode 100644 otherlibs/labltk/browser/searchid.mli create mode 100644 otherlibs/labltk/browser/searchpos.ml create mode 100644 otherlibs/labltk/browser/searchpos.mli create mode 100644 otherlibs/labltk/browser/setpath.ml create mode 100644 otherlibs/labltk/browser/setpath.mli create mode 100644 otherlibs/labltk/browser/shell.ml create mode 100644 otherlibs/labltk/browser/shell.mli create mode 100644 otherlibs/labltk/browser/typecheck.ml create mode 100644 otherlibs/labltk/browser/typecheck.mli create mode 100644 otherlibs/labltk/browser/useunix.ml create mode 100644 otherlibs/labltk/browser/useunix.mli create mode 100644 otherlibs/labltk/browser/viewer.ml create mode 100644 otherlibs/labltk/browser/viewer.mli create mode 100644 otherlibs/labltk/browser/winmain.c create mode 100644 otherlibs/labltk/builtin/LICENSE create mode 100644 otherlibs/labltk/builtin/builtin_FilePattern.ml create mode 100644 otherlibs/labltk/builtin/builtin_GetBitmap.ml create mode 100644 otherlibs/labltk/builtin/builtin_GetCursor.ml create mode 100644 otherlibs/labltk/builtin/builtin_GetPixel.ml create mode 100644 otherlibs/labltk/builtin/builtin_ScrollValue.ml create mode 100644 otherlibs/labltk/builtin/builtin_bind.ml create mode 100644 otherlibs/labltk/builtin/builtin_bindtags.ml create mode 100644 otherlibs/labltk/builtin/builtin_font.ml create mode 100644 otherlibs/labltk/builtin/builtin_grab.ml create mode 100644 otherlibs/labltk/builtin/builtin_index.ml create mode 100644 otherlibs/labltk/builtin/builtin_palette.ml create mode 100644 otherlibs/labltk/builtin/builtin_text.ml create mode 100644 otherlibs/labltk/builtin/builtina_empty.ml create mode 100644 otherlibs/labltk/builtin/builtinf_GetPixel.ml create mode 100644 otherlibs/labltk/builtin/builtinf_bind.ml create mode 100644 otherlibs/labltk/builtin/builtini_GetBitmap.ml create mode 100644 otherlibs/labltk/builtin/builtini_GetCursor.ml create mode 100644 otherlibs/labltk/builtin/builtini_GetPixel.ml create mode 100644 otherlibs/labltk/builtin/builtini_ScrollValue.ml create mode 100644 otherlibs/labltk/builtin/builtini_bind.ml create mode 100644 otherlibs/labltk/builtin/builtini_bindtags.ml create mode 100644 otherlibs/labltk/builtin/builtini_font.ml create mode 100644 otherlibs/labltk/builtin/builtini_grab.ml create mode 100644 otherlibs/labltk/builtin/builtini_index.ml create mode 100644 otherlibs/labltk/builtin/builtini_palette.ml create mode 100644 otherlibs/labltk/builtin/builtini_text.ml create mode 100644 otherlibs/labltk/builtin/canvas_bind.ml create mode 100644 otherlibs/labltk/builtin/canvas_bind.mli create mode 100644 otherlibs/labltk/builtin/dialog.ml create mode 100644 otherlibs/labltk/builtin/dialog.mli create mode 100644 otherlibs/labltk/builtin/image.ml create mode 100644 otherlibs/labltk/builtin/image.mli create mode 100644 otherlibs/labltk/builtin/optionmenu.ml create mode 100644 otherlibs/labltk/builtin/optionmenu.mli create mode 100644 otherlibs/labltk/builtin/rawimg.ml create mode 100644 otherlibs/labltk/builtin/rawimg.mli create mode 100644 otherlibs/labltk/builtin/report.ml create mode 100644 otherlibs/labltk/builtin/selection_handle_set.ml create mode 100644 otherlibs/labltk/builtin/selection_handle_set.mli create mode 100644 otherlibs/labltk/builtin/selection_own_set.ml create mode 100644 otherlibs/labltk/builtin/selection_own_set.mli create mode 100644 otherlibs/labltk/builtin/text_tag_bind.ml create mode 100644 otherlibs/labltk/builtin/text_tag_bind.mli create mode 100644 otherlibs/labltk/builtin/winfo_contained.ml create mode 100644 otherlibs/labltk/builtin/winfo_contained.mli create mode 100644 otherlibs/labltk/camltk/.cvsignore create mode 100644 otherlibs/labltk/camltk/Makefile create mode 100644 otherlibs/labltk/camltk/Makefile.gen create mode 100644 otherlibs/labltk/camltk/Makefile.gen.nt create mode 100644 otherlibs/labltk/camltk/Makefile.nt create mode 100644 otherlibs/labltk/camltk/modules create mode 100644 otherlibs/labltk/compiler/.cvsignore create mode 100644 otherlibs/labltk/compiler/.depend create mode 100644 otherlibs/labltk/compiler/Makefile create mode 100644 otherlibs/labltk/compiler/Makefile.nt create mode 100644 otherlibs/labltk/compiler/code.mli create mode 100644 otherlibs/labltk/compiler/compile.ml create mode 100644 otherlibs/labltk/compiler/copyright create mode 100644 otherlibs/labltk/compiler/flags.ml create mode 100644 otherlibs/labltk/compiler/intf.ml create mode 100644 otherlibs/labltk/compiler/lexer.mll create mode 100644 otherlibs/labltk/compiler/maincompile.ml create mode 100644 otherlibs/labltk/compiler/parser.mly create mode 100644 otherlibs/labltk/compiler/pp.ml create mode 100644 otherlibs/labltk/compiler/ppexec.ml create mode 100644 otherlibs/labltk/compiler/pplex.mli create mode 100644 otherlibs/labltk/compiler/pplex.mll create mode 100644 otherlibs/labltk/compiler/ppparse.ml create mode 100644 otherlibs/labltk/compiler/ppyac.mly create mode 100644 otherlibs/labltk/compiler/printer.ml create mode 100644 otherlibs/labltk/compiler/tables.ml create mode 100644 otherlibs/labltk/compiler/tsort.ml create mode 100644 otherlibs/labltk/examples_camltk/.cvsignore create mode 100644 otherlibs/labltk/examples_camltk/Makefile create mode 100644 otherlibs/labltk/examples_camltk/Makefile.nt create mode 100644 otherlibs/labltk/examples_camltk/addition.ml create mode 100644 otherlibs/labltk/examples_camltk/eyes.ml create mode 100644 otherlibs/labltk/examples_camltk/fileinput.ml create mode 100644 otherlibs/labltk/examples_camltk/fileopen.ml create mode 100644 otherlibs/labltk/examples_camltk/helloworld.ml create mode 100644 otherlibs/labltk/examples_camltk/images/CamlBook.gif create mode 100644 otherlibs/labltk/examples_camltk/images/Lambda2.back.gif create mode 100644 otherlibs/labltk/examples_camltk/images/dojoji.back.gif create mode 100644 otherlibs/labltk/examples_camltk/jptest.ml create mode 100644 otherlibs/labltk/examples_camltk/mytext.ml create mode 100644 otherlibs/labltk/examples_camltk/socketinput.ml create mode 100644 otherlibs/labltk/examples_camltk/taddition.ml create mode 100644 otherlibs/labltk/examples_camltk/tetris.ml create mode 100644 otherlibs/labltk/examples_camltk/text.ml create mode 100644 otherlibs/labltk/examples_camltk/winskel.ml create mode 100644 otherlibs/labltk/examples_labltk/.cvsignore create mode 100644 otherlibs/labltk/examples_labltk/Lambda2.back.gif create mode 100644 otherlibs/labltk/examples_labltk/Makefile create mode 100644 otherlibs/labltk/examples_labltk/Makefile.nt create mode 100644 otherlibs/labltk/examples_labltk/README create mode 100644 otherlibs/labltk/examples_labltk/calc.ml create mode 100644 otherlibs/labltk/examples_labltk/clock.ml create mode 100644 otherlibs/labltk/examples_labltk/demo.ml create mode 100644 otherlibs/labltk/examples_labltk/eyes.ml create mode 100644 otherlibs/labltk/examples_labltk/hello.ml create mode 100755 otherlibs/labltk/examples_labltk/hello.tcl create mode 100644 otherlibs/labltk/examples_labltk/lang.ml create mode 100644 otherlibs/labltk/examples_labltk/taquin.ml create mode 100644 otherlibs/labltk/examples_labltk/tetris.ml create mode 100644 otherlibs/labltk/frx/.depend create mode 100644 otherlibs/labltk/frx/Makefile create mode 100644 otherlibs/labltk/frx/Makefile.nt create mode 100644 otherlibs/labltk/frx/README create mode 100644 otherlibs/labltk/frx/frx_after.ml create mode 100644 otherlibs/labltk/frx/frx_after.mli create mode 100644 otherlibs/labltk/frx/frx_color.ml create mode 100644 otherlibs/labltk/frx/frx_color.mli create mode 100644 otherlibs/labltk/frx/frx_ctext.ml create mode 100644 otherlibs/labltk/frx/frx_ctext.mli create mode 100644 otherlibs/labltk/frx/frx_dialog.ml create mode 100644 otherlibs/labltk/frx/frx_dialog.mli create mode 100644 otherlibs/labltk/frx/frx_entry.ml create mode 100644 otherlibs/labltk/frx/frx_entry.mli create mode 100644 otherlibs/labltk/frx/frx_fileinput.ml create mode 100644 otherlibs/labltk/frx/frx_fillbox.ml create mode 100644 otherlibs/labltk/frx/frx_fillbox.mli create mode 100644 otherlibs/labltk/frx/frx_fit.ml create mode 100644 otherlibs/labltk/frx/frx_fit.mli create mode 100644 otherlibs/labltk/frx/frx_focus.ml create mode 100644 otherlibs/labltk/frx/frx_focus.mli create mode 100644 otherlibs/labltk/frx/frx_font.ml create mode 100644 otherlibs/labltk/frx/frx_font.mli create mode 100644 otherlibs/labltk/frx/frx_group.ml create mode 100644 otherlibs/labltk/frx/frx_lbutton.ml create mode 100644 otherlibs/labltk/frx/frx_lbutton.mli create mode 100644 otherlibs/labltk/frx/frx_listbox.ml create mode 100644 otherlibs/labltk/frx/frx_listbox.mli create mode 100644 otherlibs/labltk/frx/frx_mem.ml create mode 100644 otherlibs/labltk/frx/frx_mem.mli create mode 100644 otherlibs/labltk/frx/frx_misc.ml create mode 100644 otherlibs/labltk/frx/frx_misc.mli create mode 100644 otherlibs/labltk/frx/frx_req.ml create mode 100644 otherlibs/labltk/frx/frx_req.mli create mode 100644 otherlibs/labltk/frx/frx_rpc.ml create mode 100644 otherlibs/labltk/frx/frx_rpc.mli create mode 100644 otherlibs/labltk/frx/frx_selection.ml create mode 100644 otherlibs/labltk/frx/frx_selection.mli create mode 100644 otherlibs/labltk/frx/frx_synth.ml create mode 100644 otherlibs/labltk/frx/frx_synth.mli create mode 100644 otherlibs/labltk/frx/frx_text.ml create mode 100644 otherlibs/labltk/frx/frx_text.mli create mode 100644 otherlibs/labltk/frx/frx_toplevel.mli create mode 100644 otherlibs/labltk/frx/frx_widget.ml create mode 100644 otherlibs/labltk/frx/frx_widget.mli create mode 100644 otherlibs/labltk/jpf/Makefile create mode 100644 otherlibs/labltk/jpf/Makefile.nt create mode 100644 otherlibs/labltk/jpf/README create mode 100644 otherlibs/labltk/jpf/balloon.ml create mode 100644 otherlibs/labltk/jpf/balloon.mli create mode 100644 otherlibs/labltk/jpf/balloontest.ml create mode 100644 otherlibs/labltk/jpf/fileselect.ml create mode 100644 otherlibs/labltk/jpf/fileselect.mli create mode 100644 otherlibs/labltk/jpf/jpf_font.ml create mode 100644 otherlibs/labltk/jpf/jpf_font.mli create mode 100644 otherlibs/labltk/jpf/shell.ml create mode 100644 otherlibs/labltk/jpf/shell.mli create mode 100644 otherlibs/labltk/labl.gif create mode 100644 otherlibs/labltk/labltk/.cvsignore create mode 100644 otherlibs/labltk/labltk/Makefile create mode 100644 otherlibs/labltk/labltk/Makefile.gen create mode 100644 otherlibs/labltk/labltk/Makefile.gen.nt create mode 100644 otherlibs/labltk/labltk/Makefile.nt create mode 100644 otherlibs/labltk/labltk/modules create mode 100644 otherlibs/labltk/lib/.cvsignore create mode 100644 otherlibs/labltk/lib/Makefile create mode 100644 otherlibs/labltk/lib/Makefile.nt create mode 100644 otherlibs/labltk/support/.depend create mode 100644 otherlibs/labltk/support/Makefile create mode 100644 otherlibs/labltk/support/Makefile.common create mode 100644 otherlibs/labltk/support/Makefile.common.nt create mode 100644 otherlibs/labltk/support/Makefile.nt create mode 100644 otherlibs/labltk/support/camltk.h create mode 100644 otherlibs/labltk/support/camltkwrap.ml create mode 100644 otherlibs/labltk/support/camltkwrap.mli create mode 100644 otherlibs/labltk/support/cltkCaml.c create mode 100644 otherlibs/labltk/support/cltkDMain.c create mode 100644 otherlibs/labltk/support/cltkEval.c create mode 100644 otherlibs/labltk/support/cltkEvent.c create mode 100644 otherlibs/labltk/support/cltkFile.c create mode 100644 otherlibs/labltk/support/cltkImg.c create mode 100644 otherlibs/labltk/support/cltkMain.c create mode 100644 otherlibs/labltk/support/cltkMisc.c create mode 100644 otherlibs/labltk/support/cltkTimer.c create mode 100644 otherlibs/labltk/support/cltkUtf.c create mode 100644 otherlibs/labltk/support/cltkVar.c create mode 100644 otherlibs/labltk/support/cltkWait.c create mode 100644 otherlibs/labltk/support/fileevent.ml create mode 100644 otherlibs/labltk/support/fileevent.mli create mode 100644 otherlibs/labltk/support/protocol.ml create mode 100644 otherlibs/labltk/support/protocol.mli create mode 100644 otherlibs/labltk/support/rawwidget.ml create mode 100644 otherlibs/labltk/support/rawwidget.mli create mode 100644 otherlibs/labltk/support/slave.ml create mode 100644 otherlibs/labltk/support/support.ml create mode 100644 otherlibs/labltk/support/support.mli create mode 100644 otherlibs/labltk/support/textvariable.ml create mode 100644 otherlibs/labltk/support/textvariable.mli create mode 100644 otherlibs/labltk/support/timer.ml create mode 100644 otherlibs/labltk/support/timer.mli create mode 100644 otherlibs/labltk/support/tkwait.ml create mode 100644 otherlibs/labltk/support/widget.ml create mode 100644 otherlibs/labltk/support/widget.mli create mode 100644 otherlibs/labltk/tkanim/.cvsignore create mode 100644 otherlibs/labltk/tkanim/.depend create mode 100644 otherlibs/labltk/tkanim/Makefile create mode 100644 otherlibs/labltk/tkanim/Makefile.nt create mode 100644 otherlibs/labltk/tkanim/README create mode 100644 otherlibs/labltk/tkanim/cltkaniminit.c create mode 100644 otherlibs/labltk/tkanim/gifanimtest.ml create mode 100644 otherlibs/labltk/tkanim/mmm.anim.gif create mode 100644 otherlibs/labltk/tkanim/tkAnimGIF.c create mode 100644 otherlibs/labltk/tkanim/tkAppInit.c create mode 100644 otherlibs/labltk/tkanim/tkanim.ml create mode 100644 otherlibs/labltk/tkanim/tkanim.mli create mode 100644 otherlibs/macosunix/.cvsignore create mode 100644 otherlibs/macosunix/Makefile.Mac create mode 100644 otherlibs/macosunix/Makefile.Mac.depend create mode 100644 otherlibs/macosunix/macosunix.c create mode 100644 otherlibs/macosunix/macosunix_startup.ml create mode 100644 otherlibs/macosunix/macosunix_startup.mli create mode 100644 otherlibs/macosunix/unix-primitives create mode 100644 otherlibs/macosunix/unixsupport.h create mode 100644 otherlibs/num/.cvsignore create mode 100644 otherlibs/num/.depend create mode 100644 otherlibs/num/.depend.nt create mode 100644 otherlibs/num/Makefile create mode 100644 otherlibs/num/Makefile.Mac create mode 100644 otherlibs/num/Makefile.Mac.depend create mode 100644 otherlibs/num/Makefile.nt create mode 100644 otherlibs/num/README create mode 100644 otherlibs/num/arith_flags.ml create mode 100644 otherlibs/num/arith_flags.mli create mode 100644 otherlibs/num/arith_status.ml create mode 100644 otherlibs/num/arith_status.mli create mode 100644 otherlibs/num/big_int.ml create mode 100644 otherlibs/num/big_int.mli create mode 100644 otherlibs/num/bignum/.cvsignore create mode 100644 otherlibs/num/bignum/Makefile create mode 100644 otherlibs/num/bignum/Makefile.Mac create mode 100644 otherlibs/num/bignum/Makefile.nt create mode 100644 otherlibs/num/bignum/README create mode 100644 otherlibs/num/bignum/c/KerN.c create mode 100644 otherlibs/num/bignum/c/bn/bnCmp.c create mode 100644 otherlibs/num/bignum/c/bn/bnDivide.c create mode 100644 otherlibs/num/bignum/c/bn/bnInit.c create mode 100644 otherlibs/num/bignum/c/bn/bnMult.c create mode 100644 otherlibs/num/bignum/c/bz.c create mode 100644 otherlibs/num/bignum/c/bzf.c create mode 100644 otherlibs/num/bignum/c/bztest.c create mode 100644 otherlibs/num/bignum/c/testKerN.c create mode 100644 otherlibs/num/bignum/h/BigNum.h create mode 100644 otherlibs/num/bignum/h/BigZ.h create mode 100644 otherlibs/num/bignum/h/BntoBnn.h create mode 100644 otherlibs/num/bignum/o/.cvsignore create mode 100644 otherlibs/num/bignum/o/EMPTY create mode 100644 otherlibs/num/bignum/s/68KerN.s create mode 100644 otherlibs/num/bignum/s/68KerN_mot.s create mode 100644 otherlibs/num/bignum/s/68KerN_sony.s create mode 100644 otherlibs/num/bignum/s/RS6000KerN.s create mode 100644 otherlibs/num/bignum/s/alphaKerN.s create mode 100644 otherlibs/num/bignum/s/hpKerN.s create mode 100644 otherlibs/num/bignum/s/i960KerN.s create mode 100644 otherlibs/num/bignum/s/mipsKerN.s create mode 100644 otherlibs/num/bignum/s/nsKerN.s create mode 100644 otherlibs/num/bignum/s/pyramidKerN.s create mode 100644 otherlibs/num/bignum/s/sparcKerN.s create mode 100644 otherlibs/num/bignum/s/sparcfpuKerN.s create mode 100644 otherlibs/num/bignum/s/supersparcKerN.s create mode 100644 otherlibs/num/bignum/s/unix2vms.sed create mode 100644 otherlibs/num/bignum/s/vaxKerN.mar create mode 100644 otherlibs/num/bignum/s/vaxKerN.s create mode 100644 otherlibs/num/bignum/s/x86KerN.s create mode 100644 otherlibs/num/int_misc.ml create mode 100644 otherlibs/num/int_misc.mli create mode 100644 otherlibs/num/nat.h create mode 100644 otherlibs/num/nat.ml create mode 100644 otherlibs/num/nat.mli create mode 100644 otherlibs/num/nat_stubs.c create mode 100644 otherlibs/num/num.ml create mode 100644 otherlibs/num/num.mli create mode 100644 otherlibs/num/ratio.ml create mode 100644 otherlibs/num/ratio.mli create mode 100644 otherlibs/num/string_misc.ml create mode 100644 otherlibs/num/string_misc.mli create mode 100644 otherlibs/num/test/.depend create mode 100644 otherlibs/num/test/Makefile create mode 100644 otherlibs/num/test/Makefile.Mac create mode 100644 otherlibs/num/test/Makefile.Mac.depend create mode 100644 otherlibs/num/test/Makefile.nt create mode 100644 otherlibs/num/test/end_test.ml create mode 100644 otherlibs/num/test/test.ml create mode 100644 otherlibs/num/test/test_big_ints.ml create mode 100644 otherlibs/num/test/test_io.ml create mode 100644 otherlibs/num/test/test_nats.ml create mode 100644 otherlibs/num/test/test_nums.ml create mode 100644 otherlibs/num/test/test_ratios.ml create mode 100644 otherlibs/str/.cvsignore create mode 100644 otherlibs/str/.depend create mode 100644 otherlibs/str/Makefile create mode 100644 otherlibs/str/Makefile.Mac create mode 100644 otherlibs/str/Makefile.Mac.depend create mode 100644 otherlibs/str/Makefile.nt create mode 100644 otherlibs/str/str.ml create mode 100644 otherlibs/str/str.mli create mode 100644 otherlibs/str/strstubs.c create mode 100644 otherlibs/systhreads/.cvsignore create mode 100644 otherlibs/systhreads/.depend create mode 100644 otherlibs/systhreads/Makefile create mode 100644 otherlibs/systhreads/Makefile.Mac create mode 100644 otherlibs/systhreads/Makefile.Mac.depend create mode 100644 otherlibs/systhreads/Makefile.nt create mode 100644 otherlibs/systhreads/condition.ml create mode 100644 otherlibs/systhreads/condition.mli create mode 100644 otherlibs/systhreads/event.ml create mode 100644 otherlibs/systhreads/event.mli create mode 100644 otherlibs/systhreads/mutex.ml create mode 100644 otherlibs/systhreads/mutex.mli create mode 100644 otherlibs/systhreads/posix.c create mode 100644 otherlibs/systhreads/thread.mli create mode 100644 otherlibs/systhreads/threadUnix.ml create mode 100644 otherlibs/systhreads/threadUnix.mli create mode 100644 otherlibs/systhreads/thread_posix.ml create mode 100644 otherlibs/systhreads/thread_win32.ml create mode 100644 otherlibs/systhreads/win32.c create mode 100644 otherlibs/threads/.cvsignore create mode 100644 otherlibs/threads/.depend create mode 100644 otherlibs/threads/Makefile create mode 100644 otherlibs/threads/condition.ml create mode 100644 otherlibs/threads/condition.mli create mode 100644 otherlibs/threads/event.ml create mode 100644 otherlibs/threads/event.mli create mode 100644 otherlibs/threads/marshal.ml create mode 100644 otherlibs/threads/mutex.ml create mode 100644 otherlibs/threads/mutex.mli create mode 100644 otherlibs/threads/pervasives.ml create mode 100644 otherlibs/threads/scheduler.c create mode 100644 otherlibs/threads/thread.ml create mode 100644 otherlibs/threads/thread.mli create mode 100644 otherlibs/threads/threadUnix.ml create mode 100644 otherlibs/threads/threadUnix.mli create mode 100644 otherlibs/threads/unix.ml create mode 100644 otherlibs/unix/.cvsignore create mode 100644 otherlibs/unix/.depend create mode 100644 otherlibs/unix/Makefile create mode 100644 otherlibs/unix/accept.c create mode 100644 otherlibs/unix/access.c create mode 100644 otherlibs/unix/addrofstr.c create mode 100644 otherlibs/unix/alarm.c create mode 100644 otherlibs/unix/bind.c create mode 100644 otherlibs/unix/chdir.c create mode 100644 otherlibs/unix/chmod.c create mode 100644 otherlibs/unix/chown.c create mode 100644 otherlibs/unix/chroot.c create mode 100644 otherlibs/unix/close.c create mode 100644 otherlibs/unix/closedir.c create mode 100644 otherlibs/unix/connect.c create mode 100644 otherlibs/unix/cst2constr.c create mode 100644 otherlibs/unix/cst2constr.h create mode 100644 otherlibs/unix/cstringv.c create mode 100644 otherlibs/unix/dup.c create mode 100644 otherlibs/unix/dup2.c create mode 100644 otherlibs/unix/envir.c create mode 100644 otherlibs/unix/errmsg.c create mode 100644 otherlibs/unix/execv.c create mode 100644 otherlibs/unix/execve.c create mode 100644 otherlibs/unix/execvp.c create mode 100644 otherlibs/unix/exit.c create mode 100644 otherlibs/unix/fchmod.c create mode 100644 otherlibs/unix/fchown.c create mode 100644 otherlibs/unix/fcntl.c create mode 100644 otherlibs/unix/fork.c create mode 100644 otherlibs/unix/ftruncate.c create mode 100644 otherlibs/unix/getcwd.c create mode 100644 otherlibs/unix/getegid.c create mode 100644 otherlibs/unix/geteuid.c create mode 100644 otherlibs/unix/getgid.c create mode 100644 otherlibs/unix/getgr.c create mode 100644 otherlibs/unix/getgroups.c create mode 100644 otherlibs/unix/gethost.c create mode 100644 otherlibs/unix/gethostname.c create mode 100644 otherlibs/unix/getlogin.c create mode 100644 otherlibs/unix/getpeername.c create mode 100644 otherlibs/unix/getpid.c create mode 100644 otherlibs/unix/getppid.c create mode 100644 otherlibs/unix/getproto.c create mode 100644 otherlibs/unix/getpw.c create mode 100644 otherlibs/unix/getserv.c create mode 100644 otherlibs/unix/getsockname.c create mode 100644 otherlibs/unix/gettimeofday.c create mode 100644 otherlibs/unix/getuid.c create mode 100644 otherlibs/unix/gmtime.c create mode 100644 otherlibs/unix/itimer.c create mode 100644 otherlibs/unix/kill.c create mode 100644 otherlibs/unix/link.c create mode 100644 otherlibs/unix/listen.c create mode 100644 otherlibs/unix/lockf.c create mode 100644 otherlibs/unix/lseek.c create mode 100644 otherlibs/unix/mkdir.c create mode 100644 otherlibs/unix/mkfifo.c create mode 100644 otherlibs/unix/nice.c create mode 100644 otherlibs/unix/open.c create mode 100644 otherlibs/unix/opendir.c create mode 100644 otherlibs/unix/pipe.c create mode 100644 otherlibs/unix/putenv.c create mode 100644 otherlibs/unix/read.c create mode 100644 otherlibs/unix/readdir.c create mode 100644 otherlibs/unix/readlink.c create mode 100644 otherlibs/unix/rename.c create mode 100644 otherlibs/unix/rewinddir.c create mode 100644 otherlibs/unix/rmdir.c create mode 100644 otherlibs/unix/select.c create mode 100644 otherlibs/unix/sendrecv.c create mode 100644 otherlibs/unix/setgid.c create mode 100644 otherlibs/unix/setsid.c create mode 100644 otherlibs/unix/setuid.c create mode 100644 otherlibs/unix/shutdown.c create mode 100644 otherlibs/unix/signals.c create mode 100644 otherlibs/unix/sleep.c create mode 100644 otherlibs/unix/socket.c create mode 100644 otherlibs/unix/socketaddr.c create mode 100644 otherlibs/unix/socketaddr.h create mode 100644 otherlibs/unix/socketpair.c create mode 100644 otherlibs/unix/sockopt.c create mode 100644 otherlibs/unix/stat.c create mode 100644 otherlibs/unix/strofaddr.c create mode 100644 otherlibs/unix/symlink.c create mode 100644 otherlibs/unix/termios.c create mode 100644 otherlibs/unix/time.c create mode 100644 otherlibs/unix/times.c create mode 100644 otherlibs/unix/truncate.c create mode 100644 otherlibs/unix/umask.c create mode 100644 otherlibs/unix/unix.ml create mode 100644 otherlibs/unix/unix.mli create mode 100644 otherlibs/unix/unixLabels.ml create mode 100644 otherlibs/unix/unixLabels.mli create mode 100644 otherlibs/unix/unixsupport.c create mode 100644 otherlibs/unix/unixsupport.h create mode 100644 otherlibs/unix/unlink.c create mode 100644 otherlibs/unix/utimes.c create mode 100644 otherlibs/unix/wait.c create mode 100644 otherlibs/unix/write.c create mode 100644 otherlibs/win32graph/Makefile.nt create mode 100644 otherlibs/win32graph/dib.c create mode 100644 otherlibs/win32graph/draw.c create mode 100644 otherlibs/win32graph/libgraph.h create mode 100644 otherlibs/win32graph/open.c create mode 100644 otherlibs/win32unix/.cvsignore create mode 100644 otherlibs/win32unix/.depend create mode 100644 otherlibs/win32unix/Makefile.nt create mode 100644 otherlibs/win32unix/accept.c create mode 100644 otherlibs/win32unix/bind.c create mode 100644 otherlibs/win32unix/channels.c create mode 100644 otherlibs/win32unix/close.c create mode 100644 otherlibs/win32unix/close_on.c create mode 100644 otherlibs/win32unix/connect.c create mode 100644 otherlibs/win32unix/createprocess.c create mode 100644 otherlibs/win32unix/dup.c create mode 100644 otherlibs/win32unix/dup2.c create mode 100644 otherlibs/win32unix/errmsg.c create mode 100644 otherlibs/win32unix/getpeername.c create mode 100644 otherlibs/win32unix/getpid.c create mode 100644 otherlibs/win32unix/getsockname.c create mode 100644 otherlibs/win32unix/gettimeofday.c create mode 100644 otherlibs/win32unix/link.c create mode 100644 otherlibs/win32unix/listen.c create mode 100644 otherlibs/win32unix/lockf.c create mode 100644 otherlibs/win32unix/lseek.c create mode 100644 otherlibs/win32unix/mkdir.c create mode 100755 otherlibs/win32unix/nonblock.c create mode 100644 otherlibs/win32unix/open.c create mode 100644 otherlibs/win32unix/pipe.c create mode 100644 otherlibs/win32unix/read.c create mode 100644 otherlibs/win32unix/rename.c create mode 100644 otherlibs/win32unix/select.c create mode 100644 otherlibs/win32unix/sendrecv.c create mode 100644 otherlibs/win32unix/shutdown.c create mode 100644 otherlibs/win32unix/sleep.c create mode 100644 otherlibs/win32unix/socket.c create mode 100644 otherlibs/win32unix/socketaddr.h create mode 100644 otherlibs/win32unix/sockopt.c create mode 100644 otherlibs/win32unix/startup.c create mode 100644 otherlibs/win32unix/stat.c create mode 100644 otherlibs/win32unix/system.c create mode 100644 otherlibs/win32unix/unix.ml create mode 100644 otherlibs/win32unix/unixsupport.c create mode 100644 otherlibs/win32unix/unixsupport.h create mode 100644 otherlibs/win32unix/windir.c create mode 100644 otherlibs/win32unix/winwait.c create mode 100644 otherlibs/win32unix/write.c create mode 100644 parsing/.cvsignore create mode 100644 parsing/asttypes.mli create mode 100644 parsing/lexer.mli create mode 100644 parsing/lexer.mll create mode 100644 parsing/linenum.mli create mode 100644 parsing/linenum.mll create mode 100644 parsing/location.ml create mode 100644 parsing/location.mli create mode 100644 parsing/longident.ml create mode 100644 parsing/longident.mli create mode 100644 parsing/parse.ml create mode 100644 parsing/parse.mli create mode 100644 parsing/parser.mly create mode 100644 parsing/parsetree.mli create mode 100644 parsing/printast.ml create mode 100644 parsing/printast.mli create mode 100644 parsing/syntaxerr.ml create mode 100644 parsing/syntaxerr.mli create mode 100644 stdlib/.cvsignore create mode 100644 stdlib/.depend create mode 100644 stdlib/Makefile create mode 100644 stdlib/Makefile.Mac create mode 100644 stdlib/Makefile.Mac.depend create mode 100644 stdlib/Makefile.nt create mode 100644 stdlib/StdlibModules create mode 100644 stdlib/arg.ml create mode 100644 stdlib/arg.mli create mode 100644 stdlib/array.ml create mode 100644 stdlib/array.mli create mode 100644 stdlib/arrayLabels.ml create mode 100644 stdlib/arrayLabels.mli create mode 100644 stdlib/buffer.ml create mode 100644 stdlib/buffer.mli create mode 100644 stdlib/callback.ml create mode 100644 stdlib/callback.mli create mode 100644 stdlib/camlinternalOO.ml create mode 100644 stdlib/camlinternalOO.mli create mode 100644 stdlib/char.ml create mode 100644 stdlib/char.mli create mode 100644 stdlib/complex.ml create mode 100644 stdlib/complex.mli create mode 100644 stdlib/digest.ml create mode 100644 stdlib/digest.mli create mode 100644 stdlib/filename.ml create mode 100644 stdlib/filename.mli create mode 100644 stdlib/format.ml create mode 100644 stdlib/format.mli create mode 100644 stdlib/gc.ml create mode 100644 stdlib/gc.mli create mode 100644 stdlib/genlex.ml create mode 100644 stdlib/genlex.mli create mode 100644 stdlib/hashtbl.ml create mode 100644 stdlib/hashtbl.mli create mode 100644 stdlib/header.c create mode 100644 stdlib/headernt.c create mode 100644 stdlib/int32.ml create mode 100644 stdlib/int32.mli create mode 100644 stdlib/int64.ml create mode 100644 stdlib/int64.mli create mode 100644 stdlib/lazy.ml create mode 100644 stdlib/lazy.mli create mode 100644 stdlib/lexing.ml create mode 100644 stdlib/lexing.mli create mode 100644 stdlib/list.ml create mode 100644 stdlib/list.mli create mode 100644 stdlib/listLabels.ml create mode 100644 stdlib/listLabels.mli create mode 100644 stdlib/map.ml create mode 100644 stdlib/map.mli create mode 100644 stdlib/marshal.ml create mode 100644 stdlib/marshal.mli create mode 100644 stdlib/moreLabels.ml create mode 100644 stdlib/moreLabels.mli create mode 100644 stdlib/nativeint.ml create mode 100644 stdlib/nativeint.mli create mode 100644 stdlib/obj.ml create mode 100644 stdlib/obj.mli create mode 100644 stdlib/oo.ml create mode 100644 stdlib/oo.mli create mode 100644 stdlib/parsing.ml create mode 100644 stdlib/parsing.mli create mode 100644 stdlib/pervasives.ml create mode 100644 stdlib/pervasives.mli create mode 100644 stdlib/printexc.ml create mode 100644 stdlib/printexc.mli create mode 100644 stdlib/printf.ml create mode 100644 stdlib/printf.mli create mode 100644 stdlib/queue.ml create mode 100644 stdlib/queue.mli create mode 100644 stdlib/random.ml create mode 100644 stdlib/random.mli create mode 100644 stdlib/scanf.ml create mode 100644 stdlib/scanf.mli create mode 100644 stdlib/set.ml create mode 100644 stdlib/set.mli create mode 100644 stdlib/sharpbang create mode 100644 stdlib/sort.ml create mode 100644 stdlib/sort.mli create mode 100644 stdlib/stack.ml create mode 100644 stdlib/stack.mli create mode 100644 stdlib/stdLabels.ml create mode 100644 stdlib/stdLabels.mli create mode 100644 stdlib/std_exit.ml create mode 100644 stdlib/stream.ml create mode 100644 stdlib/stream.mli create mode 100644 stdlib/string.ml create mode 100644 stdlib/string.mli create mode 100644 stdlib/stringLabels.ml create mode 100644 stdlib/stringLabels.mli create mode 100644 stdlib/sys.ml create mode 100644 stdlib/sys.mli create mode 100644 stdlib/weak.ml create mode 100644 stdlib/weak.mli create mode 100644 tools/.cvsignore create mode 100644 tools/.depend create mode 100644 tools/Characters create mode 100644 tools/DoMake create mode 100644 tools/MakeDepend create mode 100644 tools/Makefile create mode 100644 tools/Makefile.Mac create mode 100644 tools/Makefile.Mac.depend create mode 100644 tools/Makefile.nt create mode 100644 tools/OCamlc-custom create mode 100644 tools/Time create mode 100644 tools/addlabels.ml create mode 100644 tools/checkstack.c create mode 100644 tools/cleanup-header create mode 100644 tools/cvt_emit.mll create mode 100644 tools/depend.ml create mode 100644 tools/depend.mli create mode 100644 tools/dumpapprox.ml create mode 100644 tools/dumpobj.ml create mode 100644 tools/keywords.r create mode 100644 tools/lexer299.mll create mode 100644 tools/lexer301.mll create mode 100644 tools/magic create mode 100644 tools/make-opcodes create mode 100644 tools/make-opcodes.Mac create mode 100755 tools/make-package-macosx create mode 100644 tools/objinfo.ml create mode 100644 tools/ocaml299to3.ml create mode 100644 tools/ocamlcp.ml create mode 100644 tools/ocamldep.ml create mode 100644 tools/ocamlmklib.mlp create mode 100644 tools/ocamlmktop.ml create mode 100644 tools/ocamlmktop.tpl create mode 100644 tools/ocamlprof.ml create mode 100755 tools/ocamlsize create mode 100644 tools/primreq.ml create mode 100644 tools/profiling.ml create mode 100644 tools/profiling.mli create mode 100644 tools/scrapelabels.ml create mode 100644 toplevel/expunge.ml create mode 100644 toplevel/genprintval.ml create mode 100644 toplevel/genprintval.mli create mode 100644 toplevel/topdirs.ml create mode 100644 toplevel/topdirs.mli create mode 100644 toplevel/toploop.ml create mode 100644 toplevel/toploop.mli create mode 100644 toplevel/topmain.ml create mode 100644 toplevel/topmain.mli create mode 100644 toplevel/topstart.ml create mode 100644 toplevel/trace.ml create mode 100644 toplevel/trace.mli create mode 100644 typing/btype.ml create mode 100644 typing/btype.mli create mode 100644 typing/ctype.ml create mode 100644 typing/ctype.mli create mode 100644 typing/datarepr.ml create mode 100644 typing/datarepr.mli create mode 100644 typing/env.ml create mode 100644 typing/env.mli create mode 100644 typing/ident.ml create mode 100644 typing/ident.mli create mode 100644 typing/includeclass.ml create mode 100644 typing/includeclass.mli create mode 100644 typing/includecore.ml create mode 100644 typing/includecore.mli create mode 100644 typing/includemod.ml create mode 100644 typing/includemod.mli create mode 100644 typing/mtype.ml create mode 100644 typing/mtype.mli create mode 100644 typing/oprint.ml create mode 100644 typing/oprint.mli create mode 100644 typing/outcometree.mli create mode 100644 typing/parmatch.ml create mode 100644 typing/parmatch.mli create mode 100644 typing/path.ml create mode 100644 typing/path.mli create mode 100644 typing/predef.ml create mode 100644 typing/predef.mli create mode 100644 typing/primitive.ml create mode 100644 typing/primitive.mli create mode 100644 typing/printtyp.ml create mode 100644 typing/printtyp.mli create mode 100644 typing/stypes.ml create mode 100644 typing/stypes.mli create mode 100644 typing/subst.ml create mode 100644 typing/subst.mli create mode 100644 typing/typeclass.ml create mode 100644 typing/typeclass.mli create mode 100644 typing/typecore.ml create mode 100644 typing/typecore.mli create mode 100644 typing/typedecl.ml create mode 100644 typing/typedecl.mli create mode 100644 typing/typedtree.ml create mode 100644 typing/typedtree.mli create mode 100644 typing/typemod.ml create mode 100644 typing/typemod.mli create mode 100644 typing/types.ml create mode 100644 typing/types.mli create mode 100644 typing/typetexp.ml create mode 100644 typing/typetexp.mli create mode 100644 utils/.cvsignore create mode 100644 utils/ccomp.ml create mode 100644 utils/ccomp.mli create mode 100644 utils/clflags.ml create mode 100644 utils/config.mli create mode 100644 utils/config.mlp create mode 100644 utils/consistbl.ml create mode 100644 utils/consistbl.mli create mode 100644 utils/misc.ml create mode 100644 utils/misc.mli create mode 100644 utils/tbl.ml create mode 100644 utils/tbl.mli create mode 100644 utils/terminfo.ml create mode 100644 utils/terminfo.mli create mode 100644 utils/warnings.ml create mode 100644 utils/warnings.mli create mode 100644 win32caml/Makefile create mode 100644 win32caml/inria.h create mode 100644 win32caml/inriares.h create mode 100644 win32caml/libgraph.h create mode 100644 win32caml/menu.c create mode 100644 win32caml/ocaml.c create mode 100644 win32caml/ocaml.ico create mode 100644 win32caml/ocaml.rc create mode 100644 win32caml/startocaml.c create mode 100644 yacc/.cvsignore create mode 100644 yacc/Makefile create mode 100644 yacc/Makefile.Mac create mode 100644 yacc/Makefile.nt create mode 100644 yacc/closure.c create mode 100644 yacc/defs.h create mode 100644 yacc/error.c create mode 100644 yacc/lalr.c create mode 100644 yacc/lr0.c create mode 100644 yacc/main.c create mode 100644 yacc/mkpar.c create mode 100644 yacc/output.c create mode 100644 yacc/reader.c create mode 100644 yacc/skeleton.c create mode 100644 yacc/symtab.c create mode 100644 yacc/verbose.c create mode 100644 yacc/warshall.c diff --git a/.cvsignore b/.cvsignore new file mode 100644 index 00000000..f3ba5343 --- /dev/null +++ b/.cvsignore @@ -0,0 +1,14 @@ +.cvsignore +.depend +configure +configure_latour +ocamlc +ocamlc.opt +expunge +ocaml +ocamlopt +ocamlopt.opt +ocamlcomp.sh +ocamlcompopt.sh +package-macosx +.DS_Store diff --git a/.depend b/.depend new file mode 100644 index 00000000..5b12a5fa --- /dev/null +++ b/.depend @@ -0,0 +1,772 @@ +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/cmmgen.cmi: asmcomp/clambda.cmi asmcomp/cmm.cmi +asmcomp/cmm.cmi: typing/ident.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/reloadgen.cmi: asmcomp/mach.cmi asmcomp/reg.cmi +asmcomp/reload.cmi: asmcomp/mach.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/misc.cmi +asmcomp/arch.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/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/cmm.cmo: asmcomp/arch.cmo typing/ident.cmi asmcomp/cmm.cmi +asmcomp/cmm.cmx: asmcomp/arch.cmx typing/ident.cmx asmcomp/cmm.cmi +asmcomp/codegen.cmo: asmcomp/cmm.cmi asmcomp/coloring.cmi asmcomp/emit.cmi \ + asmcomp/interf.cmi asmcomp/linearize.cmi asmcomp/liveness.cmi \ + asmcomp/printcmm.cmi asmcomp/printlinear.cmi asmcomp/printmach.cmi \ + 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/emitaux.cmo: asmcomp/emitaux.cmi +asmcomp/emitaux.cmx: asmcomp/emitaux.cmi +asmcomp/emit.cmo: asmcomp/arch.cmo utils/clflags.cmo asmcomp/cmm.cmi \ + asmcomp/compilenv.cmi utils/config.cmi asmcomp/emitaux.cmi \ + asmcomp/linearize.cmi parsing/location.cmi asmcomp/mach.cmi \ + utils/misc.cmi asmcomp/proc.cmi asmcomp/reg.cmi asmcomp/emit.cmi +asmcomp/emit.cmx: asmcomp/arch.cmx utils/clflags.cmx asmcomp/cmm.cmx \ + asmcomp/compilenv.cmx utils/config.cmx asmcomp/emitaux.cmx \ + asmcomp/linearize.cmx parsing/location.cmx asmcomp/mach.cmx \ + utils/misc.cmx asmcomp/proc.cmx asmcomp/reg.cmx asmcomp/emit.cmi +asmcomp/interf.cmo: asmcomp/mach.cmi utils/misc.cmi asmcomp/proc.cmi \ + asmcomp/reg.cmi asmcomp/interf.cmi +asmcomp/interf.cmx: asmcomp/mach.cmx utils/misc.cmx asmcomp/proc.cmx \ + 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/reloadgen.cmo: asmcomp/mach.cmi utils/misc.cmi asmcomp/reg.cmi \ + asmcomp/reloadgen.cmi +asmcomp/reloadgen.cmx: asmcomp/mach.cmx utils/misc.cmx asmcomp/reg.cmx \ + asmcomp/reloadgen.cmi +asmcomp/reload.cmo: asmcomp/arch.cmo asmcomp/cmm.cmi asmcomp/mach.cmi \ + asmcomp/reg.cmi asmcomp/reloadgen.cmi asmcomp/reload.cmi +asmcomp/reload.cmx: asmcomp/arch.cmx asmcomp/cmm.cmx asmcomp/mach.cmx \ + asmcomp/reg.cmx asmcomp/reloadgen.cmx asmcomp/reload.cmi +asmcomp/schedgen.cmo: asmcomp/arch.cmo asmcomp/cmm.cmi asmcomp/linearize.cmi \ + asmcomp/mach.cmi utils/misc.cmi asmcomp/reg.cmi asmcomp/schedgen.cmi +asmcomp/schedgen.cmx: asmcomp/arch.cmx asmcomp/cmm.cmx asmcomp/linearize.cmx \ + asmcomp/mach.cmx utils/misc.cmx asmcomp/reg.cmx asmcomp/schedgen.cmi +asmcomp/scheduling.cmo: asmcomp/schedgen.cmi asmcomp/scheduling.cmi +asmcomp/scheduling.cmx: asmcomp/schedgen.cmx asmcomp/scheduling.cmi +asmcomp/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/proc.cmi asmcomp/reg.cmi asmcomp/selectgen.cmi \ + asmcomp/selection.cmi +asmcomp/selection.cmx: asmcomp/arch.cmx asmcomp/cmm.cmx asmcomp/mach.cmx \ + utils/misc.cmx asmcomp/proc.cmx asmcomp/reg.cmx asmcomp/selectgen.cmx \ + 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_args.cmo: driver/main_args.cmi +driver/main_args.cmx: driver/main_args.cmi +driver/main.cmo: bytecomp/bytelibrarian.cmi bytecomp/bytelink.cmi \ + bytecomp/bytepackager.cmi utils/clflags.cmo driver/compile.cmi \ + utils/config.cmi driver/errors.cmi driver/main_args.cmi utils/misc.cmi \ + 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/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 new file mode 100644 index 00000000..36b8a703 --- /dev/null +++ b/Changes @@ -0,0 +1,1644 @@ +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. +- 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 *.types, 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. + +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. + +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. +- Modules Lexing and Parsing: added better handling of positions + in source file. +- Module Scanf: %n and %N formats to count characters / items read so far; + assorted bug fixes. +- 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. +- Better support for preprocessed code. + +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 new file mode 100644 index 00000000..0ed812a6 --- /dev/null +++ b/INSTALL @@ -0,0 +1,260 @@ + 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. + +-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 new file mode 100644 index 00000000..67afcd2e --- /dev/null +++ b/INSTALL.MPW @@ -0,0 +1,89 @@ +# $Id: INSTALL.MPW,v 1.15 2001/12/13 13:59:21 doligez Exp $ + + + ### 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 new file mode 100644 index 00000000..2aa532e6 --- /dev/null +++ b/LICENSE @@ -0,0 +1,618 @@ +In the following, "the Library" refers to all files marked "Copyright +INRIA" in the following directories and their sub-directories: + + asmrun, byterun, 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 new file mode 100644 index 00000000..1a974109 --- /dev/null +++ b/Makefile @@ -0,0 +1,671 @@ +######################################################################### +# # +# 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: Makefile,v 1.184 2003/07/03 15:13:21 xleroy Exp $ + +# 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 new file mode 100644 index 00000000..a7215869 --- /dev/null +++ b/Makefile.Mac @@ -0,0 +1,488 @@ +######################################################################### +# # +# 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.Mac,v 1.38 2002/11/05 10:23:52 xleroy Exp $ + +# 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 new file mode 100644 index 00000000..ecc9ddd1 --- /dev/null +++ b/Makefile.Mac.depend @@ -0,0 +1,548 @@ +: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 new file mode 100644 index 00000000..823cfe01 --- /dev/null +++ b/Makefile.nt @@ -0,0 +1,614 @@ +######################################################################### +# # +# 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: Makefile.nt,v 1.92 2003/07/03 16:21:47 xleroy Exp $ + +# 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 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 +ifeq ($(TOOLCHAIN),msvc) + cd win32caml ; $(MAKE) install +endif + 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 + +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 'OPT='; \ + echo 'OTOP=../..'; \ + echo 'OLIBDIR=$$(OTOP)/boot'; \ + echo 'BINDIR=$(BINDIR)'; \ + echo 'LIBDIR=$(LIBDIR)'; \ + echo 'MANDIR=' ) > Makefile + cd camlp4 ; $(MAKE) +camlp4opt: + cd camlp4 ; $(MAKE) opt +partialclean:: + cd camlp4 ; $(MAKE) clean + +# The Win32 toplevel GUI + +win32gui: +ifeq ($(TOOLCHAIN),msvc) + cd win32caml ; $(MAKE) all +endif +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 new file mode 100644 index 00000000..400812aa --- /dev/null +++ b/README @@ -0,0 +1,144 @@ +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 new file mode 100644 index 00000000..f020f0f3 --- /dev/null +++ b/README.win32 @@ -0,0 +1,246 @@ + 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 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 MinGW or Cygwin Cygwin + - for native-code generation MSVC+MASM MinGW or 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 no + +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 MS VC 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). + +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 either the MinGW +development tools, which is free software available at + http://www.mingw.org/ +or the Cygwin development tools (also free software), 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", "unix" and "labltk". +"graph" and "threads" are not available yet. +The replay debugger is supported. + diff --git a/Upgrading b/Upgrading new file mode 100644 index 00000000..fac60423 --- /dev/null +++ b/Upgrading @@ -0,0 +1,109 @@ + + 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/asmcomp/.cvsignore b/asmcomp/.cvsignore new file mode 100644 index 00000000..31d00178 --- /dev/null +++ b/asmcomp/.cvsignore @@ -0,0 +1,6 @@ +emit.ml +arch.ml +proc.ml +selection.ml +reload.ml +scheduling.ml diff --git a/asmcomp/alpha/arch.ml b/asmcomp/alpha/arch.ml new file mode 100644 index 00000000..46eae60d --- /dev/null +++ b/asmcomp/alpha/arch.ml @@ -0,0 +1,83 @@ +(***********************************************************************) +(* *) +(* 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: arch.ml,v 1.10 2002/11/29 15:03:36 xleroy Exp $ *) + +(* Specific operations for the Alpha processor *) + +open Misc +open Format + +(* Machine-specific command-line options *) + +let command_line_options = [] + +(* Addressing modes *) + +type addressing_mode = + Ibased of string * int (* symbol + displ *) + | Iindexed of int (* reg + displ *) + +(* Specific operations *) + +type specific_operation = + Iadd4 | Iadd8 | Isub4 | Isub8 (* Scaled adds and subs *) + | Ireloadgp of bool (* The ldgp instruction *) + | Itrunc32 (* Truncate 64-bit int to 32 bit *) + +(* Sizes, endianness *) + +let big_endian = false + +let size_addr = 8 +let size_int = 8 +let size_float = 8 + +(* Operations on addressing modes *) + +let identity_addressing = Iindexed 0 + +let offset_addressing addr delta = + match addr with + Ibased(s, n) -> Ibased(s, n + delta) + | Iindexed n -> Iindexed(n + delta) + +let num_args_addressing = function + Ibased(s, n) -> 0 + | Iindexed n -> 1 + +(* Printing operations and addressing modes *) + +let print_addressing printreg addr ppf arg = + match addr with + | Ibased(s, n) -> + fprintf ppf "\"%s\"%s" s + (if n <> 0 then Printf.sprintf " + %i" n else "") + | Iindexed n -> + fprintf ppf "%a%s" printreg arg.(0) + (if n <> 0 then Printf.sprintf " + %i" n else "") + +let print_specific_operation printreg op ppf arg = + match op with + | Iadd4 -> fprintf ppf "%a * 4 + %a" printreg arg.(0) printreg arg.(1) + | Iadd8 -> fprintf ppf "%a * 8 + %a" printreg arg.(0) printreg arg.(1) + | Isub4 -> fprintf ppf "%a * 4 - %a" printreg arg.(0) printreg arg.(1) + | Isub8 -> fprintf ppf "%a * 8 - %a" printreg arg.(0) printreg arg.(1) + | Ireloadgp _ -> fprintf ppf "ldgp" + | Itrunc32 -> fprintf ppf "truncate32 %a" printreg arg.(0) + +(* Distinguish between the Digital assembler and other assemblers (e.g. gas) *) + +let digital_asm = + match Config.system with + "digital" -> true + | _ -> false diff --git a/asmcomp/alpha/emit.mlp b/asmcomp/alpha/emit.mlp new file mode 100644 index 00000000..af7469dd --- /dev/null +++ b/asmcomp/alpha/emit.mlp @@ -0,0 +1,862 @@ +(***********************************************************************) +(* *) +(* 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: emit.mlp,v 1.37 2003/04/25 12:26:59 xleroy Exp $ *) + +module LabelSet = + Set.Make(struct type t = Linearize.label let compare = compare end) + +(* Emission of Alpha assembly code *) + +open Location +open Misc +open Cmm +open Arch +open Proc +open Reg +open Mach +open Linearize +open Emitaux + +(* First pass: insert Iloadgp instructions where needed *) + +let insert_load_gp f = + + let labels_needing_gp = ref LabelSet.empty in + let fixpoint_reached = ref false in + + let label_needs_gp lbl = + LabelSet.mem lbl !labels_needing_gp in + let opt_label_needs_gp default = function + None -> default + | Some lbl -> label_needs_gp lbl in + let set_label_needs_gp lbl = + if not (label_needs_gp lbl) then begin + fixpoint_reached := false; + labels_needing_gp := LabelSet.add lbl !labels_needing_gp + end in + + let tailrec_entry_point = new_label() in + + (* Determine if $gp is needed before an instruction. + [next] says whether $gp is needed just after (i.e. by the following + instruction). *) + let instr_needs_gp next = function + Lend -> false + | Lop(Iconst_int n) -> (* for large n, turned into ldq ($gp) *) + next || n < Nativeint.of_int(-0x80000000) + || n > Nativeint.of_int 0x7FFFFFFF + | Lop(Iconst_float s) -> true (* turned into ldq ($gp) *) + | Lop(Iconst_symbol s) -> true (* turned into ldq ($gp) *) + | Lop(Icall_ind) -> false (* does ldgp if needed afterwards *) + | Lop(Icall_imm s) -> true (* does lda $27, *) + | Lop(Itailcall_ind) -> false + | Lop(Itailcall_imm s) -> + if s = f.fun_name then label_needs_gp tailrec_entry_point else true + | Lop(Iextcall(_, _)) -> true (* does lda $27, *) + | Lop(Iload(_, Ibased(_, _))) -> true (* loads address from ($gp) *) + | Lop(Istore(_, Ibased(_, _))) -> true (* loads address from ($gp) *) + | Lop(Iintop(Idiv | Imod)) -> true (* divq and remq can be turned into *) + | Lop(Iintop_imm((Idiv | Imod), _)) -> true (* a function call *) + | Lop(Iintop_imm(_, n)) -> (* for large n, turned into ldq ($gp) *) + next || n < -0x80000000 || n > 0x7FFFFFFF + | Lop _ -> next + | Lreloadretaddr -> next + | Lreturn -> false + | Llabel lbl -> if next then set_label_needs_gp lbl; next + | Lbranch lbl -> label_needs_gp lbl + | Lcondbranch(tst, lbl) -> next || label_needs_gp lbl + | Lcondbranch3(lbl1, lbl2, lbl3) -> + opt_label_needs_gp next lbl1 || + opt_label_needs_gp next lbl2 || + opt_label_needs_gp next lbl3 + | Lswitch lblv -> true + | Lsetuptrap lbl -> label_needs_gp lbl + | Lpushtrap -> next + | Lpoptrap -> next + | Lraise -> false in + + let rec needs_gp i = + if i.desc = Lend + then false + else instr_needs_gp (needs_gp i.next) i.desc in + + while not !fixpoint_reached do + fixpoint_reached := true; + if needs_gp f.fun_body then set_label_needs_gp tailrec_entry_point + done; + + (* Insert Ireloadgp instructions after calls where needed *) + let rec insert_reload_gp i = + if i.desc = Lend then (i, false) else begin + let (new_next, needs_next) = insert_reload_gp i.next in + let new_instr = + match i.desc with + (* If the instruction destroys $gp and $gp is needed afterwards, + insert a ldgp after the instructions. *) + Lop(Icall_ind | Icall_imm _) when needs_next -> + {i with next = + instr_cons (Lop(Ispecific(Ireloadgp true))) [||] [||] new_next } + | Lop(Iextcall(_, false)) | Lsetuptrap _ when needs_next -> + {i with next = + instr_cons (Lop(Ispecific(Ireloadgp false))) [||] [||] new_next } + | _ -> + {i with next = new_next} in + (new_instr, instr_needs_gp needs_next i.desc) + end in + + let (new_body, uses_gp) = insert_reload_gp f.fun_body in + ({f with fun_body = new_body}, uses_gp) + +(* Second pass: code generation proper *) + +(* Tradeoff between code size and code speed *) + +let fastcode_flag = ref true + +(* Output a label *) + +let emit_label lbl = + emit_string "$"; emit_int lbl + +let emit_Llabel fallthrough lbl = + if (not fallthrough) then begin + emit_string " .align 4\n" + end ; + emit_label lbl + +(* Output a symbol *) + +let emit_symbol s = + Emitaux.emit_symbol '$' s + +(* Output a pseudo-register *) + +let emit_reg r = + match r.loc with + Reg r -> emit_string (register_name r) + | _ -> fatal_error "Emit_alpha.emit_reg" + +(* Layout of the stack frame *) + +let stack_offset = ref 0 + +let frame_size () = + let size = + !stack_offset + + 8 * (num_stack_slots.(0) + num_stack_slots.(1)) + + (if !contains_calls then 8 else 0) in + Misc.align size 16 + +let slot_offset loc cl = + match loc with + Incoming n -> frame_size() + n + | Local n -> + if cl = 0 + then !stack_offset + n * 8 + else !stack_offset + (num_stack_slots.(0) + n) * 8 + | Outgoing n -> n + +(* Output a stack reference *) + +let emit_stack r = + match r.loc with + Stack s -> + let ofs = slot_offset s (register_class r) in `{emit_int ofs}($sp)` + | _ -> fatal_error "Emit_alpha.emit_stack" + +(* Output an addressing mode *) + +let emit_addressing addr r n = + match addr with + Iindexed ofs -> + `{emit_int ofs}({emit_reg r.(n)})` + | Ibased(s, ofs) -> + `{emit_symbol s}`; + if ofs > 0 then ` + {emit_int ofs}`; + if ofs < 0 then ` - {emit_int(-ofs)}` + +(* Immediate operands *) + +let is_immediate n = digital_asm || (n >= 0 && n <= 255) + +(* Communicate live registers at call points to the assembler *) + +let int_reg_number = [| + 0; 1; 2; 3; 4; 5; 6; 7; 8; 9; 10; 11; 12; + 16; 17; 18; 19; 20; 21; 22 +|] + +let float_reg_number = [| + 0; 1; 2; 3; 4; 5; 6; 7; 8; 9; 10; 11; 12; 13; 14; 15; + 16; 17; 18; 19; 20; 21; 22; 23; 24; 25; 26; 27; 29; 30 +|] + +let liveregs instr extra_msk = + (* $13, $14, $15 always live *) + let int_mask = ref(0x00070000 lor extra_msk) + and float_mask = ref 0 in + let add_register = function + {loc = Reg r; typ = (Int | Addr)} -> + int_mask := !int_mask lor (1 lsl (31 - int_reg_number.(r))) + | {loc = Reg r; typ = Float} -> + float_mask := !float_mask lor (1 lsl (31 - float_reg_number.(r - 100))) + | _ -> () in + Reg.Set.iter add_register instr.live; + Array.iter add_register instr.arg; + emit_printf " .livereg 0x%08x, 0x%08x\n" !int_mask !float_mask + +let live_24 = 1 lsl (31 - 24) +let live_25 = 1 lsl (31 - 25) +let live_26 = 1 lsl (31 - 26) +let live_27 = 1 lsl (31 - 27) + +(* Record live pointers at call points *) + +type frame_descr = + { fd_lbl: int; (* Return address *) + fd_frame_size: int; (* Size of stack frame *) + fd_live_offset: int list } (* Offsets/regs of live addresses *) + +let frame_descriptors = ref([] : frame_descr list) + +let record_frame_label live = + let lbl = new_label() in + let live_offset = ref [] in + Reg.Set.iter + (function + {typ = Addr; loc = Reg r} -> + live_offset := ((int_reg_number.(r) lsl 1) + 1) :: !live_offset + | {typ = Addr; loc = Stack s} as reg -> + live_offset := slot_offset s (register_class reg) :: !live_offset + | _ -> ()) + live; + frame_descriptors := + { fd_lbl = lbl; + fd_frame_size = frame_size(); + fd_live_offset = !live_offset } :: !frame_descriptors; + lbl + +let record_frame live = + let lbl = record_frame_label live in `{emit_label lbl}:` + +let emit_frame fd = + ` .quad {emit_label fd.fd_lbl}\n`; + ` .word {emit_int fd.fd_frame_size}\n`; + ` .word {emit_int (List.length fd.fd_live_offset)}\n`; + List.iter + (fun n -> + ` .word {emit_int n}\n`) + fd.fd_live_offset; + ` .align 3\n` + +(* Record calls to the GC -- we've moved them out of the way *) + +type gc_call = + { gc_lbl: label; (* Entry label *) + gc_return_lbl: label; (* Where to branch after GC *) + gc_frame: label; (* Label of frame descriptor *) + gc_instr: instruction } (* Record live registers *) + +let call_gc_sites = ref ([] : gc_call list) + +let emit_call_gc gc = + `{emit_label gc.gc_lbl}:`; + liveregs gc.gc_instr 0; + ` bsr $26, caml_call_gc\n`; + (* caml_call_gc preserves $gp *) + `{emit_label gc.gc_frame}: br {emit_label gc.gc_return_lbl}\n` + +(* Name of readonly data section *) + +let rdata_section = + match Config.system with + "digital" -> ".rdata" + | "linux" | "openbsd" | "netbsd" | "freebsd" -> ".section .rodata" + | _ -> assert false + +(* Names of various instructions *) + +let name_for_int_operation = function + Iadd -> "addq" + | Isub -> "subq" + | Imul -> "mulq" + | Idiv -> "divq" + | Imod -> "remq" + | Iand -> "and" + | Ior -> "or" + | Ixor -> "xor" + | Ilsl -> "sll" + | Ilsr -> "srl" + | Iasr -> "sra" + | _ -> Misc.fatal_error "Emit.name_for_int_operation" + +let name_for_float_operation = function + Inegf -> "fneg" + | Iabsf -> "fabs" + | Iaddf -> "addt" + | Isubf -> "subt" + | Imulf -> "mult" + | Idivf -> "divt" + | _ -> Misc.fatal_error "Emit.name_for_float_operation" + +let name_for_specific_operation = function + Iadd4 -> "s4addq" + | Iadd8 -> "s8addq" + | Isub4 -> "s4subq" + | Isub8 -> "s8subq" + | _ -> Misc.fatal_error "Emit.name_for_specific_operation" + +let name_for_int_comparison = function + Isigned Ceq -> "cmpeq", true | Isigned Cne -> "cmpeq", false + | Isigned Cle -> "cmple", true | Isigned Cgt -> "cmple", false + | Isigned Clt -> "cmplt", true | Isigned Cge -> "cmplt", false + | Iunsigned Ceq -> "cmpeq", true | Iunsigned Cne -> "cmpeq", false + | Iunsigned Cle -> "cmpule", true | Iunsigned Cgt -> "cmpule", false + | Iunsigned Clt -> "cmpult", true | Iunsigned Cge -> "cmpult", false + +(* Used for comparisons against 0 *) +let name_for_int_cond_branch = function + Isigned Ceq -> "beq" | Isigned Cne -> "bne" + | Isigned Cle -> "ble" | Isigned Cgt -> "bgt" + | Isigned Clt -> "blt" | Isigned Cge -> "bge" + | Iunsigned Ceq -> "beq" | Iunsigned Cne -> "bne" + | Iunsigned Cle -> "beq" | Iunsigned Cgt -> "bne" + | Iunsigned Clt -> "#" | Iunsigned Cge -> "br" + (* Always false *) (* Always true *) + +let name_for_float_comparison cmp neg = + match cmp with + Ceq -> ("cmpteq", false, neg) | Cne -> ("cmpteq", false, not neg) + | Cle -> ("cmptle", false, neg) | Cgt -> ("cmptlt", true, neg) + | Clt -> ("cmptlt", false, neg) | Cge -> ("cmptle", true, neg) + +(* Output the assembly code for an instruction *) + +(* Name of current function *) +let function_name = ref "" +(* Entry point for tail recursive calls *) +let tailrec_entry_point = ref 0 +(* Label of trap for out-of-range accesses *) +let range_check_trap = ref 0 +(* List of floating-point and big integer literals + (fon non-Digital assemblers) *) +let float_constants = ref ([] : (label * string) list) +let bigint_constants = ref ([] : (label * nativeint) list) + +let emit_instr fallthrough i = + match i.desc with + Lend -> () + | Lop(Imove | Ispill | Ireload) -> + let src = i.arg.(0) and dst = i.res.(0) in + if src.loc <> dst.loc then begin + match (src.loc, dst.loc) with + (Reg rs, Reg rd) -> + if src.typ = Float then + ` fmov {emit_reg src}, {emit_reg dst}\n` + else + ` mov {emit_reg src}, {emit_reg dst}\n` + | (Reg rs, Stack sd) -> + if src.typ = Float then + ` stt {emit_reg src}, {emit_stack dst}\n` + else + ` stq {emit_reg src}, {emit_stack dst}\n` + | (Stack ss, Reg rd) -> + if src.typ = Float then + ` ldt {emit_reg dst}, {emit_stack src}\n` + else + ` ldq {emit_reg dst}, {emit_stack src}\n` + | _ -> + fatal_error "Emit_alpha: Imove" + end + | Lop(Iconst_int n) -> + if n = 0n then + ` clr {emit_reg i.res.(0)}\n` + else if digital_asm || + (n >= Nativeint.of_int (-0x80000000) && + n <= Nativeint.of_int 0x7FFFFFFF) then + ` ldiq {emit_reg i.res.(0)}, {emit_nativeint n}\n` + else begin + (* Work around a bug in gas/gld concerning big integer constants *) + let lbl = new_label() in + bigint_constants := (lbl, n) :: !bigint_constants; + ` lda $25, {emit_label lbl}\n`; + ` ldq {emit_reg i.res.(0)}, 0($25)\n` + end + | Lop(Iconst_float s) -> + if digital_asm then + ` ldit {emit_reg i.res.(0)}, {emit_string s}\n` + else if float_of_string s = 0.0 then + ` fmov $f31, {emit_reg i.res.(0)}\n` + else begin + let lbl = new_label() in + float_constants := (lbl, s) :: !float_constants; + ` lda $25, {emit_label lbl}\n`; + ` ldt {emit_reg i.res.(0)}, 0($25)\n` + end + | Lop(Iconst_symbol s) -> + ` lda {emit_reg i.res.(0)}, {emit_symbol s}\n` + | Lop(Icall_ind) -> + liveregs i 0; + ` mov {emit_reg i.arg.(0)}, $27\n`; + ` jsr ({emit_reg i.arg.(0)})\n`; + `{record_frame i.live}\n` + | Lop(Icall_imm s) -> + liveregs i 0; + ` jsr {emit_symbol s}\n`; + `{record_frame i.live}\n` + | Lop(Itailcall_ind) -> + let n = frame_size() in + if !contains_calls then + ` ldq $26, {emit_int(n - 8)}($sp)\n`; + if n > 0 then + ` lda $sp, {emit_int n}($sp)\n`; + ` mov {emit_reg i.arg.(0)}, $27\n`; + liveregs i (live_26 + live_27); + ` jmp ({emit_reg i.arg.(0)})\n` + | Lop(Itailcall_imm s) -> + if s = !function_name then begin + ` br {emit_label !tailrec_entry_point}\n` + end else begin + let n = frame_size() in + if !contains_calls then + ` ldq $26, {emit_int(n - 8)}($sp)\n`; + if n > 0 then + ` lda $sp, {emit_int n}($sp)\n`; + ` lda $27, {emit_symbol s}\n`; + liveregs i (live_26 + live_27); + ` br {emit_symbol s}\n` + end + | Lop(Iextcall(s, alloc)) -> + if alloc then begin + ` lda $25, {emit_symbol s}\n`; + liveregs i live_25; + ` bsr $26, caml_c_call\n`; + `{record_frame i.live}\n` + end else begin + ` jsr {emit_symbol s}\n` + end + | Lop(Istackoffset n) -> + ` lda $sp, {emit_int (-n)}($sp)\n`; + stack_offset := !stack_offset + n + | Lop(Iload(chunk, addr)) -> + let dest = i.res.(0) in + let load_instr = + match chunk with + | Byte_unsigned -> "ldbu" + | Byte_signed -> "ldb" + | Sixteen_unsigned -> "ldwu" + | Sixteen_signed -> "ldw" + | Thirtytwo_unsigned -> "ldl" + | Thirtytwo_signed -> "ldl" + | Word -> "ldq" + | Single -> "lds" + | Double -> "ldt" + | Double_u -> "ldt" in + ` {emit_string load_instr} {emit_reg dest}, {emit_addressing addr i.arg 0}\n`; + if chunk = Thirtytwo_unsigned then + ` zapnot {emit_reg dest}, 15, {emit_reg dest}\n` + | Lop(Istore(chunk, addr)) -> + let store_instr = + match chunk with + | Byte_unsigned | Byte_signed -> "stb" + | Sixteen_unsigned | Sixteen_signed -> "stw" + | Thirtytwo_unsigned | Thirtytwo_signed -> "stl" + | Word -> "stq" + | Single -> "sts" + | Double -> "stt" + | Double_u -> "stt" in + ` {emit_string store_instr} {emit_reg i.arg.(0)}, {emit_addressing addr i.arg 1}\n` + | Lop(Ialloc n) -> + if !fastcode_flag then begin + let lbl_redo = new_label() in + let lbl_call_gc = new_label() in + let lbl_frame = record_frame_label i.live in + call_gc_sites := + { gc_lbl = lbl_call_gc; + gc_return_lbl = lbl_redo; + gc_frame = lbl_frame; + gc_instr = i } :: !call_gc_sites; + `{emit_label lbl_redo}: lda $13, -{emit_int n}($13)\n`; + ` cmpult $13, $14, $25\n`; + ` bne $25, {emit_label lbl_call_gc}\n`; + ` addq $13, 8, {emit_reg i.res.(0)}\n` + end else begin + begin match n with + 16 -> liveregs i 0; + ` bsr $26, caml_alloc1\n` + | 24 -> liveregs i 0; + ` bsr $26, caml_alloc2\n` + | 32 -> liveregs i 0; + ` bsr $26, caml_alloc3\n` + | _ -> ` ldiq $25, {emit_int n}\n`; + liveregs i live_25; + ` bsr $26, caml_alloc\n` + end; + (* $gp preserved by caml_alloc* *) + `{record_frame i.live} addq $13, 8, {emit_reg i.res.(0)}\n` + end + | Lop(Iintop(Icomp cmp)) -> + let (comp, test) = name_for_int_comparison cmp in + ` {emit_string comp} {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.res.(0)}\n`; + if not test then + ` xor {emit_reg i.res.(0)}, 1, {emit_reg i.res.(0)}\n` + | Lop(Iintop(Icheckbound)) -> + if !range_check_trap = 0 then range_check_trap := new_label(); + ` cmpule {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, $25\n`; + ` bne $25, {emit_label !range_check_trap}\n` + | Lop(Iintop op) -> + let instr = name_for_int_operation op in + ` {emit_string instr} {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.res.(0)}\n` + | Lop(Iintop_imm(Idiv, n)) -> + if n = 1 lsl (Misc.log2 n) then begin + let l = Misc.log2 n in + if is_immediate n then + ` addq {emit_reg i.arg.(0)}, {emit_int(n-1)}, $25\n` + else begin + ` ldiq $25, {emit_int(n-1)}\n`; + ` addq {emit_reg i.arg.(0)}, $25, $25\n` + end; + ` cmovge {emit_reg i.arg.(0)}, {emit_reg i.arg.(0)}, $25\n`; + ` sra $25, {emit_int l}, {emit_reg i.res.(0)}\n` + end else begin + (* divq with immediate arg is incorrectly assembled in Tru64 5.1, + so emulate it ourselves *) + ` ldiq $25, {emit_int n}\n`; + ` divq {emit_reg i.arg.(0)}, $25, {emit_reg i.res.(0)}\n` + end + | Lop(Iintop_imm(Imod, n)) -> + if n = 1 lsl (Misc.log2 n) then begin + let l = Misc.log2 n in + if is_immediate n then + ` and {emit_reg i.arg.(0)}, {emit_int(n-1)}, $25\n` + else begin + ` ldiq $25, {emit_int (n-1)}\n`; + ` and {emit_reg i.arg.(0)}, $25, $25\n` + end; + ` subq $25, {emit_int n}, $24\n`; + ` cmovge {emit_reg i.arg.(0)}, $25, $24\n`; + ` cmoveq $25, $25, $24\n`; + ` mov $24, {emit_reg i.res.(0)}\n` + end else begin + (* remq with immediate arg is incorrectly assembled in Tru64 5.1, + so emulate it ourselves *) + ` ldiq $25, {emit_int n}\n`; + ` remq {emit_reg i.arg.(0)}, $25, {emit_reg i.res.(0)}\n` + end + | Lop(Iintop_imm(Ilsl, 1)) -> + (* Turn x << 1 into x + x, slightly faster according to the docs *) + ` addq {emit_reg i.arg.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.res.(0)}\n` + | Lop(Iintop_imm(Icomp cmp, n)) -> + let (comp, test) = name_for_int_comparison cmp in + ` {emit_string comp} {emit_reg i.arg.(0)}, {emit_int n}, {emit_reg i.res.(0)}\n`; + if not test then + ` xor {emit_reg i.res.(0)}, 1, {emit_reg i.res.(0)}\n` + + | Lop(Iintop_imm(Icheckbound, n)) -> + if !range_check_trap = 0 then range_check_trap := new_label(); + ` cmpule {emit_reg i.arg.(0)}, {emit_int n}, $25\n`; + ` bne $25, {emit_label !range_check_trap}\n` + | Lop(Iintop_imm(op, n)) -> + let instr = name_for_int_operation op in + ` {emit_string instr} {emit_reg i.arg.(0)}, {emit_int n}, {emit_reg i.res.(0)}\n` + | Lop(Inegf | Iabsf as op) -> + let instr = name_for_float_operation op in + ` {emit_string instr} {emit_reg i.arg.(0)}, {emit_reg i.res.(0)}\n` + | Lop(Iaddf | Isubf | Imulf | Idivf as op) -> + let instr = name_for_float_operation op in + ` {emit_string instr} {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.res.(0)}\n` + | Lop(Ifloatofint) -> + ` .set noat\n`; + ` lda $sp, -8($sp)\n`; + ` stq {emit_reg i.arg.(0)}, 0($sp)\n`; + ` ldt $f28, 0($sp)\n`; + ` cvtqt $f28, {emit_reg i.res.(0)}\n`; + ` lda $sp, 8($sp)\n`; + ` .set at\n` + | Lop(Iintoffloat) -> + ` .set noat\n`; + ` lda $sp, -8($sp)\n`; + ` cvttqc {emit_reg i.arg.(0)}, $f28\n`; + ` stt $f28, 0($sp)\n`; + ` ldq {emit_reg i.res.(0)}, 0($sp)\n`; + ` lda $sp, 8($sp)\n`; + ` .set at\n` + | Lop(Ispecific(Ireloadgp marked_r26)) -> + ` ldgp $gp, 0($26)\n`; + if marked_r26 then + ` bic $gp, 1, $gp\n` + | Lop(Ispecific Itrunc32) -> + ` addl {emit_reg i.arg.(0)}, 0, {emit_reg i.res.(0)}\n` + | Lop(Ispecific sop) -> + let instr = name_for_specific_operation sop in + ` {emit_string instr} {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.res.(0)}\n` + | Lreloadretaddr -> + let n = frame_size() in + ` ldq $26, {emit_int(n - 8)}($sp)\n` + | Lreturn -> + let n = frame_size() in + if n > 0 then + ` lda $sp, {emit_int n}($sp)\n`; + liveregs i live_26; + ` ret ($26)\n` + | Llabel lbl -> + `{emit_Llabel fallthrough lbl}:\n` + | Lbranch lbl -> + ` br {emit_label lbl}\n` + | Lcondbranch(tst, lbl) -> + begin match tst with + Itruetest -> + ` bne {emit_reg i.arg.(0)}, {emit_label lbl}\n` + | Ifalsetest -> + ` beq {emit_reg i.arg.(0)}, {emit_label lbl}\n` + | Iinttest cmp -> + let (comp, test) = name_for_int_comparison cmp in + ` {emit_string comp} {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, $25\n`; + if test then + ` bne $25, {emit_label lbl}\n` + else + ` beq $25, {emit_label lbl}\n` + | Iinttest_imm(cmp, 0) -> + let branch = name_for_int_cond_branch cmp in + ` {emit_string branch} {emit_reg i.arg.(0)}, {emit_label lbl}\n` + | Iinttest_imm(cmp, n) -> + let (comp, test) = name_for_int_comparison cmp in + ` {emit_string comp} {emit_reg i.arg.(0)}, {emit_int n}, $25\n`; + if test then + ` bne $25, {emit_label lbl}\n` + else + ` beq $25, {emit_label lbl}\n` + | Ifloattest(cmp, neg) -> + ` .set noat\n`; + let (comp, swap, test) = name_for_float_comparison cmp neg in + ` {emit_string comp} `; + if swap + then `{emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}, $f28\n` + else `{emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, $f28\n`; + if test + then ` fbeq $f28, {emit_label lbl}\n` + else ` fbne $f28, {emit_label lbl}\n`; + ` .set at\n` + | Ioddtest -> + ` blbs {emit_reg i.arg.(0)}, {emit_label lbl}\n` + | Ieventest -> + ` blbc {emit_reg i.arg.(0)}, {emit_label lbl}\n` + end + | Lcondbranch3(lbl0, lbl1, lbl2) -> + begin match lbl0 with + None -> () + | Some lbl -> ` beq {emit_reg i.arg.(0)}, {emit_label lbl}\n` + end; + begin match lbl1 with + None -> () + | Some lbl -> ` blbs {emit_reg i.arg.(0)}, {emit_label lbl}\n` + end; + begin match lbl2 with + None -> () + | Some lbl -> + if lbl0 <> None then + ` blbc {emit_reg i.arg.(0)}, {emit_label lbl}\n` + else if lbl1 <> None then + ` bne {emit_reg i.arg.(0)}, {emit_label lbl}\n` + else begin + ` subq {emit_reg i.arg.(0)}, 2, $25\n`; + ` beq $25, {emit_label lbl}\n` + end + end + | Lswitch jumptbl -> + let lbl_jumptbl = new_label() in + ` lda $25, {emit_label lbl_jumptbl}\n`; + ` s4addq {emit_reg i.arg.(0)}, $25, $25\n`; + ` ldl $25, 0($25)\n`; + ` addq $gp, $25, $25\n`; + ` jmp ($25), {emit_label jumptbl.(0)}\n`; + ` {emit_string rdata_section}\n`; + `{emit_label lbl_jumptbl}:`; + for i = 0 to Array.length jumptbl - 1 do + ` .gprel32 {emit_label jumptbl.(i)}\n` + done; + ` .text\n` + | Lsetuptrap lbl -> + ` br $25, {emit_label lbl}\n` + | Lpushtrap -> + stack_offset := !stack_offset + 16; + ` lda $sp, -16($sp)\n`; + ` stq $15, 0($sp)\n`; + ` stq $25, 8($sp)\n`; + ` mov $sp, $15\n` + | Lpoptrap -> + ` ldq $15, 0($sp)\n`; + ` lda $sp, 16($sp)\n`; + stack_offset := !stack_offset - 16 + | Lraise -> + ` ldq $26, 8($15)\n`; + ` mov $15, $sp\n`; + ` ldq $15, 0($sp)\n`; + ` lda $sp, 16($sp)\n`; + liveregs i live_26; + ` jmp $25, ($26)\n` (* Keep retaddr in $25 for debugging *) + +let rec emit_all fallthrough i = match i.desc with +| Lend -> () +| _ -> + emit_instr fallthrough i; + emit_all (has_fallthrough i.desc) i.next + +(* Emission of a function declaration *) + +let emit_fundecl (fundecl, needs_gp) = + function_name := fundecl.fun_name; + fastcode_flag := fundecl.fun_fast; + stack_offset := 0; + call_gc_sites := []; + range_check_trap := 0; + float_constants := []; + bigint_constants := []; + ` .text\n`; + ` .align 4\n`; + ` .globl {emit_symbol fundecl.fun_name}\n`; + ` .ent {emit_symbol fundecl.fun_name}\n`; + `{emit_symbol fundecl.fun_name}:\n`; + if needs_gp then begin + ` .set noreorder\n`; + ` ldgp $gp, 0($27)\n`; + ` .set reorder\n` + end; + let n = frame_size() in + if n > 0 then + ` lda $sp, -{emit_int n}($sp)\n`; + if !contains_calls then begin + ` stq $26, {emit_int(n - 8)}($sp)\n`; + ` .mask 0x04000000, -8\n`; + ` .fmask 0x0, 0\n` + end; + ` .frame $sp, {emit_int n}, $26\n`; + ` .prologue {emit_int(if needs_gp then 1 else 0)}\n`; + tailrec_entry_point := new_label(); + `{emit_label !tailrec_entry_point}:\n`; + emit_all true fundecl.fun_body; + List.iter emit_call_gc !call_gc_sites; + if !range_check_trap > 0 then begin + `{emit_label !range_check_trap}:\n`; + ` br $26, caml_array_bound_error\n` + (* Keep retaddr in $26 for debugging *) + end; + ` .end {emit_symbol fundecl.fun_name}\n`; + if !bigint_constants <> [] then begin + ` {emit_string rdata_section}\n`; + ` .align 3\n`; + List.iter + (fun (lbl, n) -> `{emit_label lbl}: .quad 0x{emit_string(Nativeint.format "%x" n)}\n`) + !bigint_constants + end; + if !float_constants <> [] then begin + ` {emit_string rdata_section}\n`; + ` .align 3\n`; + List.iter + (fun (lbl, s) -> `{emit_label lbl}: .t_floating {emit_string s}\n`) + !float_constants + end + +let fundecl f = + emit_fundecl (insert_load_gp f) + +(* Emission of data *) + +let emit_item = function + Cglobal_symbol s -> + ` .globl {emit_symbol s}\n`; + | Cdefine_symbol s -> + `{emit_symbol s}:\n` + | Cdefine_label lbl -> + `{emit_label (100000 + lbl)}:\n` + | Cint8 n -> + ` .byte {emit_int n}\n` + | Cint16 n -> + ` .word {emit_int n}\n` + | Cint32 n -> + let n' = Nativeint.shift_right (Nativeint.shift_left n 32) 32 in + ` .long {emit_nativeint n'}\n` + | Cint n -> + if digital_asm then + ` .quad {emit_nativeint n}\n` + else + (* Work around a bug in gas regarding the parsing of + long decimal constants *) + ` .quad 0x{emit_string(Nativeint.format "%x" n)}\n` + | Csingle f -> + ` .float {emit_string f}\n` + | Cdouble f -> + ` .double {emit_string f}\n` + | Csymbol_address s -> + ` .quad {emit_symbol s}\n` + | Clabel_address lbl -> + ` .quad {emit_label (100000 + lbl)}\n` + | Cstring s -> + emit_string_directive " .ascii " s + | Cskip n -> + if n > 0 then ` .space {emit_int n}\n` + | Calign n -> + ` .align {emit_int(Misc.log2 n)}\n` + +let data l = + ` .data\n`; + List.iter emit_item l + +(* Beginning / end of an assembly file *) + +let begin_assembly() = + (* There are really two groups of registers: + $sp and $15 always point to stack locations + $0 - $14, $16-$23 never point to stack locations. *) + ` .noalias $0,$sp; .noalias $0,$15; .noalias $1,$sp; .noalias $1,$15\n`; + ` .noalias $2,$sp; .noalias $2,$15; .noalias $3,$sp; .noalias $3,$15\n`; + ` .noalias $4,$sp; .noalias $4,$15; .noalias $5,$sp; .noalias $5,$15\n`; + ` .noalias $6,$sp; .noalias $6,$15; .noalias $7,$sp; .noalias $7,$15\n`; + ` .noalias $8,$sp; .noalias $8,$15; .noalias $9,$sp; .noalias $9,$15\n`; + ` .noalias $10,$sp; .noalias $10,$15; .noalias $11,$sp; .noalias $11,$15\n`; + ` .noalias $12,$sp; .noalias $12,$15; .noalias $13,$sp; .noalias $13,$15\n`; + ` .noalias $14,$sp; .noalias $14,$15; .noalias $16,$sp; .noalias $16,$15\n`; + ` .noalias $17,$sp; .noalias $17,$15; .noalias $18,$sp; .noalias $18,$15\n`; + ` .noalias $19,$sp; .noalias $19,$15; .noalias $20,$sp; .noalias $20,$15\n`; + ` .noalias $21,$sp; .noalias $21,$15; .noalias $22,$sp; .noalias $22,$15\n`; + ` .noalias $23,$sp; .noalias $23,$15\n\n`; + (* The following .file directive is intended to prevent the generation + of line numbers for the debugger, 'cos they make .o files larger + and slow down linking. *) + ` .file 1 \"{emit_string !Location.input_name}\"\n\n`; + let lbl_begin = Compilenv.current_unit_name() ^ "__data_begin" in + ` .data\n`; + ` .globl {emit_symbol lbl_begin}\n`; + `{emit_symbol lbl_begin}:\n`; + let lbl_begin = Compilenv.current_unit_name() ^ "__code_begin" in + ` .text\n`; + ` .globl {emit_symbol lbl_begin}\n`; + `{emit_symbol lbl_begin}:\n` + +let end_assembly () = + let lbl_end = Compilenv.current_unit_name() ^ "__code_end" in + ` .text\n`; + ` .globl {emit_symbol lbl_end}\n`; + `{emit_symbol lbl_end}:\n`; + let lbl_end = Compilenv.current_unit_name() ^ "__data_end" in + ` .data\n`; + ` .globl {emit_symbol lbl_end}\n`; + `{emit_symbol lbl_end}:\n`; + ` .quad 0\n`; + let lbl_frame = Compilenv.current_unit_name() ^ "__frametable" in + ` {emit_string rdata_section}\n`; + ` .globl {emit_symbol lbl_frame}\n`; + `{emit_symbol lbl_frame}:\n`; + ` .quad {emit_int (List.length !frame_descriptors)}\n`; + List.iter emit_frame !frame_descriptors; + frame_descriptors := [] diff --git a/asmcomp/alpha/proc.ml b/asmcomp/alpha/proc.ml new file mode 100644 index 00000000..20b81797 --- /dev/null +++ b/asmcomp/alpha/proc.ml @@ -0,0 +1,217 @@ +(***********************************************************************) +(* *) +(* 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: proc.ml,v 1.6 2002/07/22 16:37:46 doligez Exp $ *) + +(* Description of the Alpha processor *) + +open Misc +open Cmm +open Reg +open Arch +open Mach + +(* Instruction selection *) + +let word_addressed = true + +(* Registers available for register allocation *) + +(* Register map: + $0 - $7 0 - 7 function results + $8 - $12 8 - 12 general purpose ($9 - $15 are preserved by C) + $13 allocation pointer + $14 allocation limit + $15 trap pointer + $16 - $22 13 - 19 function arguments + $23 - $25 temporaries (for the code gen and for the asm) + $26 - $30 stack ptr, global ptr, etc + $31 always zero + + $f0 - $f7 100 - 107 function results + $f8 - $f15 108 - 115 general purpose ($f2 - $f9 preserved by C) + $f16 - $f23 116 - 123 function arguments + $f24 - $f30 124 - 129 general purpose + $f28 temporary + $f31 always zero *) + +let int_reg_name = [| + (* 0-7 *) "$0"; "$1"; "$2"; "$3"; "$4"; "$5"; "$6"; "$7"; + (* 8-12 *) "$8"; "$9"; "$10"; "$11"; "$12"; + (* 13-19 *) "$16"; "$17"; "$18"; "$19"; "$20"; "$21"; "$22" +|] + +let float_reg_name = [| + (* 100-107 *) "$f0"; "$f1"; "$f2"; "$f3"; "$f4"; "$f5"; "$f6"; "$f7"; + (* 108-115 *) "$f8"; "$f9"; "$f10"; "$f11"; "$f12"; "$f13"; "$f14"; "$f15"; + (* 116-123 *) "$f16"; "$f17"; "$f18"; "$f19"; "$f20"; "$f21"; "$f22"; "$f23"; + (* 124-129 *) "$f24"; "$f25"; "$f26"; "$f27"; "$f29"; "$f30" +|] + +let num_register_classes = 2 + +let register_class r = + match r.typ with + Int -> 0 + | Addr -> 0 + | Float -> 1 + +let num_available_registers = [| 20; 30 |] + +let first_available_register = [| 0; 100 |] + +let register_name r = + if r < 100 then int_reg_name.(r) else float_reg_name.(r - 100) + +let rotate_registers = true + +(* Representation of hard registers by pseudo-registers *) + +let hard_int_reg = + let v = Array.create 20 Reg.dummy in + for i = 0 to 19 do v.(i) <- Reg.at_location Int (Reg i) done; + v + +let hard_float_reg = + let v = Array.create 30 Reg.dummy in + for i = 0 to 29 do v.(i) <- Reg.at_location Float (Reg(100 + i)) done; + v + +let all_phys_regs = + Array.append hard_int_reg hard_float_reg + +let phys_reg n = + if n < 100 then hard_int_reg.(n) else hard_float_reg.(n - 100) + +let stack_slot slot ty = + Reg.at_location ty (Stack slot) + +(* Calling conventions *) + +let calling_conventions first_int last_int first_float last_float make_stack + arg = + let loc = Array.create (Array.length arg) Reg.dummy in + let int = ref first_int in + let float = ref first_float in + let ofs = ref 0 in + for i = 0 to Array.length arg - 1 do + match arg.(i).typ with + Int | Addr as ty -> + if !int <= last_int then begin + loc.(i) <- phys_reg !int; + incr int + end else begin + loc.(i) <- stack_slot (make_stack !ofs) ty; + ofs := !ofs + size_int + end + | Float -> + if !float <= last_float then begin + loc.(i) <- phys_reg !float; + incr float + end else begin + loc.(i) <- stack_slot (make_stack !ofs) Float; + ofs := !ofs + size_float + end + done; + (loc, Misc.align !ofs 16) (* Keep stack 16-aligned *) + +let incoming ofs = Incoming ofs +let outgoing ofs = Outgoing ofs +let not_supported ofs = fatal_error "Proc.loc_results: cannot call" + +let loc_arguments arg = + calling_conventions 13 18 116 123 outgoing arg +let loc_parameters arg = + let (loc, ofs) = calling_conventions 13 18 116 123 incoming arg in loc +let loc_results res = + let (loc, ofs) = calling_conventions 0 7 100 107 not_supported res in loc + +(* On the Alpha, C functions have calling conventions similar to those + for Caml functions, except that integer and floating-point registers + for arguments are allocated "in sequence". E.g. a function + taking a float f1 and two ints i2 and i3 will put f1 in the + first float reg, i2 in the second int reg and i3 in the third int reg. *) + +let ext_calling_conventions first_int last_int first_float last_float + make_stack arg = + let loc = Array.create (Array.length arg) Reg.dummy in + let int = ref first_int in + let float = ref first_float in + let ofs = ref 0 in + for i = 0 to Array.length arg - 1 do + match arg.(i).typ with + Int | Addr as ty -> + if !int <= last_int then begin + loc.(i) <- phys_reg !int; incr int; incr float + end else begin + loc.(i) <- stack_slot (make_stack !ofs) ty; + ofs := !ofs + size_int + end + | Float -> + if !float <= last_float then begin + loc.(i) <- phys_reg !float; incr int; incr float + end else begin + loc.(i) <- stack_slot (make_stack !ofs) Float; + ofs := !ofs + size_float + end + done; + (loc, Misc.align !ofs 16) (* Keep stack 16-aligned *) + +let loc_external_arguments arg = + ext_calling_conventions 13 18 116 121 outgoing arg +let loc_external_results res = + let (loc, ofs) = ext_calling_conventions 0 0 100 100 not_supported res in loc +let extcall_use_push = false + +let loc_exn_bucket = phys_reg 0 (* $0 *) + +(* Registers destroyed by operations *) + +let destroyed_at_c_call = (* $9 - $12, $f2 - $f9 preserved *) + Array.of_list(List.map phys_reg + [0;1;2;3;4;5;6;7;8;13;14;15;16;17;18;19; + 100;101;110;111;112;113;114;115;116;117;118;119;120;121;122;123;124; + 125;126;127;128;129]) + +let destroyed_at_oper = function + Iop(Icall_ind | Icall_imm _ | Iextcall(_, true)) -> all_phys_regs + | Iop(Iextcall(_, false)) -> destroyed_at_c_call + | _ -> [||] + +let destroyed_at_raise = all_phys_regs + +(* Maximal register pressure *) + +let safe_register_pressure = function + Iextcall(_, _) -> 4 + | _ -> 19 +let max_register_pressure = function + Iextcall(_, _) -> [| 4; 8 |] + | _ -> [| 19; 29 |] + +(* Layout of the stack *) + +let num_stack_slots = [| 0; 0 |] +let contains_calls = ref false + +(* Calling the assembler *) + +let assemble_file infile outfile = + let as_cmd = + if digital_asm + then if !Clflags.gprofile then "as -O2 -nocpp -pg -o " + else "as -O2 -nocpp -o " + else "as -o " in + Ccomp.command (as_cmd ^ Filename.quote outfile ^ " " ^ Filename.quote infile) + +open Clflags;; +open Config;; diff --git a/asmcomp/alpha/reload.ml b/asmcomp/alpha/reload.ml new file mode 100644 index 00000000..17f0a371 --- /dev/null +++ b/asmcomp/alpha/reload.ml @@ -0,0 +1,18 @@ +(***********************************************************************) +(* *) +(* 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: reload.ml,v 1.3 1999/11/17 18:56:40 xleroy Exp $ *) + +(* Reloading for the Alpha *) + +let fundecl f = + (new Reloadgen.reload_generic)#fundecl f diff --git a/asmcomp/alpha/scheduling.ml b/asmcomp/alpha/scheduling.ml new file mode 100644 index 00000000..47a6b92d --- /dev/null +++ b/asmcomp/alpha/scheduling.ml @@ -0,0 +1,70 @@ +(***********************************************************************) +(* *) +(* 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: scheduling.ml,v 1.6 1999/11/17 18:56:40 xleroy Exp $ *) + +open Arch +open Mach + +(* The Digital Unix assembler does scheduling better than us. + However, the Linux-Alpha assembler does not do scheduling, so we do + a feeble attempt here. *) + +class scheduler = object (self) + +inherit Schedgen.scheduler_generic as super + +(* Latencies (in cycles). Based on the 21064, with some poetic license. *) + +method oper_latency = function + Ireload -> 3 + | Iload(_, _) -> 3 + | Iconst_symbol _ -> 3 (* turned into a load *) + | Iconst_float _ -> 3 (* ends up in a load *) + | Iintop(Imul) -> 23 + | Iintop_imm(Imul, _) -> 23 + | Iaddf -> 6 + | Isubf -> 6 + | Imulf -> 6 + | Idivf -> 63 + | _ -> 2 + (* Most arithmetic instructions can be executed back-to-back in 1 cycle. + However, some combinations (arith; load or arith; store) require 2 + cycles. Also, by claiming 2 cycles instead of 1, we might favor + dual issue. *) + +(* Issue cycles. Rough approximations. *) + +method oper_issue_cycles = function + Iconst_float _ -> 4 (* load from $gp, then load *) + | Ialloc _ -> 4 + | Iintop(Icheckbound) -> 2 + | Iintop_imm(Idiv, _) -> 3 + | Iintop_imm(Imod, _) -> 5 + | Iintop_imm(Icheckbound, _) -> 2 + | Ifloatofint -> 10 + | Iintoffloat -> 10 + | _ -> 1 + +(* Say that reloadgp is not part of a basic block (prevents moving it + past an operation that uses $gp) *) + +method oper_in_basic_block = function + Ispecific(Ireloadgp _) -> false + | op -> super#oper_in_basic_block op + +end + +let fundecl = + if digital_asm + then (fun f -> f) + else (new scheduler)#schedule_fundecl diff --git a/asmcomp/alpha/selection.ml b/asmcomp/alpha/selection.ml new file mode 100644 index 00000000..530c2f20 --- /dev/null +++ b/asmcomp/alpha/selection.ml @@ -0,0 +1,83 @@ +(***********************************************************************) +(* *) +(* 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: selection.ml,v 1.12 2001/07/24 08:01:25 xleroy Exp $ *) + +(* Instruction selection for the Alpha processor *) + +open Misc +open Cmm +open Reg +open Arch +open Mach + +class selector = object (self) + +inherit Selectgen.selector_generic as super + +method is_immediate n = digital_asm || (n >= 0 && n <= 255) + +method select_addressing = function + (* Force an explicit lda for non-scheduling assemblers, + this allows our scheduler to do a better job. *) + Cconst_symbol s when digital_asm -> + (Ibased(s, 0), Ctuple []) + | Cop((Cadda | Caddi), [Cconst_symbol s; Cconst_int n]) when digital_asm -> + (Ibased(s, n), Ctuple []) + | Cop((Cadda | Caddi), [arg; Cconst_int n]) -> + (Iindexed n, arg) + | Cop((Cadda | Caddi), [arg1; Cop(Caddi, [arg2; Cconst_int n])]) -> + (Iindexed n, Cop(Cadda, [arg1; arg2])) + | arg -> + (Iindexed 0, arg) + +method select_operation op args = + match (op, args) with + (* Recognize shift-add operations *) + ((Caddi|Cadda), + [arg2; Cop(Clsl, [arg1; Cconst_int(2|3 as shift)])]) -> + (Ispecific(if shift = 2 then Iadd4 else Iadd8), [arg1; arg2]) + | ((Caddi|Cadda), + [arg2; Cop(Cmuli, [arg1; Cconst_int(4|8 as mult)])]) -> + (Ispecific(if mult = 4 then Iadd4 else Iadd8), [arg1; arg2]) + | ((Caddi|Cadda), + [arg2; Cop(Cmuli, [Cconst_int(4|8 as mult); arg1])]) -> + (Ispecific(if mult = 4 then Iadd4 else Iadd8), [arg1; arg2]) + | (Caddi, [Cop(Clsl, [arg1; Cconst_int(2|3 as shift)]); arg2]) -> + (Ispecific(if shift = 2 then Iadd4 else Iadd8), [arg1; arg2]) + | (Caddi, [Cop(Cmuli, [arg1; Cconst_int(4|8 as mult)]); arg2]) -> + (Ispecific(if mult = 4 then Iadd4 else Iadd8), [arg1; arg2]) + | (Caddi, [Cop(Cmuli, [Cconst_int(4|8 as mult); arg1]); arg2]) -> + (Ispecific(if mult = 4 then Iadd4 else Iadd8), [arg1; arg2]) + | (Csubi, [Cop(Clsl, [arg1; Cconst_int(2|3 as shift)]); arg2]) -> + (Ispecific(if shift = 2 then Isub4 else Isub8), [arg1; arg2]) + | (Csubi, [Cop(Cmuli, [Cconst_int(4|8 as mult); arg1]); arg2]) -> + (Ispecific(if mult = 4 then Isub4 else Isub8), [arg1; arg2]) + (* Recognize truncation/normalization of 64-bit integers to 32 bits *) + | (Casr, [Cop(Clsl, [arg; Cconst_int 32]); Cconst_int 32]) -> + (Ispecific Itrunc32, [arg]) + (* Work around various limitations of the GNU assembler *) + | ((Caddi|Cadda), [arg1; Cconst_int n]) + when not (self#is_immediate n) && self#is_immediate (-n) -> + (Iintop_imm(Isub, -n), [arg1]) + | (Cdivi, [arg1; Cconst_int n]) + when (not digital_asm) && n <> 1 lsl (Misc.log2 n) -> + (Iintop Idiv, args) + | (Cmodi, [arg1; Cconst_int n]) + when (not digital_asm) && n <> 1 lsl (Misc.log2 n) -> + (Iintop Imod, args) + | _ -> + super#select_operation op args + +end + +let fundecl f = (new selector)#emit_fundecl f diff --git a/asmcomp/amd64/arch.ml b/asmcomp/amd64/arch.ml new file mode 100644 index 00000000..859dd4ac --- /dev/null +++ b/asmcomp/amd64/arch.ml @@ -0,0 +1,105 @@ +(***********************************************************************) +(* *) +(* 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 Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: arch.ml,v 1.1 2003/06/30 08:28:44 xleroy Exp $ *) + +(* Machine-specific command-line options *) + +let command_line_options = [] + +(* Specific operations for the AMD64 processor *) + +open Format + +type addressing_mode = + Ibased of string * int (* symbol + displ *) + | Iindexed of int (* reg + displ *) + | Iindexed2 of int (* reg + reg + displ *) + | Iscaled of int * int (* reg * scale + displ *) + | Iindexed2scaled of int * int (* reg + reg * scale + displ *) + +type specific_operation = + Ilea of addressing_mode (* "lea" gives scaled adds *) + | Istore_int of nativeint * addressing_mode (* Store an integer constant *) + | Istore_symbol of string * addressing_mode (* Store a symbol *) + | Ioffset_loc of int * addressing_mode (* Add a constant to a location *) + | Ifloatarithmem of float_operation * addressing_mode + (* Float arith operation with memory *) +and float_operation = + Ifloatadd | Ifloatsub | Ifloatmul | Ifloatdiv + +(* Sizes, endianness *) + +let big_endian = false + +let size_addr = 8 +let size_int = 8 +let size_float = 8 + +(* Operations on addressing modes *) + +let identity_addressing = Iindexed 0 + +let offset_addressing addr delta = + match addr with + Ibased(s, n) -> Ibased(s, n + delta) + | Iindexed n -> Iindexed(n + delta) + | Iindexed2 n -> Iindexed2(n + delta) + | Iscaled(scale, n) -> Iscaled(scale, n + delta) + | Iindexed2scaled(scale, n) -> Iindexed2scaled(scale, n + delta) + +let num_args_addressing = function + Ibased(s, n) -> 0 + | Iindexed n -> 1 + | Iindexed2 n -> 2 + | Iscaled(scale, n) -> 1 + | Iindexed2scaled(scale, n) -> 2 + +(* Printing operations and addressing modes *) + +let print_addressing printreg addr ppf arg = + match addr with + | Ibased(s, 0) -> + fprintf ppf "\"%s\"" s + | Ibased(s, n) -> + fprintf ppf "\"%s\" + %i" s n + | Iindexed n -> + let idx = if n <> 0 then Printf.sprintf " + %i" n else "" in + fprintf ppf "%a%s" printreg arg.(0) idx + | Iindexed2 n -> + let idx = if n <> 0 then Printf.sprintf " + %i" n else "" in + fprintf ppf "%a + %a%s" printreg arg.(0) printreg arg.(1) idx + | Iscaled(scale, n) -> + let idx = if n <> 0 then Printf.sprintf " + %i" n else "" in + fprintf ppf "%a * %i%s" printreg arg.(0) scale idx + | Iindexed2scaled(scale, n) -> + let idx = if n <> 0 then Printf.sprintf " + %i" n else "" in + fprintf ppf "%a + %a * %i%s" printreg arg.(0) printreg arg.(1) scale idx + +let print_specific_operation printreg op ppf arg = + match op with + | Ilea addr -> print_addressing printreg addr ppf arg + | Istore_int(n, addr) -> + fprintf ppf "[%a] := %nd" (print_addressing printreg addr) arg n + | Istore_symbol(lbl, addr) -> + fprintf ppf "[%a] := \"%s\"" (print_addressing printreg addr) arg lbl + | Ioffset_loc(n, addr) -> + fprintf ppf "[%a] +:= %i" (print_addressing printreg addr) arg n + | Ifloatarithmem(op, addr) -> + let op_name = function + | Ifloatadd -> "+f" + | Ifloatsub -> "-f" + | Ifloatmul -> "*f" + | Ifloatdiv -> "/f" in + fprintf ppf "%a %s float64[%a]" printreg arg.(0) (op_name op) + (print_addressing printreg addr) + (Array.sub arg 1 (Array.length arg - 1)) diff --git a/asmcomp/amd64/emit.mlp b/asmcomp/amd64/emit.mlp new file mode 100644 index 00000000..e73abe49 --- /dev/null +++ b/asmcomp/amd64/emit.mlp @@ -0,0 +1,682 @@ +(***********************************************************************) +(* *) +(* 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: emit.mlp,v 1.2 2003/06/30 11:29:26 xleroy Exp $ *) + +(* Emission of Intel 386 assembly code *) + +open Misc +open Cmm +open Arch +open Proc +open Reg +open Mach +open Linearize +open Emitaux + +(* Tradeoff between code size and code speed *) + +let fastcode_flag = ref true + +let stack_offset = ref 0 + +(* Layout of the stack frame *) + +let frame_required () = + !contains_calls || num_stack_slots.(0) > 0 || num_stack_slots.(1) > 0 + +let frame_size () = (* includes return address *) + let sz = (!stack_offset + 8 * (num_stack_slots.(0) + num_stack_slots.(1)) + 8) + in Misc.align sz 16 + +let slot_offset loc cl = + match loc with + Incoming n -> frame_size() + n + | Local n -> + if cl = 0 + then !stack_offset + n * 8 + else !stack_offset + (num_stack_slots.(0) + n) * 8 + | Outgoing n -> n + +(* Symbols *) + +let emit_symbol s = + Emitaux.emit_symbol '$' s + +(* Output a label *) + +let emit_label lbl = + emit_string ".L"; emit_int lbl + +(* Output a .align directive. *) + +let emit_align n = + ` .align {emit_int n}\n` + +let emit_Llabel fallthrough lbl = + if not fallthrough && !fastcode_flag then emit_align 4; + emit_label lbl + +(* Output a pseudo-register *) + +let emit_reg = function + { loc = Reg r } -> + emit_string (register_name r) + | { loc = Stack s } as r -> + let ofs = slot_offset s (register_class r) in + `{emit_int ofs}(%rsp)` + | { loc = Unknown } -> + assert false + +(* Output a reference to the lower 8, 16 or 32 bits of a register *) + +let reg_low_8_name = + [| "%al"; "%bl"; "%dil"; "%sil"; "%dl"; "%cl"; "%r8b"; "%r9b"; + "%r10b"; "%r11b"; "%bpl"; "%r12b"; "%r13b" |] +let reg_low_16_name = + [| "%ax"; "%bx"; "%di"; "%si"; "%dx"; "%cx"; "%r8w"; "%r9w"; + "%r10w"; "%r11w"; "%bp"; "%r12w"; "%r13w" |] +let reg_low_32_name = + [| "%eax"; "%ebx"; "%edi"; "%esi"; "%edx"; "%ecx"; "%r8d"; "%r9d"; + "%r10d"; "%r11d"; "%ebp"; "%r12d"; "%r13d" |] + +let emit_subreg tbl r = + match r.loc with + Reg r when r < 13 -> + emit_string tbl.(r) + | Stack s -> + let ofs = slot_offset s (register_class r) in + `{emit_int ofs}(%rsp)` + | _ -> + assert false + +let emit_reg8 r = emit_subreg reg_low_8_name r +let emit_reg16 r = emit_subreg reg_low_16_name r +let emit_reg32 r = emit_subreg reg_low_32_name r + +(* Output an addressing mode *) + +let emit_addressing addr r n = + match addr with + Ibased(s, d) -> + `{emit_symbol s}`; + if d <> 0 then ` + {emit_int d}`; + `(%rip)` + | Iindexed d -> + if d <> 0 then emit_int d; + `({emit_reg r.(n)})` + | Iindexed2 d -> + if d <> 0 then emit_int d; + `({emit_reg r.(n)}, {emit_reg r.(n+1)})` + | Iscaled(2, d) -> + if d <> 0 then emit_int d; + `({emit_reg r.(n)}, {emit_reg r.(n)})` + | Iscaled(scale, d) -> + if d <> 0 then emit_int d; + `(, {emit_reg r.(n)}, {emit_int scale})` + | Iindexed2scaled(scale, d) -> + if d <> 0 then emit_int d; + `({emit_reg r.(n)}, {emit_reg r.(n+1)}, {emit_int scale})` + +(* Record live pointers at call points *) + +type frame_descr = + { fd_lbl: int; (* Return address *) + fd_frame_size: int; (* Size of stack frame *) + fd_live_offset: int list } (* Offsets/regs of live addresses *) + +let frame_descriptors = ref([] : frame_descr list) + +let record_frame_label live = + let lbl = new_label() in + let live_offset = ref [] in + Reg.Set.iter + (function + {typ = Addr; loc = Reg r} -> + live_offset := ((r lsl 1) + 1) :: !live_offset + | {typ = Addr; loc = Stack s} as reg -> + live_offset := slot_offset s (register_class reg) :: !live_offset + | _ -> ()) + live; + frame_descriptors := + { fd_lbl = lbl; + fd_frame_size = frame_size(); + fd_live_offset = !live_offset } :: !frame_descriptors; + lbl + +let record_frame live = + let lbl = record_frame_label live in `{emit_label lbl}:\n` + +let emit_frame fd = + ` .quad {emit_label fd.fd_lbl}\n`; + ` .word {emit_int fd.fd_frame_size}\n`; + ` .word {emit_int (List.length fd.fd_live_offset)}\n`; + List.iter + (fun n -> + ` .word {emit_int n}\n`) + fd.fd_live_offset; + emit_align 8 + +(* Record calls to the GC -- we've moved them out of the way *) + +type gc_call = + { gc_lbl: label; (* Entry label *) + gc_return_lbl: label; (* Where to branch after GC *) + gc_frame: label } (* Label of frame descriptor *) + +let call_gc_sites = ref ([] : gc_call list) + +let emit_call_gc gc = + `{emit_label gc.gc_lbl}: call {emit_symbol "caml_call_gc"}\n`; + `{emit_label gc.gc_frame}: jmp {emit_label gc.gc_return_lbl}\n` + +(* Names for instructions *) + +let instr_for_intop = function + Iadd -> "addq" + | Isub -> "subq" + | Imul -> "imulq" + | Iand -> "andq" + | Ior -> "orq" + | Ixor -> "xorq" + | Ilsl -> "salq" + | Ilsr -> "shrq" + | Iasr -> "sarq" + | _ -> assert false + +let instr_for_floatop = function + Iaddf -> "addsd" + | Isubf -> "subsd" + | Imulf -> "mulsd" + | Idivf -> "divsd" + | _ -> assert false + +let instr_for_floatarithmem = function + Ifloatadd -> "addsd" + | Ifloatsub -> "subsd" + | Ifloatmul -> "mulsd" + | Ifloatdiv -> "divsd" + +let name_for_cond_branch = function + Isigned Ceq -> "e" | Isigned Cne -> "ne" + | Isigned Cle -> "le" | Isigned Cgt -> "g" + | Isigned Clt -> "l" | Isigned Cge -> "ge" + | Iunsigned Ceq -> "e" | Iunsigned Cne -> "ne" + | Iunsigned Cle -> "be" | Iunsigned Cgt -> "a" + | Iunsigned Clt -> "b" | Iunsigned Cge -> "ae" + +(* Output an = 0 or <> 0 test. *) + +let output_test_zero arg = + match arg.loc with + Reg r -> ` testq {emit_reg arg}, {emit_reg arg}\n` + | _ -> ` cmpq $0, {emit_reg arg}\n` + +(* Output a floating-point compare and branch *) + +let emit_float_test cmp neg arg lbl = + begin match cmp with + | Ceq | Cne -> ` ucomisd ` + | _ -> ` comisd ` + end; + `{emit_reg arg.(1)}, {emit_reg arg.(0)}\n`; + let (branch_opcode, need_jp) = + match (cmp, neg) with + (Ceq, false) -> ("je", true) + | (Ceq, true) -> ("jne", true) + | (Cne, false) -> ("jne", true) + | (Cne, true) -> ("je", true) + | (Clt, false) -> ("jb", true) + | (Clt, true) -> ("jae", true) + | (Cle, false) -> ("jbe", true) + | (Cle, true) -> ("ja", true) + | (Cgt, false) -> ("ja", false) + | (Cgt, true) -> ("jbe", false) + | (Cge, false) -> ("jae", true) + | (Cge, true) -> ("jb", false) in + let branch_if_not_comparable = + if cmp = Cne then not neg else neg in + if need_jp then + if branch_if_not_comparable then begin + ` jp {emit_label lbl}\n`; + ` {emit_string branch_opcode} {emit_label lbl}\n` + end else begin + let next = new_label() in + ` jp {emit_label next}\n`; + ` {emit_string branch_opcode} {emit_label lbl}\n`; + `{emit_label next}:\n` + end + else begin + ` {emit_string branch_opcode} {emit_label lbl}\n` + end + +(* Deallocate the stack frame before a return or tail call *) + +let output_epilogue () = + if frame_required() then begin + let n = frame_size() - 8 in + ` addq ${emit_int n}, %rsp\n` + end + +(* Output the assembly code for an instruction *) + +(* Name of current function *) +let function_name = ref "" +(* Entry point for tail recursive calls *) +let tailrec_entry_point = ref 0 +(* Label of trap for out-of-range accesses *) +let range_check_trap = ref 0 + +let float_constants = ref ([] : (int * string) list) + +let emit_instr fallthrough i = + match i.desc with + Lend -> () + | Lop(Imove | Ispill | Ireload) -> + let src = i.arg.(0) and dst = i.res.(0) in + if src.loc <> dst.loc then begin + if src.typ = Float then + ` movsd {emit_reg src}, {emit_reg dst}\n` + else + ` movq {emit_reg src}, {emit_reg dst}\n` + end + | Lop(Iconst_int n) -> + if n = 0n then begin + match i.res.(0).loc with + Reg n -> ` xorq {emit_reg i.res.(0)}, {emit_reg i.res.(0)}\n` + | _ -> ` movq $0, {emit_reg i.res.(0)}\n` + end else if n <= 0x7FFFFFFFn && n >= -0x80000000n then + ` movq ${emit_nativeint n}, {emit_reg i.res.(0)}\n` + else + ` movabsq ${emit_nativeint n}, {emit_reg i.res.(0)}\n` + | Lop(Iconst_float s) -> + let f = float_of_string s in + if f = 0.0 then + ` xorpd {emit_reg i.res.(0)}, {emit_reg i.res.(0)}\n` + else begin + let lbl = new_label() in + float_constants := (lbl, s) :: !float_constants; + ` movlpd {emit_label lbl}(%rip), {emit_reg i.res.(0)}\n` + end + | Lop(Iconst_symbol s) -> + ` movq ${emit_symbol s}, {emit_reg i.res.(0)}\n` + | Lop(Icall_ind) -> + ` call *{emit_reg i.arg.(0)}\n`; + record_frame i.live + | Lop(Icall_imm s) -> + ` call {emit_symbol s}\n`; + record_frame i.live + | Lop(Itailcall_ind) -> + output_epilogue(); + ` jmp *{emit_reg i.arg.(0)}\n` + | Lop(Itailcall_imm s) -> + if s = !function_name then + ` jmp {emit_label !tailrec_entry_point}\n` + else begin + output_epilogue(); + ` jmp {emit_symbol s}\n` + end + | Lop(Iextcall(s, alloc)) -> + if alloc then begin + ` movq ${emit_symbol s}, %rax\n`; + ` call {emit_symbol "caml_c_call"}\n`; + record_frame i.live + end else begin + ` call {emit_symbol s}\n` + end + | Lop(Istackoffset n) -> + if n < 0 + then ` addq ${emit_int(-n)}, %rsp\n` + else ` subq ${emit_int(n)}, %rsp\n`; + stack_offset := !stack_offset + n + | Lop(Iload(chunk, addr)) -> + let dest = i.res.(0) in + begin match chunk with + | Word -> + ` movq {emit_addressing addr i.arg 0}, {emit_reg dest}\n` + | Byte_unsigned -> + ` movzbq {emit_addressing addr i.arg 0}, {emit_reg dest}\n` + | Byte_signed -> + ` movsbq {emit_addressing addr i.arg 0}, {emit_reg dest}\n` + | Sixteen_unsigned -> + ` movzwq {emit_addressing addr i.arg 0}, {emit_reg dest}\n` + | Sixteen_signed -> + ` movswq {emit_addressing addr i.arg 0}, {emit_reg dest}\n` + | Thirtytwo_unsigned -> + ` movl {emit_addressing addr i.arg 0}, {emit_reg32 dest}\n` + | Thirtytwo_signed -> + ` movslq {emit_addressing addr i.arg 0}, {emit_reg dest}\n` + | Single -> + ` cvtss2sd {emit_addressing addr i.arg 0}, {emit_reg dest}\n` + | Double | Double_u -> + ` movlpd {emit_addressing addr i.arg 0}, {emit_reg dest}\n` + end + | Lop(Istore(chunk, addr)) -> + begin match chunk with + | Word -> + ` movq {emit_reg i.arg.(0)}, {emit_addressing addr i.arg 1}\n` + | Byte_unsigned | Byte_signed -> + ` movb {emit_reg8 i.arg.(0)}, {emit_addressing addr i.arg 1}\n` + | Sixteen_unsigned | Sixteen_signed -> + ` movw {emit_reg16 i.arg.(0)}, {emit_addressing addr i.arg 1}\n` + | Thirtytwo_signed | Thirtytwo_unsigned -> + ` movl {emit_reg32 i.arg.(0)}, {emit_addressing addr i.arg 1}\n` + | Single -> + ` cvtsd2ss {emit_reg i.arg.(0)}, %xmm15\n`; + ` movss %xmm15, {emit_addressing addr i.arg 1}\n` + | Double | Double_u -> + ` movlpd {emit_reg i.arg.(0)}, {emit_addressing addr i.arg 1}\n` + end + | Lop(Ialloc n) -> + if !fastcode_flag then begin + let lbl_redo = new_label() in + `{emit_label lbl_redo}: subq ${emit_int n}, %r15\n`; + ` cmpq {emit_symbol "young_limit"}(%rip), %r15\n`; + let lbl_call_gc = new_label() in + let lbl_frame = record_frame_label i.live in + ` jb {emit_label lbl_call_gc}\n`; + ` leaq 8(%r15), {emit_reg i.res.(0)}\n`; + call_gc_sites := + { gc_lbl = lbl_call_gc; + gc_return_lbl = lbl_redo; + gc_frame = lbl_frame } :: !call_gc_sites + end else begin + begin match n with + 16 -> ` call {emit_symbol "caml_alloc1"}\n` + | 24 -> ` call {emit_symbol "caml_alloc2"}\n` + | 32 -> ` call {emit_symbol "caml_alloc3"}\n` + | _ -> ` movq ${emit_int n}, %rax\n`; + ` call {emit_symbol "caml_alloc"}\n` + end; + `{record_frame i.live} leaq 8(%r15), {emit_reg i.res.(0)}\n` + end + | Lop(Iintop(Icomp cmp)) -> + ` cmpq {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}\n`; + let b = name_for_cond_branch cmp in + ` set{emit_string b} %al\n`; + ` movzbq %al, {emit_reg i.res.(0)}\n` + | Lop(Iintop_imm(Icomp cmp, n)) -> + ` cmpq ${emit_int n}, {emit_reg i.arg.(0)}\n`; + let b = name_for_cond_branch cmp in + ` set{emit_string b} %al\n`; + ` movzbq %al, {emit_reg i.res.(0)}\n` + | Lop(Iintop Icheckbound) -> + if !range_check_trap = 0 then range_check_trap := new_label(); + ` cmpq {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}\n`; + ` jbe {emit_label !range_check_trap}\n` + | Lop(Iintop_imm(Icheckbound, n)) -> + if !range_check_trap = 0 then range_check_trap := new_label(); + ` cmpq ${emit_int n}, {emit_reg i.arg.(0)}\n`; + ` jbe {emit_label !range_check_trap}\n` + | Lop(Iintop(Idiv | Imod)) -> + ` cqto\n`; + ` idivq {emit_reg i.arg.(1)}\n` + | Lop(Iintop(Ilsl | Ilsr | Iasr as op)) -> + (* We have i.arg.(0) = i.res.(0) and i.arg.(1) = %rcx *) + ` {emit_string(instr_for_intop op)} %cl, {emit_reg i.res.(0)}\n` + | Lop(Iintop op) -> + (* We have i.arg.(0) = i.res.(0) *) + ` {emit_string(instr_for_intop op)} {emit_reg i.arg.(1)}, {emit_reg i.res.(0)}\n` + | Lop(Iintop_imm(Iadd, n)) when i.arg.(0).loc <> i.res.(0).loc -> + ` leaq {emit_int n}({emit_reg i.arg.(0)}), {emit_reg i.res.(0)}\n` + | Lop(Iintop_imm(Iadd, 1) | Iintop_imm(Isub, -1)) -> + ` incq {emit_reg i.res.(0)}\n` + | Lop(Iintop_imm(Iadd, -1) | Iintop_imm(Isub, 1)) -> + ` decq {emit_reg i.res.(0)}\n` + | Lop(Iintop_imm(Idiv, n)) -> + (* Note: i.arg.(0) = i.res.(0) = rdx (cf. selection.ml) *) + let l = Misc.log2 n in + ` movq {emit_reg i.arg.(0)}, %rax\n`; + ` addq ${emit_int(n-1)}, {emit_reg i.arg.(0)}\n`; + ` testq %rax, %rax\n`; + ` cmovns %rax, {emit_reg i.arg.(0)}\n`; + ` sarq ${emit_int l}, {emit_reg i.res.(0)}\n` + | Lop(Iintop_imm(Imod, n)) -> + (* Note: i.arg.(0) = i.res.(0) = rdx (cf. selection.ml) *) + let l = Misc.log2 n in + ` movq {emit_reg i.arg.(0)}, %rax\n`; + ` testq %rax, %rax\n`; + ` leaq {emit_int(n-1)}(%rax), %rax\n`; + ` cmovns {emit_reg i.arg.(0)}, %rax\n`; + ` andq ${emit_int (-n)}, %rax\n`; + ` subq %rax, {emit_reg i.res.(0)}\n` + | Lop(Iintop_imm(op, n)) -> + (* We have i.arg.(0) = i.res.(0) *) + ` {emit_string(instr_for_intop op)} ${emit_int n}, {emit_reg i.res.(0)}\n` + | Lop(Inegf) -> + ` xorpd {emit_symbol "caml_negf_mask"}(%rip), {emit_reg i.res.(0)}\n` + | Lop(Iabsf) -> + ` andpd {emit_symbol "caml_absf_mask"}(%rip), {emit_reg i.res.(0)}\n` + | Lop(Iaddf | Isubf | Imulf | Idivf as floatop) -> + ` {emit_string(instr_for_floatop floatop)} {emit_reg i.arg.(1)}, {emit_reg i.res.(0)}\n` + | Lop(Ifloatofint) -> + ` cvtsi2sdq {emit_reg i.arg.(0)}, {emit_reg i.res.(0)}\n` + | Lop(Iintoffloat) -> + ` cvttsd2siq {emit_reg i.arg.(0)}, {emit_reg i.res.(0)}\n` + | Lop(Ispecific(Ilea addr)) -> + ` leaq {emit_addressing addr i.arg 0}, {emit_reg i.res.(0)}\n` + | Lop(Ispecific(Istore_int(n, addr))) -> + ` movq ${emit_nativeint n}, {emit_addressing addr i.arg 0}\n` + | Lop(Ispecific(Istore_symbol(s, addr))) -> + ` movq ${emit_symbol s}, {emit_addressing addr i.arg 0}\n` + | Lop(Ispecific(Ioffset_loc(n, addr))) -> + ` addq ${emit_int n}, {emit_addressing addr i.arg 0}\n` + | Lop(Ispecific(Ifloatarithmem(op, addr))) -> + ` {emit_string(instr_for_floatarithmem op)} {emit_addressing addr i.arg 1}, {emit_reg i.res.(0)}\n` + | Lreloadretaddr -> + () + | Lreturn -> + output_epilogue(); + ` ret\n` + | Llabel lbl -> + `{emit_Llabel fallthrough lbl}:\n` + | Lbranch lbl -> + ` jmp {emit_label lbl}\n` + | Lcondbranch(tst, lbl) -> + begin match tst with + Itruetest -> + output_test_zero i.arg.(0); + ` jne {emit_label lbl}\n` + | Ifalsetest -> + output_test_zero i.arg.(0); + ` je {emit_label lbl}\n` + | Iinttest cmp -> + ` cmpq {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}\n`; + let b = name_for_cond_branch cmp in + ` j{emit_string b} {emit_label lbl}\n` + | Iinttest_imm((Isigned Ceq | Isigned Cne | + Iunsigned Ceq | Iunsigned Cne) as cmp, 0) -> + output_test_zero i.arg.(0); + let b = name_for_cond_branch cmp in + ` j{emit_string b} {emit_label lbl}\n` + | Iinttest_imm(cmp, n) -> + ` cmpq ${emit_int n}, {emit_reg i.arg.(0)}\n`; + let b = name_for_cond_branch cmp in + ` j{emit_string b} {emit_label lbl}\n` + | Ifloattest(cmp, neg) -> + emit_float_test cmp neg i.arg lbl + | Ioddtest -> + ` testb $1, {emit_reg8 i.arg.(0)}\n`; + ` jne {emit_label lbl}\n` + | Ieventest -> + ` testb $1, {emit_reg8 i.arg.(0)}\n`; + ` je {emit_label lbl}\n` + end + | Lcondbranch3(lbl0, lbl1, lbl2) -> + ` cmpq $1, {emit_reg i.arg.(0)}\n`; + begin match lbl0 with + None -> () + | Some lbl -> ` jb {emit_label lbl}\n` + end; + begin match lbl1 with + None -> () + | Some lbl -> ` je {emit_label lbl}\n` + end; + begin match lbl2 with + None -> () + | Some lbl -> ` jg {emit_label lbl}\n` + end + | Lswitch jumptbl -> + let lbl = new_label() in + ` jmp *{emit_label lbl}(, {emit_reg i.arg.(0)}, 8)\n`; + ` .section .rodata\n`; + emit_align 8; + `{emit_label lbl}:`; + for i = 0 to Array.length jumptbl - 1 do + ` .quad {emit_label jumptbl.(i)}\n` + done; + ` .text\n` + | Lsetuptrap lbl -> + ` call {emit_label lbl}\n` + | Lpushtrap -> + ` pushq %r14\n`; + ` movq %rsp, %r14\n`; + stack_offset := !stack_offset + 16 + | Lpoptrap -> + ` popq %r14\n`; + ` addq $8, %rsp\n`; + stack_offset := !stack_offset - 16 + | Lraise -> + ` movq %r14, %rsp\n`; + ` popq %r14\n`; + ` ret\n` + +let rec emit_all fallthrough i = + match i.desc with + | Lend -> () + | _ -> + emit_instr fallthrough i; + emit_all (Linearize.has_fallthrough i.desc) i.next + +(* Emission of the floating-point constants *) + +let emit_float_constant (lbl, cst) = + `{emit_label lbl}: .double {emit_string cst}\n` + +(* Emission of the profiling prelude -- FIXME *) + +let emit_profile () = + match Config.system with + "linux_elf" -> + ` pushl %eax\n`; + ` movl %esp, %ebp\n`; + ` pushl %ecx\n`; + ` pushl %edx\n`; + ` call {emit_symbol "mcount"}\n`; + ` popl %edx\n`; + ` popl %ecx\n`; + ` popl %eax\n` + | "bsd_elf" -> + ` pushl %eax\n`; + ` movl %esp, %ebp\n`; + ` pushl %ecx\n`; + ` pushl %edx\n`; + ` call .mcount\n`; + ` popl %edx\n`; + ` popl %ecx\n`; + ` popl %eax\n` + | _ -> () (*unsupported yet*) + +(* Emission of a function declaration *) + +let fundecl fundecl = + function_name := fundecl.fun_name; + fastcode_flag := fundecl.fun_fast; + tailrec_entry_point := new_label(); + stack_offset := 0; + float_constants := []; + call_gc_sites := []; + range_check_trap := 0; + ` .text\n`; + emit_align 16; + ` .globl {emit_symbol fundecl.fun_name}\n`; + `{emit_symbol fundecl.fun_name}:\n`; + if !Clflags.gprofile then emit_profile(); + if frame_required() then begin + let n = frame_size() - 8 in + ` subq ${emit_int n}, %rsp\n` + end; + `{emit_label !tailrec_entry_point}:\n`; + emit_all true fundecl.fun_body; + List.iter emit_call_gc !call_gc_sites; + if !range_check_trap > 0 then + `{emit_label !range_check_trap}: call {emit_symbol "caml_array_bound_error"}\n`; + (* Never returns, but useful to have retaddr on stack for debugging *) + if !float_constants <> [] then begin + ` .section .rodata.cst8,\"aM\",@progbits,8\n`; + List.iter emit_float_constant !float_constants + end + +(* Emission of data *) + +let emit_item = function + Cglobal_symbol s -> + ` .globl {emit_symbol s}\n`; + | Cdefine_symbol s -> + `{emit_symbol s}:\n` + | Cdefine_label lbl -> + `{emit_label (100000 + lbl)}:\n` + | Cint8 n -> + ` .byte {emit_int n}\n` + | Cint16 n -> + ` .word {emit_int n}\n` + | Cint32 n -> + ` .long {emit_nativeint n}\n` + | Cint n -> + ` .quad {emit_nativeint n}\n` + | Csingle f -> + ` .float {emit_string f}\n` + | Cdouble f -> + ` .double {emit_string f}\n` + | Csymbol_address s -> + ` .quad {emit_symbol s}\n` + | Clabel_address lbl -> + ` .quad {emit_label (100000 + lbl)}\n` + | Cstring s -> + emit_string_directive " .ascii " s + | Cskip n -> + if n > 0 then ` .space {emit_int n}\n` + | Calign n -> + emit_align n + +let data l = + ` .data\n`; + List.iter emit_item l + +(* Beginning / end of an assembly file *) + +let begin_assembly() = + let lbl_begin = Compilenv.current_unit_name() ^ "__data_begin" in + ` .data\n`; + ` .globl {emit_symbol lbl_begin}\n`; + `{emit_symbol lbl_begin}:\n`; + let lbl_begin = Compilenv.current_unit_name() ^ "__code_begin" in + ` .text\n`; + ` .globl {emit_symbol lbl_begin}\n`; + `{emit_symbol lbl_begin}:\n` + +let end_assembly() = + let lbl_end = Compilenv.current_unit_name() ^ "__code_end" in + ` .text\n`; + ` .globl {emit_symbol lbl_end}\n`; + `{emit_symbol lbl_end}:\n`; + ` .data\n`; + let lbl_end = Compilenv.current_unit_name() ^ "__data_end" in + ` .globl {emit_symbol lbl_end}\n`; + `{emit_symbol lbl_end}:\n`; + ` .long 0\n`; + let lbl = Compilenv.current_unit_name() ^ "__frametable" in + ` .globl {emit_symbol lbl}\n`; + `{emit_symbol lbl}:\n`; + ` .quad {emit_int (List.length !frame_descriptors)}\n`; + List.iter emit_frame !frame_descriptors; + frame_descriptors := [] diff --git a/asmcomp/amd64/proc.ml b/asmcomp/amd64/proc.ml new file mode 100644 index 00000000..057c5225 --- /dev/null +++ b/asmcomp/amd64/proc.ml @@ -0,0 +1,199 @@ +(***********************************************************************) +(* *) +(* 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 Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: proc.ml,v 1.1 2003/06/30 08:28:44 xleroy Exp $ *) + +(* Description of the AMD64 processor *) + +open Misc +open Arch +open Cmm +open Reg +open Mach + +(* Registers available for register allocation *) + +(* Register map: + rax 0 rax - r11: Caml function arguments + rbx 1 rdi - r9: C function arguments + rdi 2 rax: Caml and C function results + rsi 3 rbx, rbp, r12-r15 are preserved by C + rdx 4 + rcx 5 + r8 6 + r9 7 + r10 8 + r11 9 + rbp 10 + r12 11 + r13 12 + r14 trap pointer + r15 allocation pointer + + xmm0 - xmm15 100 - 115 xmm0 - xmm9: Caml function arguments + xmm0 - xmm7: C function arguments + xmm0: Caml and C function results *) + +let int_reg_name = + [| "%rax"; "%rbx"; "%rdi"; "%rsi"; "%rdx"; "%rcx"; "%r8"; "%r9"; + "%r10"; "%r11"; "%rbp"; "%r12"; "%r13" |] + +let float_reg_name = + [| "%xmm0"; "%xmm1"; "%xmm2"; "%xmm3"; "%xmm4"; "%xmm5"; "%xmm6"; "%xmm7"; + "%xmm8"; "%xmm9"; "%xmm10"; "%xmm11"; + "%xmm12"; "%xmm13"; "%xmm14"; "%xmm15" |] + +let num_register_classes = 2 + +let register_class r = + match r.typ with + Int -> 0 + | Addr -> 0 + | Float -> 1 + +let num_available_registers = [| 13; 16 |] + +let first_available_register = [| 0; 100 |] + +let register_name r = + if r < 100 then int_reg_name.(r) else float_reg_name.(r - 100) + +(* Pack registers starting at %rax so as to reduce the number of REX + prefixes and thus improve code density *) +let rotate_registers = false + +(* Representation of hard registers by pseudo-registers *) + +let hard_int_reg = + let v = Array.create 13 Reg.dummy in + for i = 0 to 12 do v.(i) <- Reg.at_location Int (Reg i) done; + v + +let hard_float_reg = + let v = Array.create 16 Reg.dummy in + for i = 0 to 15 do v.(i) <- Reg.at_location Float (Reg (100 + i)) done; + v + +let all_phys_regs = + Array.append hard_int_reg hard_float_reg + +let phys_reg n = + if n < 100 then hard_int_reg.(n) else hard_float_reg.(n - 100) + +let rax = phys_reg 0 +let rcx = phys_reg 5 +let rdx = phys_reg 4 +let rxmm15 = phys_reg 115 + +let stack_slot slot ty = + Reg.at_location ty (Stack slot) + +(* Instruction selection *) + +let word_addressed = false + +(* Calling conventions *) + +let calling_conventions first_int last_int first_float last_float make_stack + arg = + let loc = Array.create (Array.length arg) Reg.dummy in + let int = ref first_int in + let float = ref first_float in + let ofs = ref 0 in + for i = 0 to Array.length arg - 1 do + match arg.(i).typ with + Int | Addr as ty -> + if !int <= last_int then begin + loc.(i) <- phys_reg !int; + incr int + end else begin + loc.(i) <- stack_slot (make_stack !ofs) ty; + ofs := !ofs + size_int + end + | Float -> + if !float <= last_float then begin + loc.(i) <- phys_reg !float; + incr float + end else begin + loc.(i) <- stack_slot (make_stack !ofs) Float; + ofs := !ofs + size_float + end + done; + (loc, Misc.align !ofs 16) (* keep stack 16-aligned *) + +let incoming ofs = Incoming ofs +let outgoing ofs = Outgoing ofs +let not_supported ofs = fatal_error "Proc.loc_results: cannot call" + +let loc_arguments arg = + calling_conventions 0 9 100 109 outgoing arg +let loc_parameters arg = + let (loc, ofs) = calling_conventions 0 9 100 109 incoming arg in loc +let loc_results res = + let (loc, ofs) = calling_conventions 0 0 100 100 not_supported res in loc + +(* C calling convention: + first integer args in rdi, rsi, rdx, rcx, r8, r9 + first float args in xmm0 ... xmm7 + remaining args on stack. + Return value in rax or xmm0. *) + +let loc_external_arguments arg = + calling_conventions 2 7 100 107 outgoing arg +let loc_external_results res = + let (loc, ofs) = calling_conventions 0 0 100 100 not_supported res in loc + +let loc_exn_bucket = rax + +(* Registers destroyed by operations *) + +let destroyed_at_c_call = (* rbp, rbx, r12-r15 preserved *) + Array.of_list(List.map phys_reg + [0;2;3;4;5;6;7;8;9; + 100;101;102;103;104;105;106;107; + 108;109;110;111;112;113;114;115]) + +let destroyed_at_oper = function + Iop(Icall_ind | Icall_imm _ | Iextcall(_, true)) -> all_phys_regs + | Iop(Iextcall(_, false)) -> destroyed_at_c_call + | Iop(Iintop(Idiv | Imod)) -> [| rax; rdx |] + | Iop(Istore(Single, _)) -> [| rxmm15 |] + | Iop(Ialloc _ | Iintop(Icomp _) | Iintop_imm((Idiv|Imod|Icomp _), _)) + -> [| rax |] + | _ -> [||] + +let destroyed_at_raise = all_phys_regs + +(* Maximal register pressure *) + +let safe_register_pressure = function + Iextcall(_,_) -> 0 + | _ -> 11 + +let max_register_pressure = function + Iextcall(_, _) -> [| 4; 0 |] + | Iintop(Idiv | Imod) -> [| 11; 16 |] + | Ialloc _ | Iintop(Icomp _) | Iintop_imm((Idiv|Imod|Icomp _), _) + -> [| 12; 16 |] + | Istore(Single, _) -> [| 13; 15 |] + | _ -> [| 13; 16 |] + +(* Layout of the stack frame *) + +let num_stack_slots = [| 0; 0 |] +let contains_calls = ref false + +(* Calling the assembler *) + +let assemble_file infile outfile = + Ccomp.command ("as -o " ^ outfile ^ " " ^ infile) + diff --git a/asmcomp/amd64/reload.ml b/asmcomp/amd64/reload.ml new file mode 100644 index 00000000..d9a56459 --- /dev/null +++ b/asmcomp/amd64/reload.ml @@ -0,0 +1,113 @@ +(***********************************************************************) +(* *) +(* 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 Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: reload.ml,v 1.1 2003/06/30 08:28:44 xleroy Exp $ *) + +open Cmm +open Arch +open Reg +open Mach + +(* Reloading for the AMD64 *) + +(* Summary of instruction set constraints: + "S" means either stack or register, "R" means register only. + Operation Res Arg1 Arg2 + Imove R S + or S R + Iconst_int S + Iconst_float R + Iconst_symbol S + Icall_ind R + Itailcall_ind R + Iload R R R + Istore R R + Iintop(Icomp) R R S + or S S R + Iintop(Imul|Idiv|mod) R R S + Iintop(shift) S S R + Iintop(others) R R S + or S S R + Iintop_imm(Iadd, n)/lea R R + Iintop_imm(others) S S + Inegf...Idivf R R S + Ifloatofint R S + Iintoffloat R S + Ispecific(Ilea) R R R + Ispecific(Ifloatarithmem) R R R + + Conditional branches: + Iinttest S R + or R S + Ifloattest R S + other tests S +*) + +let stackp r = + match r.loc with + Stack _ -> true + | _ -> false + +class reload = object (self) + +inherit Reloadgen.reload_generic as super + +method reload_operation op arg res = + match op with + Iintop(Iadd|Isub|Iand|Ior|Ixor|Icomp _|Icheckbound) -> + (* One of the two arguments can reside in the stack, but not both *) + if stackp arg.(0) && stackp arg.(1) + then ([|arg.(0); self#makereg arg.(1)|], res) + else (arg, res) + | Iintop_imm(Iadd, _) when arg.(0).loc <> res.(0).loc -> + (* This add will be turned into a lea; args and results must be + in registers *) + super#reload_operation op arg res + | Iconst_int _ | Iconst_symbol _ + | Iintop(Idiv | Imod | Ilsl | Ilsr | Iasr) + | Iintop_imm(_, _) -> + (* The argument(s) and results can be either in register or on stack *) + (* Note: Idiv, Imod: arg(0) and res(0) already forced in regs + Ilsl, Ilsr, Iasr: arg(1) already forced in regs *) + (arg, res) + | Iintop(Imul) | Iaddf | Isubf | Imulf | Idivf -> + (* First argument (= result) must be in register, second arg + can reside in the stack *) + if stackp arg.(0) + then (let r = self#makereg arg.(0) in ([|r; arg.(1)|], [|r|])) + else (arg, res) + | Ifloatofint | Iintoffloat -> + (* Result must be in register, but argument can be on stack *) + (arg, (if stackp res.(0) then [| self#makereg res.(0) |] else res)) + | _ -> (* Other operations: all args and results in registers *) + super#reload_operation op arg res + +method reload_test tst arg = + match tst with + Iinttest cmp -> + (* One of the two arguments can reside on stack *) + if stackp arg.(0) && stackp arg.(1) + then [| self#makereg arg.(0); arg.(1) |] + else arg + | Ifloattest(_, _) -> + (* Second argument can be on stack, first must be in register *) + if stackp arg.(0) + then [| self#makereg arg.(0); arg.(1) |] + else arg + | _ -> + (* The argument(s) can be either in register or on stack *) + arg + +end + +let fundecl f = + (new reload)#fundecl f diff --git a/asmcomp/amd64/scheduling.ml b/asmcomp/amd64/scheduling.ml new file mode 100644 index 00000000..972c47c2 --- /dev/null +++ b/asmcomp/amd64/scheduling.ml @@ -0,0 +1,20 @@ +(***********************************************************************) +(* *) +(* 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 Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: scheduling.ml,v 1.1 2003/06/30 08:28:44 xleroy Exp $ *) + +open Schedgen (* to create a dependency *) + +(* Scheduling is turned off because the processor schedules dynamically + much better than what we could do. *) + +let fundecl f = f diff --git a/asmcomp/amd64/selection.ml b/asmcomp/amd64/selection.ml new file mode 100644 index 00000000..1a12f5e8 --- /dev/null +++ b/asmcomp/amd64/selection.ml @@ -0,0 +1,229 @@ +(***********************************************************************) +(* *) +(* 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 Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: selection.ml,v 1.2 2003/06/30 11:29:26 xleroy Exp $ *) + +(* Instruction selection for the AMD64 *) + +open Misc +open Arch +open Proc +open Cmm +open Reg +open Mach + +(* Auxiliary for recognizing addressing modes *) + +type addressing_expr = + Asymbol of string + | Alinear of expression + | Aadd of expression * expression + | Ascale of expression * int + | Ascaledadd of expression * expression * int + +let rec select_addr exp = + match exp with + Cconst_symbol s -> + (Asymbol s, 0) + | Cop((Caddi | Cadda), [arg; Cconst_int m]) -> + let (a, n) = select_addr arg in (a, n + m) + | Cop((Csubi | Csuba), [arg; Cconst_int m]) -> + let (a, n) = select_addr arg in (a, n - m) + | Cop((Caddi | Cadda), [Cconst_int m; arg]) -> + let (a, n) = select_addr arg in (a, n + m) + | Cop(Clsl, [arg; Cconst_int(1|2|3 as shift)]) -> + begin match select_addr arg with + (Alinear e, n) -> (Ascale(e, 1 lsl shift), n lsl shift) + | _ -> (Alinear exp, 0) + end + | Cop(Cmuli, [arg; Cconst_int(2|4|8 as mult)]) -> + begin match select_addr arg with + (Alinear e, n) -> (Ascale(e, mult), n * mult) + | _ -> (Alinear exp, 0) + end + | Cop(Cmuli, [Cconst_int(2|4|8 as mult); arg]) -> + begin match select_addr arg with + (Alinear e, n) -> (Ascale(e, mult), n * mult) + | _ -> (Alinear exp, 0) + end + | Cop((Caddi | Cadda), [arg1; arg2]) -> + begin match (select_addr arg1, select_addr arg2) with + ((Alinear e1, n1), (Alinear e2, n2)) -> + (Aadd(e1, e2), n1 + n2) + | ((Alinear e1, n1), (Ascale(e2, scale), n2)) -> + (Ascaledadd(e1, e2, scale), n1 + n2) + | ((Ascale(e1, scale), n1), (Alinear e2, n2)) -> + (Ascaledadd(e2, e1, scale), n1 + n2) + | (_, (Ascale(e2, scale), n2)) -> + (Ascaledadd(arg1, e2, scale), n2) + | ((Ascale(e1, scale), n1), _) -> + (Ascaledadd(arg2, e1, scale), n1) + | _ -> + (Aadd(arg1, arg2), 0) + end + | arg -> + (Alinear arg, 0) + +(* Special constraints on operand and result registers *) + +exception Use_default + +let rax = phys_reg 0 +let rcx = phys_reg 5 +let rdx = phys_reg 4 + +let pseudoregs_for_operation op arg res = + match op with + (* Two-address binary operations: arg.(0) and res.(0) must be the same *) + Iintop(Iadd|Isub|Imul|Iand|Ior|Ixor) | Iaddf|Isubf|Imulf|Idivf -> + ([|res.(0); arg.(1)|], res) + (* One-address unary operations: arg.(0) and res.(0) must be the same *) + | Iintop_imm((Iadd|Isub|Imul|Iand|Ior|Ixor|Ilsl|Ilsr|Iasr), _) + | Iabsf | Inegf -> + (res, res) + | Ispecific(Ifloatarithmem(_,_)) -> + let arg' = Array.copy arg in + arg'.(0) <- res.(0); + (arg', res) + (* For shifts with variable shift count, second arg must be in rcx *) + | Iintop(Ilsl|Ilsr|Iasr) -> + ([|res.(0); rcx|], res) + (* For div and mod, first arg must be in rax, rdx is clobbered, + and result is in rax or rdx respectively. + Keep it simple, just force second argument in rcx. *) + | Iintop(Idiv) -> + ([| rax; rcx |], [| rax |]) + | Iintop(Imod) -> + ([| rax; rcx |], [| rdx |]) + (* For div and mod with immediate operand, arg must not be in rax. + Keep it simple, force it in rdx. *) + | Iintop_imm((Idiv|Imod), _) -> + ([| rdx |], [| rdx |]) + (* Other instructions are regular *) + | _ -> raise Use_default + +(* The selector class *) + +class selector = object (self) + +inherit Selectgen.selector_generic as super + +method is_immediate n = n <= 0x7FFFFFFF && n >= -0x80000000 + +method is_immediate_natint n = n <= 0x7FFFFFFFn && n >= -0x80000000n + +method select_addressing exp = + match select_addr exp with + (Asymbol s, d) -> + (Ibased(s, d), Ctuple []) + | (Alinear e, d) -> + (Iindexed d, e) + | (Aadd(e1, e2), d) -> + (Iindexed2 d, Ctuple[e1; e2]) + | (Ascale(e, scale), d) -> + (Iscaled(scale, d), e) + | (Ascaledadd(e1, e2, scale), d) -> + (Iindexed2scaled(scale, d), Ctuple[e1; e2]) + +method select_store addr exp = + match exp with + Cconst_int n when self#is_immediate n -> + (Ispecific(Istore_int(Nativeint.of_int n, addr)), Ctuple []) + | Cconst_natint n when self#is_immediate_natint n -> + (Ispecific(Istore_int(n, addr)), Ctuple []) + | Cconst_pointer n when self#is_immediate n -> + (Ispecific(Istore_int(Nativeint.of_int n, addr)), Ctuple []) + | Cconst_natpointer n when self#is_immediate_natint n -> + (Ispecific(Istore_int(n, addr)), Ctuple []) + | Cconst_symbol s -> + (Ispecific(Istore_symbol(s, addr)), Ctuple []) + | _ -> + super#select_store addr exp + +method select_operation op args = + match op with + (* Recognize the LEA instruction *) + Caddi | Cadda | Csubi | Csuba -> + begin match self#select_addressing (Cop(op, args)) with + (Iindexed d, _) -> super#select_operation op args + | (Iindexed2 0, _) -> super#select_operation op args + | (addr, arg) -> (Ispecific(Ilea addr), [arg]) + end + (* Recognize (x / cst) and (x % cst) only if cst is a power of 2. *) + | Cdivi -> + begin match args with + [arg1; Cconst_int n] when self#is_immediate n + && n = 1 lsl (Misc.log2 n) -> + (Iintop_imm(Idiv, n), [arg1]) + | _ -> (Iintop Idiv, args) + end + | Cmodi -> + begin match args with + [arg1; Cconst_int n] when self#is_immediate n + && n = 1 lsl (Misc.log2 n) -> + (Iintop_imm(Imod, n), [arg1]) + | _ -> (Iintop Imod, args) + end + (* Recognize float arithmetic with memory. *) + | Caddf -> + self#select_floatarith true Iaddf Ifloatadd args + | Csubf -> + self#select_floatarith false Isubf Ifloatsub args + | Cmulf -> + self#select_floatarith true Imulf Ifloatmul args + | Cdivf -> + self#select_floatarith false Idivf Ifloatdiv args + (* Recognize store instructions *) + | Cstore Word -> + begin match args with + [loc; Cop(Caddi, [Cop(Cload _, [loc']); Cconst_int n])] + when loc = loc' -> + let (addr, arg) = self#select_addressing loc in + (Ispecific(Ioffset_loc(n, addr)), [arg]) + | _ -> + super#select_operation op args + end + | _ -> super#select_operation op args + +(* Recognize float arithmetic with mem *) + +method select_floatarith commutative regular_op mem_op args = + match args with + [arg1; Cop(Cload (Double|Double_u), [loc2])] -> + let (addr, arg2) = self#select_addressing loc2 in + (Ispecific(Ifloatarithmem(mem_op, addr)), + [arg1; arg2]) + | [Cop(Cload (Double|Double_u), [loc1]); arg2] when commutative -> + let (addr, arg1) = self#select_addressing loc1 in + (Ispecific(Ifloatarithmem(mem_op, addr)), + [arg2; arg1]) + | [arg1; arg2] -> + (regular_op, [arg1; arg2]) + | _ -> + assert false + +(* Deal with register constraints *) + +method insert_op op rs rd = + try + let (rsrc, rdst) = pseudoregs_for_operation op rs rd in + self#insert_moves rs rsrc; + self#insert (Iop op) rsrc rdst; + self#insert_moves rdst rd; + rd + with Use_default -> + super#insert_op op rs rd + +end + +let fundecl f = (new selector)#emit_fundecl f + diff --git a/asmcomp/arm/arch.ml b/asmcomp/arm/arch.ml new file mode 100644 index 00000000..a2b0027e --- /dev/null +++ b/asmcomp/arm/arch.ml @@ -0,0 +1,86 @@ +(***********************************************************************) +(* *) +(* 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 Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: arch.ml,v 1.9 2002/11/29 15:03:36 xleroy Exp $ *) + +(* Specific operations for the ARM processor *) + +open Misc +open Format + +(* Machine-specific command-line options *) + +let command_line_options = [] + +(* Addressing modes *) + +type addressing_mode = + Iindexed of int (* reg + displ *) + +(* We do not support the reg + shifted reg addressing mode, because + what we really need is reg + shifted reg + displ, + and this is decomposed in two instructions (reg + shifted reg -> tmp, + then addressing tmp + displ). *) + +(* Specific operations *) + +type specific_operation = + Ishiftarith of arith_operation * int + | Ishiftcheckbound of int + | Irevsubimm of int + +and arith_operation = + Ishiftadd + | Ishiftsub + | Ishiftsubrev + +(* Sizes, endianness *) + +let big_endian = false + +let size_addr = 4 +let size_int = 4 +let size_float = 8 + +(* Operations on addressing modes *) + +let identity_addressing = Iindexed 0 + +let offset_addressing (Iindexed n) delta = Iindexed(n + delta) + +let num_args_addressing (Iindexed n) = 1 + +(* Printing operations and addressing modes *) + +let print_addressing printreg addr ppf arg = + match addr with + | Iindexed n -> + printreg ppf arg.(0); + if n <> 0 then fprintf ppf " + %i" n + +let print_specific_operation printreg op ppf arg = + match op with + | Ishiftarith(op, shift) -> + let op_name = function + | Ishiftadd -> "+" + | Ishiftsub -> "-" + | Ishiftsubrev -> "-rev" in + let shift_mark = + if shift >= 0 + then sprintf "<< %i" shift + else sprintf ">> %i" (-shift) in + fprintf ppf "%a %s %a %s" + printreg arg.(0) (op_name op) printreg arg.(1) shift_mark + | Ishiftcheckbound n -> + fprintf ppf "check %a >> %i > %a" printreg arg.(0) n printreg arg.(1) + | Irevsubimm n -> + fprintf ppf "%i %s %a" n "-" printreg arg.(0) diff --git a/asmcomp/arm/emit.mlp b/asmcomp/arm/emit.mlp new file mode 100644 index 00000000..0670610a --- /dev/null +++ b/asmcomp/arm/emit.mlp @@ -0,0 +1,678 @@ +(***********************************************************************) +(* *) +(* 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 Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: emit.mlp,v 1.15 2003/04/25 12:26:59 xleroy Exp $ *) + +(* Emission of ARM assembly code *) + +open Location +open Misc +open Cmm +open Arch +open Proc +open Reg +open Mach +open Linearize +open Emitaux + +(* Tradeoff between code size and code speed *) + +let fastcode_flag = ref true + +(* Output a label *) + +let emit_label lbl = + emit_string ".L"; emit_int lbl + +(* Output a symbol *) + +let emit_symbol s = + Emitaux.emit_symbol '$' s + +(* Output a pseudo-register *) + +let emit_reg r = + match r.loc with + Reg r -> emit_string (register_name r) + | _ -> fatal_error "Emit_arm.emit_reg" + +(* Output the next register after the given pseudo-register *) + +let emit_next_reg r = + match r.loc with + Reg r -> emit_string (register_name(r + 1)) + | _ -> fatal_error "Emit_arm.emit_next_reg" + +(* Layout of the stack frame *) + +let stack_offset = ref 0 + +let frame_size () = + !stack_offset + + 4 * num_stack_slots.(0) + 8 * num_stack_slots.(1) + + (if !contains_calls then 4 else 0) + +let slot_offset loc cl = + match loc with + Incoming n -> frame_size() + n + | Local n -> + if cl = 0 + then !stack_offset + num_stack_slots.(1) * 8 + n * 4 + else !stack_offset + n * 8 + | Outgoing n -> n + +(* Output a stack reference *) + +let emit_stack r = + match r.loc with + Stack s -> + let ofs = slot_offset s (register_class r) in `[sp, #{emit_int ofs}]` + | _ -> fatal_error "Emit_arm.emit_stack" + +(* Output an addressing mode *) + +let emit_addressing addr r n = + match addr with + Iindexed ofs -> + `[{emit_reg r.(n)}, #{emit_int ofs}]` + +(* Record live pointers at call points *) + +type frame_descr = + { fd_lbl: int; (* Return address *) + fd_frame_size: int; (* Size of stack frame *) + fd_live_offset: int list } (* Offsets/regs of live addresses *) + +let frame_descriptors = ref([] : frame_descr list) + +let record_frame live = + let lbl = new_label() in + let live_offset = ref [] in + Reg.Set.iter + (function + {typ = Addr; loc = Reg r} -> + live_offset := (r lsl 1) + 1 :: !live_offset + | {typ = Addr; loc = Stack s} as reg -> + live_offset := slot_offset s (register_class reg) :: !live_offset + | _ -> ()) + live; + frame_descriptors := + { fd_lbl = lbl; + fd_frame_size = frame_size(); + fd_live_offset = !live_offset } :: !frame_descriptors; + `{emit_label lbl}:` + +let emit_frame fd = + ` .word {emit_label fd.fd_lbl} + 4\n`; + ` .short {emit_int fd.fd_frame_size}\n`; + ` .short {emit_int (List.length fd.fd_live_offset)}\n`; + List.iter + (fun n -> + ` .short {emit_int n}\n`) + fd.fd_live_offset; + ` .align 2\n` + +(* Names of various instructions *) + +let name_for_comparison = function + Isigned Ceq -> "eq" | Isigned Cne -> "ne" | Isigned Cle -> "le" + | Isigned Cge -> "ge" | Isigned Clt -> "lt" | Isigned Cgt -> "gt" + | Iunsigned Ceq -> "eq" | Iunsigned Cne -> "ne" | Iunsigned Cle -> "ls" + | Iunsigned Cge -> "cs" | Iunsigned Clt -> "cc" | Iunsigned Cgt -> "hi" + +let name_for_float_comparison cmp neg = + match cmp with + Ceq -> if neg then "ne" else "eq" + | Cne -> if neg then "eq" else "ne" + | Cle -> if neg then "hi" else "ls" + | Cge -> if neg then "lt" else "ge" + | Clt -> if neg then "pl" else "mi" + | Cgt -> if neg then "le" else "gt" + +let name_for_int_operation = function + Iadd -> "add" + | Isub -> "sub" + | Imul -> "mul" + | Iand -> "and" + | Ior -> "orr" + | Ixor -> "eor" + | _ -> assert false + +let name_for_shift_operation = function + Ilsl -> "lsl" + | Ilsr -> "lsr" + | Iasr -> "asr" + | _ -> assert false + +let name_for_shift_int_operation = function + Ishiftadd -> "add" + | Ishiftsub -> "sub" + | Ishiftsubrev -> "rsb" + +let name_for_float_operation = function + Inegf -> "mnfd" + | Iabsf -> "absd" + | Iaddf -> "adfd" + | Isubf -> "sufd" + | Imulf -> "mufd" + | Idivf -> "dvfd" + | Ifloatofint -> "fltd" + | Iintoffloat -> "fixz" + | _ -> assert false + +(* Recognize immediate operands *) + +(* Immediate operands are 8-bit immediate values, zero-extended, and rotated + right by 0, 2, 4, ... 30 bits. + We check only with 8-bit values shifted left 0 to 24 bits. *) + +let rec is_immed n shift = + shift <= 24 && + (Nativeint.logand n (Nativeint.shift_left (Nativeint.of_int 0xFF) shift) = n + || is_immed n (shift + 2)) + +let is_immediate n = is_immed n 0 + +(* General functional to decompose a non-immediate integer constant + into 8-bit chunks shifted left 0 ... 24 bits *) + +let decompose_intconst n fn = + let i = ref n in + let shift = ref 0 in + let ninstr = ref 0 in + while !i <> 0n do + if Nativeint.to_int (Nativeint.shift_right !i !shift) land 3 = 0 then + shift := !shift + 2 + else begin + let mask = Nativeint.shift_left 0xFFn !shift in + let bits = Nativeint.logand !i mask in + fn bits; + shift := !shift + 8; + i := Nativeint.sub !i bits; + incr ninstr + end + done; + !ninstr + +(* Emit a non-immediate integer constant *) + +let emit_complex_intconst r n = + let first = ref true in + decompose_intconst n + (fun bits -> + if !first + then ` mov {emit_reg r}, #{emit_nativeint bits} @ {emit_nativeint n}\n` + else ` add {emit_reg r}, {emit_reg r}, #{emit_nativeint bits}\n`; + first := false) + +(* Adjust sp (up or down) by the given byte amount *) + +let emit_stack_adjustment instr n = + if n <= 0 then 0 else + decompose_intconst (Nativeint.of_int n) + (fun bits -> + ` {emit_string instr} sp, sp, #{emit_nativeint bits}\n`) + +(* Adjust alloc_ptr down by the given byte amount *) + +let emit_alloc_decrement n = + decompose_intconst (Nativeint.of_int n) + (fun bits -> + ` sub alloc_ptr, alloc_ptr, #{emit_nativeint bits}\n`) + +(* Name of current function *) +let function_name = ref "" +(* Entry point for tail recursive calls *) +let tailrec_entry_point = ref 0 +(* Table of symbols referenced *) +let symbol_constants = (Hashtbl.create 11 : (string, int) Hashtbl.t) +(* Table of floating-point literals *) +let float_constants = (Hashtbl.create 11 : (string, int) Hashtbl.t) +(* Total space (in word) occupied by pending literals *) +let num_literals = ref 0 +(* True if we've at least one pending float literal *) +let pending_float = ref false + +(* Label a symbol or float constant *) +let label_constant tbl s size = + try + Hashtbl.find tbl s + with Not_found -> + let lbl = new_label() in + Hashtbl.add tbl s lbl; + num_literals := !num_literals + size; + lbl + +(* Emit all pending constants *) + +let emit_constants () = + Hashtbl.iter + (fun s lbl -> + `{emit_label lbl}: .word {emit_symbol s}\n`) + symbol_constants; + Hashtbl.iter + (fun s lbl -> + `{emit_label lbl}: .double {emit_string s}\n`) + float_constants; + Hashtbl.clear symbol_constants; + Hashtbl.clear float_constants; + num_literals := 0; + pending_float := false + +(* Output the assembly code for an instruction *) + +let emit_instr i = + match i.desc with + Lend -> 0 + | Lop(Imove | Ispill | Ireload) -> + let src = i.arg.(0) and dst = i.res.(0) in + if src.loc = dst.loc then 0 else begin + match (src, dst) with + {loc = Reg rs; typ = Int|Addr}, {loc = Reg rd; typ = Int|Addr} -> + ` mov {emit_reg dst}, {emit_reg src}\n`; 1 + | {loc = Reg rs; typ = Float}, {loc = Reg rd; typ = Float} -> + ` mvfd {emit_reg dst}, {emit_reg src}\n`; 1 + | {loc = Reg rs; typ = Float}, {loc = Reg rd; typ = Int|Addr} -> + ` stfd {emit_reg src}, [sp, #-8]!\n`; + ` ldmfd sp!, \{{emit_reg dst}, {emit_next_reg dst}}\n`; 2 + | {loc = Reg rs; typ = Int|Addr}, {loc = Stack sd} -> + ` str {emit_reg src}, {emit_stack dst}\n`; 1 + | {loc = Reg rs; typ = Float}, {loc = Stack sd} -> + ` stfd {emit_reg src}, {emit_stack dst}\n`; 1 + | {loc = Stack ss; typ = Int|Addr}, {loc = Reg rd} -> + ` ldr {emit_reg dst}, {emit_stack src}\n`; 1 + | {loc = Stack ss; typ = Float}, {loc = Reg rd} -> + ` ldfd {emit_reg dst}, {emit_stack src}\n`; 1 + | _ -> + assert false + end + | Lop(Iconst_int n) -> + let r = i.res.(0) in + let nr = Nativeint.lognot n in + if is_immediate n then begin + ` mov {emit_reg r}, #{emit_nativeint n}\n`; 1 + end else if is_immediate nr then begin + ` mvn {emit_reg r}, #{emit_nativeint nr}\n`; 1 + end else + emit_complex_intconst r n + | Lop(Iconst_float s) -> + if float_of_string s = 0.0 then + ` mvfd {emit_reg i.res.(0)}, #0.0\n` + else begin + let lbl = label_constant float_constants s 2 in + pending_float := true; + ` ldfd {emit_reg i.res.(0)}, {emit_label lbl} @ {emit_string s}\n` + end; + 1 + | Lop(Iconst_symbol s) -> + let lbl = label_constant symbol_constants s 1 in + ` ldr {emit_reg i.res.(0)}, {emit_label lbl} @ {emit_symbol s}\n`; 1 + | Lop(Icall_ind) -> + ` mov lr, pc\n`; + `{record_frame i.live} mov pc, {emit_reg i.arg.(0)}\n`; 2 + | Lop(Icall_imm s) -> + `{record_frame i.live} bl {emit_symbol s}\n`; 1 + | Lop(Itailcall_ind) -> + let n = frame_size() in + if !contains_calls then + ` ldr lr, [sp, #{emit_int (n-4)}]\n`; + ignore (emit_stack_adjustment "add" n); + ` mov pc, {emit_reg i.arg.(0)}\n`; 3 + | Lop(Itailcall_imm s) -> + if s = !function_name then begin + ` b {emit_label !tailrec_entry_point}\n`; 1 + end else begin + let n = frame_size() in + if !contains_calls then + ` ldr lr, [sp, #{emit_int (n-4)}]\n`; + ignore (emit_stack_adjustment "add" n); + ` b {emit_symbol s}\n`; 3 + end + | Lop(Iextcall(s, alloc)) -> + if alloc then begin + let lbl = label_constant symbol_constants s 1 in + ` ldr r10, {emit_label lbl} @ {emit_symbol s}\n`; + `{record_frame i.live} bl caml_c_call\n`; 2 + end else begin + ` bl {emit_symbol s}\n`; 1 + end + | Lop(Istackoffset n) -> + let ninstr = + if n >= 0 + then emit_stack_adjustment "sub" n + else emit_stack_adjustment "add" (-n) in + stack_offset := !stack_offset + n; + ninstr + | Lop(Iload(Single, addr)) -> + let r = i.res.(0) in + ` ldfs {emit_reg r}, {emit_addressing addr i.arg 0}\n`; + ` mvfd {emit_reg r}, {emit_reg r}\n`; + 2 + | Lop(Iload(size, addr)) -> + let r = i.res.(0) in + let instr = + match size with + Byte_unsigned -> "ldrb" + | Byte_signed -> "ldrsb" + | Sixteen_unsigned -> "ldrh" + | Sixteen_signed -> "ldrsh" + | Double | Double_u -> "ldfd" + | _ (* Word | Thirtytwo_signed | Thirtytwo_unsigned *) -> "ldr" in + ` {emit_string instr} {emit_reg r}, {emit_addressing addr i.arg 0}\n`; + 1 + | Lop(Istore(Single, addr)) -> + let r = i.arg.(0) in + ` mvfs f7, {emit_reg r}\n`; + ` stfs f7, {emit_addressing addr i.arg 1}\n`; + 2 + | Lop(Istore(size, addr)) -> + let r = i.arg.(0) in + let instr = + match size with + Byte_unsigned | Byte_signed -> "strb" + | Sixteen_unsigned | Sixteen_signed -> "strh" + | Double | Double_u -> "stfd" + | _ (* Word | Thirtytwo_signed | Thirtytwo_unsigned *) -> "str" in + ` {emit_string instr} {emit_reg r}, {emit_addressing addr i.arg 1}\n`; + 1 + | Lop(Ialloc n) -> + if !fastcode_flag then begin + ` ldr r10, [alloc_limit, #0]\n`; + let ni = emit_alloc_decrement n in + ` cmp alloc_ptr, r10\n`; + `{record_frame i.live} blcc caml_call_gc\n`; + ` add {emit_reg i.res.(0)}, alloc_ptr, #4\n`; + 4 + ni + end else if n = 8 || n = 12 || n = 16 then begin + `{record_frame i.live} bl caml_alloc{emit_int ((n-4)/4)}\n`; + ` add {emit_reg i.res.(0)}, alloc_ptr, #4\n`; 2 + end else begin + let nn = Nativeint.of_int n in + let ni = + if is_immediate nn then begin + ` mov r10, #{emit_int n}\n`; 1 + end else + emit_complex_intconst (phys_reg 8 (*r10*)) nn in + `{record_frame i.live} bl caml_alloc\n`; + ` add {emit_reg i.res.(0)}, alloc_ptr, #4\n`; + 2 + ni + end + | Lop(Iintop(Ilsl | Ilsr | Iasr as op)) -> + let shift = name_for_shift_operation op in + ` mov {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_string shift} {emit_reg i.arg.(1)}\n`; 1 + | Lop(Iintop(Icomp cmp)) -> + let comp = name_for_comparison cmp in + ` cmp {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; + ` mov {emit_reg i.res.(0)}, #0\n`; + ` mov{emit_string comp} {emit_reg i.res.(0)}, #1\n`; 3 + | Lop(Iintop(Icheckbound)) -> + ` cmp {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; + ` blls caml_array_bound_error\n`; 2 + | Lop(Iintop op) -> + let instr = name_for_int_operation op in + ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; 1 + | Lop(Iintop_imm(Idiv, n)) -> (* n is a power of 2 *) + let l = Misc.log2 n in + let r = i.res.(0) in + ` movs {emit_reg r}, {emit_reg i.arg.(0)}\n`; + if n <= 256 then + ` addlt {emit_reg r}, {emit_reg r}, #{emit_int (n-1)}\n` + else begin + ` addlt {emit_reg r}, {emit_reg r}, #{emit_int n}\n`; + ` sublt {emit_reg r}, {emit_reg r}, #1\n` + end; + ` mov {emit_reg r}, {emit_reg r}, asr #{emit_int l}\n`; 4 + | Lop(Iintop_imm(Imod, n)) -> (* n is a power of 2 *) + let l = Misc.log2 n in + let a = i.arg.(0) in + let r = i.res.(0) in + let lbl = new_label() in + ` cmp {emit_reg a}, #0\n`; + ` mov {emit_reg r}, {emit_reg a}, lsl #{emit_int (32-l)}\n`; + ` mov {emit_reg r}, {emit_reg r}, lsr #{emit_int (32-l)}\n`; + ` bpl {emit_label lbl}\n`; + ` cmp {emit_reg r}, #0\n`; + ` subne {emit_reg r}, {emit_reg r}, #{emit_int n}\n`; + `{emit_label lbl}:\n`; 6 + | Lop(Iintop_imm((Ilsl | Ilsr | Iasr as op), n)) -> + let shift = name_for_shift_operation op in + ` mov {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_string shift} #{emit_int n}\n`; 1 + | Lop(Iintop_imm(Icomp cmp, n)) -> + let comp = name_for_comparison cmp in + ` cmp {emit_reg i.arg.(0)}, #{emit_int n}\n`; + ` mov {emit_reg i.res.(0)}, #0\n`; + ` mov{emit_string comp} {emit_reg i.res.(0)}, #1\n`; 3 + | Lop(Iintop_imm(Icheckbound, n)) -> + ` cmp {emit_reg i.arg.(0)}, #{emit_int n}\n`; + ` blls caml_array_bound_error\n`; 2 + | Lop(Iintop_imm(op, n)) -> + let instr = name_for_int_operation op in + ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, #{emit_int n}\n`; 1 + | Lop(Inegf | Iabsf | Ifloatofint | Iintoffloat as op) -> + let instr = name_for_float_operation op in + ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}\n`; 1 + | Lop(Iaddf | Isubf | Imulf | Idivf as op) -> + let instr = name_for_float_operation op in + ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; 1 + | Lop(Ispecific(Ishiftarith(op, shift))) -> + let instr = name_for_shift_int_operation op in + ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}`; + if shift >= 0 + then `, lsl #{emit_int shift}\n` + else `, asr #{emit_int (-shift)}\n`; + 1 + | Lop(Ispecific(Ishiftcheckbound shift)) -> + ` cmp {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}, lsr #{emit_int shift}\n`; + ` blcs caml_array_bound_error\n`; 2 + | Lop(Ispecific(Irevsubimm n)) -> + ` rsb {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, #{emit_int n}\n`; 1 + | Lreloadretaddr -> + let n = frame_size() in + ` ldr lr, [sp, #{emit_int(n-4)}]\n`; 1 + | Lreturn -> + let n = frame_size() in + ignore(emit_stack_adjustment "add" n); + ` mov pc, lr\n`; 2 + | Llabel lbl -> + `{emit_label lbl}:\n`; 0 + | Lbranch lbl -> + ` b {emit_label lbl}\n`; 1 + | Lcondbranch(tst, lbl) -> + begin match tst with + Itruetest -> + ` cmp {emit_reg i.arg.(0)}, #0\n`; + ` bne {emit_label lbl}\n` + | Ifalsetest -> + ` cmp {emit_reg i.arg.(0)}, #0\n`; + ` beq {emit_label lbl}\n` + | Iinttest cmp -> + ` cmp {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; + let comp = name_for_comparison cmp in + ` b{emit_string comp} {emit_label lbl}\n` + | Iinttest_imm(cmp, n) -> + ` cmp {emit_reg i.arg.(0)}, #{emit_int n}\n`; + let comp = name_for_comparison cmp in + ` b{emit_string comp} {emit_label lbl}\n` + | Ifloattest(cmp, neg) -> + begin match cmp with + Ceq | Cne -> + ` cmf {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n` + | _ -> + ` cmfe {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n` + end; + let comp = name_for_float_comparison cmp neg in + ` b{emit_string comp} {emit_label lbl}\n` + | Ioddtest -> + ` tst {emit_reg i.arg.(0)}, #1\n`; + ` bne {emit_label lbl}\n` + | Ieventest -> + ` tst {emit_reg i.arg.(0)}, #1\n`; + ` beq {emit_label lbl}\n` + end; + 2 + | Lcondbranch3(lbl0, lbl1, lbl2) -> + ` cmp {emit_reg i.arg.(0)}, #1\n`; + begin match lbl0 with + None -> () + | Some lbl -> ` blt {emit_label lbl}\n` + end; + begin match lbl1 with + None -> () + | Some lbl -> ` beq {emit_label lbl}\n` + end; + begin match lbl2 with + None -> () + | Some lbl -> ` bgt {emit_label lbl}\n` + end; + 4 + | Lswitch jumptbl -> + ` ldr pc, [pc, {emit_reg i.arg.(0)}, lsl #2]\n`; + ` mov r0, r0\n`; (* nop *) + for i = 0 to Array.length jumptbl - 1 do + ` .word {emit_label jumptbl.(i)}\n` + done; + 2 + Array.length jumptbl + | Lsetuptrap lbl -> + ` bl {emit_label lbl}\n`; 1 + | Lpushtrap -> + stack_offset := !stack_offset + 8; + ` stmfd sp!, \{trap_ptr, lr}\n`; + ` mov trap_ptr, sp\n`; 2 + | Lpoptrap -> + ` ldmfd sp!, \{trap_ptr, lr}\n`; + stack_offset := !stack_offset - 8; 1 + | Lraise -> + ` mov sp, trap_ptr\n`; + ` ldmfd sp!, \{trap_ptr, pc}\n`; 2 + +(* Emission of an instruction sequence *) + +let no_fallthrough = function + Lop(Itailcall_ind | Itailcall_imm _) -> true + | Lreturn -> true + | Lbranch _ -> true + | Lswitch _ -> true + | Lraise -> true + | _ -> false + +let rec emit_all ninstr i = + if i.desc = Lend then () else begin + let n = emit_instr i in + let ninstr' = ninstr + n in + let limit = (if !pending_float then 127 else 511) - !num_literals in + if ninstr' >= limit - 32 && no_fallthrough i.desc then begin + emit_constants(); + emit_all 0 i.next + end else + if ninstr' >= limit then begin + let lbl = new_label() in + ` b {emit_label lbl}\n`; + emit_constants(); + `{emit_label lbl}:\n`; + emit_all 0 i.next + end else + emit_all ninstr' i.next + end + +(* Emission of a function declaration *) + +let fundecl fundecl = + function_name := fundecl.fun_name; + fastcode_flag := fundecl.fun_fast; + tailrec_entry_point := new_label(); + stack_offset := 0; + Hashtbl.clear symbol_constants; + Hashtbl.clear float_constants; + ` .text\n`; + ` .align 0\n`; + ` .global {emit_symbol fundecl.fun_name}\n`; + `{emit_symbol fundecl.fun_name}:\n`; + let n = frame_size() in + ignore(emit_stack_adjustment "sub" n); + if !contains_calls then + ` str lr, [sp, #{emit_int(n - 4)}]\n`; + `{emit_label !tailrec_entry_point}:\n`; + emit_all 0 fundecl.fun_body; + emit_constants() + +(* Emission of data *) + +let emit_item = function + Cglobal_symbol s -> + ` .global {emit_symbol s}\n`; + | Cdefine_symbol s -> + `{emit_symbol s}:\n` + | Cdefine_label lbl -> + `{emit_label (10000 + lbl)}:\n` + | Cint8 n -> + ` .byte {emit_int n}\n` + | Cint16 n -> + ` .short {emit_int n}\n` + | Cint32 n -> + ` .word {emit_nativeint n}\n` + | Cint n -> + ` .word {emit_nativeint n}\n` + | Csingle f -> + ` .float {emit_string f}\n` + | Cdouble f -> + ` .align 0\n`; + ` .double {emit_string f}\n` + | Csymbol_address s -> + ` .word {emit_symbol s}\n` + | Clabel_address lbl -> + ` .word {emit_label (10000 + lbl)}\n` + | Cstring s -> + emit_string_directive " .ascii " s + | Cskip n -> + if n > 0 then ` .space {emit_int n}\n` + | Calign n -> + ` .align {emit_int(Misc.log2 n)}\n` + +let data l = + ` .data\n`; + List.iter emit_item l + +(* Beginning / end of an assembly file *) + +let begin_assembly() = + `trap_ptr .req r11\n`; + `alloc_ptr .req r8\n`; + `alloc_limit .req r9\n`; + `sp .req r13\n`; + `lr .req r14\n`; + `pc .req r15\n`; + let lbl_begin = Compilenv.current_unit_name() ^ "__data_begin" in + ` .data\n`; + ` .global {emit_symbol lbl_begin}\n`; + `{emit_symbol lbl_begin}:\n`; + let lbl_begin = Compilenv.current_unit_name() ^ "__code_begin" in + ` .text\n`; + ` .global {emit_symbol lbl_begin}\n`; + `{emit_symbol lbl_begin}:\n` + +let end_assembly () = + let lbl_end = Compilenv.current_unit_name() ^ "__code_end" in + ` .text\n`; + ` .global {emit_symbol lbl_end}\n`; + `{emit_symbol lbl_end}:\n`; + let lbl_end = Compilenv.current_unit_name() ^ "__data_end" in + ` .data\n`; + ` .global {emit_symbol lbl_end}\n`; + `{emit_symbol lbl_end}:\n`; + ` .word 0\n`; + let lbl = Compilenv.current_unit_name() ^ "__frametable" in + ` .data\n`; + ` .global {emit_symbol lbl}\n`; + `{emit_symbol lbl}:\n`; + ` .word {emit_int (List.length !frame_descriptors)}\n`; + List.iter emit_frame !frame_descriptors; + frame_descriptors := [] diff --git a/asmcomp/arm/proc.ml b/asmcomp/arm/proc.ml new file mode 100644 index 00000000..da1719a1 --- /dev/null +++ b/asmcomp/arm/proc.ml @@ -0,0 +1,196 @@ +(***********************************************************************) +(* *) +(* 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 Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: proc.ml,v 1.8 2002/07/22 16:37:47 doligez Exp $ *) + +(* Description of the ARM processor *) + +open Misc +open Cmm +open Reg +open Arch +open Mach + +(* Instruction selection *) + +let word_addressed = false + +(* Registers available for register allocation *) + +(* Register map: + r0 - r7 general purpose (r4 - r7 preserved by C) + r8 allocation pointer (preserved by C) + r9 allocation limit (preserved by C) + r10 general purpose + r11 trap pointer (preserved by C) + r12 general purpose + r13 stack pointer + r14 return address + r15 program counter + + f0 - f6 general purpose (f4 - f6 preserved by C) + f7 temporary +*) + +let int_reg_name = [| + "r0"; "r1"; "r2"; "r3"; "r4"; "r5"; "r6"; "r7"; "r10"; "r12" +|] + +let float_reg_name = [| + "f0"; "f1"; "f2"; "f3"; "f4"; "f5"; "f6" +|] + +let num_register_classes = 2 + +let register_class r = + match r.typ with + Int -> 0 + | Addr -> 0 + | Float -> 1 + +let num_available_registers = [| 10; 7 |] + +let first_available_register = [| 0; 100 |] + +let register_name r = + if r < 100 then int_reg_name.(r) else float_reg_name.(r - 100) + +let rotate_registers = true + +(* Representation of hard registers by pseudo-registers *) + +let hard_int_reg = + let v = Array.create 10 Reg.dummy in + for i = 0 to 9 do v.(i) <- Reg.at_location Int (Reg i) done; + v + +let hard_float_reg = + let v = Array.create 7 Reg.dummy in + for i = 0 to 6 do v.(i) <- Reg.at_location Float (Reg(100 + i)) done; + v + +let all_phys_regs = + Array.append hard_int_reg hard_float_reg + +let phys_reg n = + if n < 100 then hard_int_reg.(n) else hard_float_reg.(n - 100) + +let stack_slot slot ty = + Reg.at_location ty (Stack slot) + +(* Calling conventions *) + +let calling_conventions first_int last_int first_float last_float + make_stack arg = + let loc = Array.create (Array.length arg) Reg.dummy in + let int = ref first_int in + let float = ref first_float in + let ofs = ref 0 in + for i = 0 to Array.length arg - 1 do + match arg.(i).typ with + Int | Addr as ty -> + if !int <= last_int then begin + loc.(i) <- phys_reg !int; + incr int + end else begin + loc.(i) <- stack_slot (make_stack !ofs) ty; + ofs := !ofs + size_int + end + | Float -> + if !float <= last_float then begin + loc.(i) <- phys_reg !float; + incr float + end else begin + loc.(i) <- stack_slot (make_stack !ofs) Float; + ofs := !ofs + size_float + end + done; + (loc, !ofs) + +let incoming ofs = Incoming ofs +let outgoing ofs = Outgoing ofs +let not_supported ofs = fatal_error "Proc.loc_results: cannot call" + +let loc_arguments arg = + calling_conventions 0 7 100 103 outgoing arg +let loc_parameters arg = + let (loc, ofs) = calling_conventions 0 7 100 103 incoming arg in loc +let loc_results res = + let (loc, ofs) = calling_conventions 0 7 100 103 not_supported res in loc + +(* Calling conventions for C are as for Caml, except that float arguments + are passed in pairs of integer registers. *) + +let loc_external_arguments arg = + let loc = Array.create (Array.length arg) Reg.dummy in + let reg = ref 0 in + let ofs = ref 0 in + for i = 0 to Array.length arg - 1 do + match arg.(i).typ with + Int | Addr as ty -> + if !reg <= 3 then begin + loc.(i) <- phys_reg !reg; + incr reg + end else begin + loc.(i) <- stack_slot (outgoing !ofs) ty; + ofs := !ofs + size_int + end + | Float -> + if !reg <= 2 then begin + loc.(i) <- phys_reg !reg; + reg := !reg + 2 + end else begin + loc.(i) <- stack_slot (outgoing !ofs) Float; + ofs := !ofs + size_float + end + done; + (loc, !ofs) + +let loc_external_results res = + let (loc, ofs) = calling_conventions 0 0 100 100 not_supported res in loc + +let loc_exn_bucket = phys_reg 0 + +(* Registers destroyed by operations *) + +let destroyed_at_c_call = (* r4-r9, f4-f6 preserved *) + Array.of_list(List.map phys_reg [0;1;2;3;8;9; 100;101;102;103]) + +let destroyed_at_oper = function + Iop(Icall_ind | Icall_imm _ | Iextcall(_, true)) -> all_phys_regs + | Iop(Iextcall(_, false)) -> destroyed_at_c_call + | Iop(Ialloc(_)) -> [|phys_reg 8|] (* r10 destroyed *) + | _ -> [||] + +let destroyed_at_raise = all_phys_regs + +(* Maximal register pressure *) + +let safe_register_pressure = function + Iextcall(_, _) -> 4 + | _ -> 7 +let max_register_pressure = function + Iextcall(_, _) -> [| 4; 4 |] + | _ -> [| 10; 7 |] + +(* Layout of the stack *) + +let num_stack_slots = [| 0; 0 |] +let contains_calls = ref false + +(* Calling the assembler *) + +let assemble_file infile outfile = + Sys.command ("as -o " ^ Filename.quote outfile ^ " " ^ Filename.quote infile) + +open Clflags;; +open Config;; diff --git a/asmcomp/arm/reload.ml b/asmcomp/arm/reload.ml new file mode 100644 index 00000000..0ec090d1 --- /dev/null +++ b/asmcomp/arm/reload.ml @@ -0,0 +1,18 @@ +(***********************************************************************) +(* *) +(* 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 Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: reload.ml,v 1.4 1999/11/17 18:56:41 xleroy Exp $ *) + +(* Reloading for the ARM *) + +let fundecl f = + (new Reloadgen.reload_generic)#fundecl f diff --git a/asmcomp/arm/scheduling.ml b/asmcomp/arm/scheduling.ml new file mode 100644 index 00000000..533a2175 --- /dev/null +++ b/asmcomp/arm/scheduling.ml @@ -0,0 +1,53 @@ +(***********************************************************************) +(* *) +(* 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: scheduling.ml,v 1.4 1999/11/17 18:56:41 xleroy Exp $ *) + +open Mach + +(* Instruction scheduling for the Sparc *) + +class scheduler = object + +inherit Schedgen.scheduler_generic + +(* Scheduling -- based roughly on the Strong ARM *) + +method oper_latency = function + Ireload -> 2 + | Iload(_, _) -> 2 + | Iconst_symbol _ -> 2 (* turned into a load *) + | Iconst_float _ -> 2 (* turned into a load *) + | Iintop(Imul) -> 3 + | Iintop_imm(Imul, _) -> 3 + (* No data available for floatops, let's make educated guesses *) + | Iaddf -> 3 + | Isubf -> 3 + | Imulf -> 5 + | Idivf -> 15 + | _ -> 1 + +(* Issue cycles. Rough approximations *) + +method oper_issue_cycles = function + Ialloc _ -> 4 + | Iintop(Icomp _) -> 3 + | Iintop(Icheckbound) -> 2 + | Iintop_imm(Idiv, _) -> 4 + | Iintop_imm(Imod, _) -> 6 + | Iintop_imm(Icomp _, _) -> 3 + | Iintop_imm(Icheckbound, _) -> 2 + | _ -> 1 + +end + +let fundecl f = (new scheduler)#schedule_fundecl f diff --git a/asmcomp/arm/selection.ml b/asmcomp/arm/selection.ml new file mode 100644 index 00000000..ac586f9d --- /dev/null +++ b/asmcomp/arm/selection.ml @@ -0,0 +1,132 @@ +(***********************************************************************) +(* *) +(* 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 Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: selection.ml,v 1.6 2001/03/30 12:22:32 xleroy Exp $ *) + +(* Instruction selection for the ARM processor *) + +open Misc +open Cmm +open Reg +open Arch +open Mach + +(* Immediate operands are 8-bit immediate values, zero-extended, and rotated + right by 0, 2, 4, ... 30 bits. + To avoid problems with Caml's 31-bit arithmetic, + we check only with 8-bit values shifted left 0 to 22 bits. *) + +let rec is_immed n shift = + if shift > 22 then false + else if n land (0xFF lsl shift) = n then true + else is_immed n (shift + 2) + +(* We have 12-bit + sign byte offsets for word accesses, + 8-bit + sign word offsets for float accesses, + and 8-bit + sign byte offsets for bytes and shorts. + Use lowest common denominator. *) + +let is_offset n = n < 256 && n > -256 + +let is_intconst = function Cconst_int n -> true | _ -> false + +(* Instruction selection *) +class selector = object(self) + +inherit Selectgen.selector_generic as super + +method is_immediate n = + n land 0xFF = n || is_immed n 2 + +method select_addressing = function + Cop(Cadda, [arg; Cconst_int n]) when is_offset n -> + (Iindexed n, arg) + | Cop(Cadda, [arg1; Cop(Caddi, [arg2; Cconst_int n])]) when is_offset n -> + (Iindexed n, Cop(Cadda, [arg1; arg2])) + | arg -> + (Iindexed 0, arg) + +method select_shift_arith op shiftop shiftrevop args = + match args with + [arg1; Cop(Clsl, [arg2; Cconst_int n])] + when n > 0 && n < 32 && not(is_intconst arg2) -> + (Ispecific(Ishiftarith(shiftop, n)), [arg1; arg2]) + | [arg1; Cop(Casr, [arg2; Cconst_int n])] + when n > 0 && n < 32 && not(is_intconst arg2) -> + (Ispecific(Ishiftarith(shiftop, -n)), [arg1; arg2]) + | [Cop(Clsl, [arg1; Cconst_int n]); arg2] + when n > 0 && n < 32 && not(is_intconst arg1) -> + (Ispecific(Ishiftarith(shiftrevop, n)), [arg2; arg1]) + | [Cop(Casr, [arg1; Cconst_int n]); arg2] + when n > 0 && n < 32 && not(is_intconst arg1) -> + (Ispecific(Ishiftarith(shiftrevop, -n)), [arg2; arg1]) + | _ -> + super#select_operation op args + +method select_operation op args = + match op with + Cadda | Caddi -> + begin match args with + [arg1; Cconst_int n] when n < 0 && self#is_immediate (-n) -> + (Iintop_imm(Isub, -n), [arg1]) + | _ -> + self#select_shift_arith op Ishiftadd Ishiftadd args + end + | Csuba | Csubi -> + begin match args with + [arg1; Cconst_int n] when n < 0 && self#is_immediate (-n) -> + (Iintop_imm(Iadd, -n), [arg1]) + | [Cconst_int n; arg2] when self#is_immediate n -> + (Ispecific(Irevsubimm n), [arg2]) + | _ -> + self#select_shift_arith op Ishiftsub Ishiftsubrev args + end + | Cmuli -> (* no multiply immediate *) + (Iintop Imul, args) + | Cdivi -> + begin match args with + [arg1; Cconst_int n] when n = 1 lsl (Misc.log2 n) -> + (Iintop_imm(Idiv, n), [arg1]) + | _ -> + (Iextcall("__divsi3", false), args) + end + | Cmodi -> + begin match args with + [arg1; Cconst_int n] when n = 1 lsl (Misc.log2 n) -> + (Iintop_imm(Imod, n), [arg1]) + | _ -> + (Iextcall("__modsi3", false), args) + end + | Ccheckbound -> + begin match args with + [Cop(Clsr, [arg1; Cconst_int n]); arg2] + when n > 0 && n < 32 && not(is_intconst arg2) -> + (Ispecific(Ishiftcheckbound n), [arg1; arg2]) + | _ -> + super#select_operation op args + end + | _ -> super#select_operation op args + +(* In mul rd, rm, rs, rm and rd must be different. + We deal with this by pretending that rm is also a result of the mul + operation. *) + +method insert_op op rs rd = + if op = Iintop(Imul) then begin + self#insert (Iop op) rs [| rd.(0); rs.(0) |]; rd + end else + super#insert_op op rs rd + +end + +let fundecl f = (new selector)#emit_fundecl f + diff --git a/asmcomp/asmgen.ml b/asmcomp/asmgen.ml new file mode 100644 index 00000000..66d9eac8 --- /dev/null +++ b/asmcomp/asmgen.ml @@ -0,0 +1,113 @@ +(***********************************************************************) +(* *) +(* 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: asmgen.ml,v 1.19 2000/04/21 08:10:25 weis Exp $ *) + +(* From lambda to assembly code *) + +open Format +open Config +open Clflags +open Misc +open Cmm + +type error = Assembler_error of string + +exception Error of error + +let liveness ppf phrase = + Liveness.fundecl ppf phrase; phrase + +let dump_if ppf flag message phrase = + if !flag then Printmach.phase message ppf phrase + +let pass_dump_if ppf flag message phrase = + dump_if ppf flag message phrase; phrase + +let pass_dump_linear_if ppf flag message phrase = + if !flag then fprintf ppf "*** %s@.%a@." message Printlinear.fundecl phrase; + phrase + +let rec regalloc ppf round fd = + if round > 50 then + fatal_error(fd.Mach.fun_name ^ + ": function too complex, cannot complete register allocation"); + dump_if ppf dump_live "Liveness analysis" fd; + Interf.build_graph fd; + if !dump_interf then Printmach.interferences ppf (); + if !dump_prefer then Printmach.preferences ppf (); + Coloring.allocate_registers(); + dump_if ppf dump_regalloc "After register allocation" fd; + let (newfd, redo_regalloc) = Reload.fundecl fd in + dump_if ppf dump_reload "After insertion of reloading code" newfd; + if redo_regalloc then begin + Reg.reinit(); Liveness.fundecl ppf newfd; regalloc ppf (round + 1) newfd + end else newfd + +let (++) x f = f x + +let compile_fundecl (ppf : formatter) fd_cmm = + Reg.reset(); + fd_cmm + ++ Selection.fundecl + ++ pass_dump_if ppf dump_selection "After instruction selection" + ++ Comballoc.fundecl + ++ pass_dump_if ppf dump_combine "After allocation combining" + ++ liveness ppf + ++ pass_dump_if ppf dump_live "Liveness analysis" + ++ Spill.fundecl + ++ liveness ppf + ++ pass_dump_if ppf dump_spill "After spilling" + ++ Split.fundecl + ++ pass_dump_if ppf dump_split "After live range splitting" + ++ liveness ppf + ++ regalloc ppf 1 + ++ Linearize.fundecl + ++ pass_dump_linear_if ppf dump_linear "Linearized code" + ++ Scheduling.fundecl + ++ pass_dump_linear_if ppf dump_scheduling "After instruction scheduling" + ++ Emit.fundecl + +let compile_phrase ppf p = + if !dump_cmm then fprintf ppf "%a@." Printcmm.phrase p; + match p with + | Cfunction fd -> compile_fundecl ppf fd + | Cdata dl -> Emit.data dl + +let compile_implementation prefixname ppf (size, lam) = + let asmfile = + if !keep_asm_file + then prefixname ^ ext_asm + else Filename.temp_file "camlasm" ext_asm in + let oc = open_out asmfile in + begin try + Emitaux.output_channel := oc; + Emit.begin_assembly(); + Closure.intro size lam + ++ Cmmgen.compunit size + ++ List.iter (compile_phrase ppf) ++ (fun () -> ()); + Emit.end_assembly(); + close_out oc + with x -> + close_out oc; + if !keep_asm_file then () else remove_file asmfile; + raise x + end; + if Proc.assemble_file asmfile (prefixname ^ ext_obj) <> 0 + then raise(Error(Assembler_error asmfile)); + if !keep_asm_file then () else remove_file asmfile + +(* Error report *) + +let report_error ppf = function + | Assembler_error file -> + fprintf ppf "Assembler error, input left in file %s" file diff --git a/asmcomp/asmgen.mli b/asmcomp/asmgen.mli new file mode 100644 index 00000000..94536e12 --- /dev/null +++ b/asmcomp/asmgen.mli @@ -0,0 +1,24 @@ +(***********************************************************************) +(* *) +(* 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: asmgen.mli,v 1.7 2000/04/21 08:10:26 weis Exp $ *) + +(* From lambda to assembly code *) + +val compile_implementation : + string -> Format.formatter -> int * Lambda.lambda -> unit +val compile_phrase : + Format.formatter -> Cmm.phrase -> unit + +type error = Assembler_error of string +exception Error of error +val report_error: Format.formatter -> error -> unit diff --git a/asmcomp/asmlibrarian.ml b/asmcomp/asmlibrarian.ml new file mode 100644 index 00000000..33395931 --- /dev/null +++ b/asmcomp/asmlibrarian.ml @@ -0,0 +1,74 @@ +(***********************************************************************) +(* *) +(* 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: asmlibrarian.ml,v 1.13 2002/04/04 09:00:16 garrigue Exp $ *) + +(* Build libraries of .cmx files *) + +open Misc +open Config +open Compilenv + +type error = + File_not_found of string + | Archiver_error of string + +exception Error of error + +let read_info name = + let filename = + try + find_in_path !load_path name + with Not_found -> + raise(Error(File_not_found name)) in + let (info, crc) = Compilenv.read_unit_info filename in + info.ui_force_link <- !Clflags.link_everything; + (* There is no need to keep the approximation in the .cmxa file, + since the compiler will go looking directly for .cmx files. + The linker, which is the only one that reads .cmxa files, does not + need the approximation. *) + info.ui_approx <- Clambda.Value_unknown; + (Filename.chop_suffix filename ".cmx" ^ ext_obj, (info, crc)) + +let create_archive file_list lib_name = + let archive_name = Filename.chop_suffix lib_name ".cmxa" ^ ext_lib in + let outchan = open_out_bin lib_name in + try + output_string outchan cmxa_magic_number; + let (objfile_list, descr_list) = + List.split (List.map read_info file_list) in + List.iter2 + (fun file_name (unit, crc) -> + Asmlink.check_consistency file_name unit crc) + file_list descr_list; + let infos = + { lib_units = descr_list; + lib_ccobjs = !Clflags.ccobjs; + lib_ccopts = !Clflags.ccopts } in + output_value outchan infos; + if Ccomp.create_archive archive_name objfile_list <> 0 + then raise(Error(Archiver_error archive_name)); + close_out outchan + with x -> + close_out outchan; + remove_file lib_name; + remove_file archive_name; + raise x + +open Format + +let report_error ppf = function + | File_not_found name -> + fprintf ppf "Cannot find file %s" name + | Archiver_error name -> + fprintf ppf "Error while creating the library %s" name + diff --git a/asmcomp/asmlibrarian.mli b/asmcomp/asmlibrarian.mli new file mode 100644 index 00000000..9b60488d --- /dev/null +++ b/asmcomp/asmlibrarian.mli @@ -0,0 +1,27 @@ +(***********************************************************************) +(* *) +(* 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: asmlibrarian.mli,v 1.6 2000/04/21 08:10:27 weis Exp $ *) + +(* Build libraries of .cmx files *) + +open Format + +val create_archive: string list -> string -> unit + +type error = + File_not_found of string + | Archiver_error of string + +exception Error of error + +val report_error: formatter -> error -> unit diff --git a/asmcomp/asmlink.ml b/asmcomp/asmlink.ml new file mode 100644 index 00000000..a66b6052 --- /dev/null +++ b/asmcomp/asmlink.ml @@ -0,0 +1,360 @@ +(***********************************************************************) +(* *) +(* 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: asmlink.ml,v 1.62 2003/06/27 08:49:22 xleroy Exp $ *) + +(* Link a set of .cmx/.o files and produce an executable *) + +open Sys +open Misc +open Config +open Compilenv + +type error = + File_not_found of string + | Not_an_object_file of string + | Missing_implementations of (string * string list) list + | Inconsistent_interface of string * string * string + | Inconsistent_implementation of string * string * string + | Assembler_error of string + | Linking_error + | Multiple_definition of string * string * string + +exception Error of error + +(* Consistency check between interfaces and implementations *) + +let crc_interfaces = Consistbl.create () +let crc_implementations = Consistbl.create () +let extra_implementations = ref ([] : string list) +let implementations_defined = ref ([] : (string * string) list) + +let check_consistency file_name unit crc = + begin try + List.iter + (fun (name, crc) -> + if name = unit.ui_name + then Consistbl.set crc_interfaces name crc file_name + else Consistbl.check crc_interfaces name crc file_name) + unit.ui_imports_cmi + with Consistbl.Inconsistency(name, user, auth) -> + raise(Error(Inconsistent_interface(name, user, auth))) + end; + begin try + List.iter + (fun (name, crc) -> + if crc = cmx_not_found_crc then + extra_implementations := name :: !extra_implementations + else + Consistbl.check crc_implementations name crc file_name) + unit.ui_imports_cmx + with Consistbl.Inconsistency(name, user, auth) -> + raise(Error(Inconsistent_implementation(name, user, auth))) + end; + begin try + let source = List.assoc unit.ui_name !implementations_defined in + raise (Error(Multiple_definition(unit.ui_name, file_name, source))) + with Not_found -> () + end; + Consistbl.set crc_implementations unit.ui_name crc file_name; + implementations_defined := + (unit.ui_name, file_name) :: !implementations_defined + +let extract_crc_interfaces () = + Consistbl.extract crc_interfaces +let extract_crc_implementations () = + List.fold_left + (fun ncl n -> + if List.mem_assoc n ncl then ncl else (n, cmx_not_found_crc) :: ncl) + (Consistbl.extract crc_implementations) + !extra_implementations + +(* Add C objects and options and "custom" info from a library descriptor. + See bytecomp/bytelink.ml for comments on the order of C objects. *) + +let lib_ccobjs = ref [] +let lib_ccopts = ref [] + +let add_ccobjs l = + if not !Clflags.no_auto_link then begin + lib_ccobjs := l.lib_ccobjs @ !lib_ccobjs; + lib_ccopts := l.lib_ccopts @ !lib_ccopts + end + +(* First pass: determine which units are needed *) + +let missing_globals = (Hashtbl.create 17 : (string, string list ref) Hashtbl.t) + +let is_required name = + try ignore (Hashtbl.find missing_globals name); true + with Not_found -> false + +let add_required by (name, crc) = + try + let rq = Hashtbl.find missing_globals name in + rq := by :: !rq + with Not_found -> + Hashtbl.add missing_globals name (ref [by]) + +let remove_required name = + Hashtbl.remove missing_globals name + +let extract_missing_globals () = + let mg = ref [] in + Hashtbl.iter (fun md rq -> mg := (md, !rq) :: !mg) missing_globals; + !mg + +let scan_file obj_name tolink = + let file_name = + try + find_in_path !load_path obj_name + with Not_found -> + raise(Error(File_not_found obj_name)) in + if Filename.check_suffix file_name ".cmx" then begin + (* This is a .cmx file. It must be linked in any case. + Read the infos to see which modules it requires. *) + let (info, crc) = Compilenv.read_unit_info file_name in + remove_required info.ui_name; + List.iter (add_required file_name) info.ui_imports_cmx; + (info, file_name, crc) :: tolink + end + else if Filename.check_suffix file_name ".cmxa" then begin + (* This is an archive file. Each unit contained in it will be linked + in only if needed. *) + let ic = open_in_bin file_name in + let buffer = String.create (String.length cmxa_magic_number) in + really_input ic buffer 0 (String.length cmxa_magic_number); + if buffer <> cmxa_magic_number then + raise(Error(Not_an_object_file file_name)); + let infos = (input_value ic : library_infos) in + close_in ic; + add_ccobjs infos; + List.fold_right + (fun (info, crc) reqd -> + if info.ui_force_link + || !Clflags.link_everything + || is_required info.ui_name + then begin + remove_required info.ui_name; + List.iter (add_required (Printf.sprintf "%s(%s)" + file_name info.ui_name)) + info.ui_imports_cmx; + (info, file_name, crc) :: reqd + end else + reqd) + infos.lib_units tolink + end + else raise(Error(Not_an_object_file file_name)) + +(* Second pass: generate the startup file and link it with everything else *) + +module IntSet = Set.Make( + struct + type t = int + let compare = compare + end) + +let make_startup_file ppf filename units_list = + let compile_phrase p = Asmgen.compile_phrase ppf p in + let oc = open_out filename in + Emitaux.output_channel := oc; + Location.input_name := "startup"; (* set the name of the "current" input *) + Compilenv.reset "startup"; (* set the name of the "current" compunit *) + Emit.begin_assembly(); + let name_list = + List.flatten (List.map (fun (info,_,_) -> info.ui_defines) units_list) in + compile_phrase (Cmmgen.entry_point name_list); + let apply_functions = ref (IntSet.add 2 (IntSet.add 3 IntSet.empty)) in + (* The callback functions always reference caml_apply[23] *) + let curry_functions = + ref IntSet.empty in + List.iter + (fun (info,_,_) -> + List.iter + (fun n -> apply_functions := IntSet.add n !apply_functions) + info.ui_apply_fun; + List.iter + (fun n -> curry_functions := IntSet.add n !curry_functions) + info.ui_curry_fun) + units_list; + IntSet.iter + (fun n -> compile_phrase (Cmmgen.apply_function n)) + !apply_functions; + IntSet.iter + (fun n -> List.iter (compile_phrase) (Cmmgen.curry_function n)) + !curry_functions; + Array.iter + (fun name -> compile_phrase (Cmmgen.predef_exception name)) + Runtimedef.builtin_exceptions; + compile_phrase (Cmmgen.global_table name_list); + compile_phrase + (Cmmgen.globals_map + (List.map + (fun (unit,_,_) -> + try (unit.ui_name, List.assoc unit.ui_name unit.ui_imports_cmi) + with Not_found -> assert false) + units_list)); + compile_phrase(Cmmgen.data_segment_table ("startup" :: name_list)); + compile_phrase(Cmmgen.code_segment_table ("startup" :: name_list)); + compile_phrase + (Cmmgen.frame_table("startup" :: "system" :: name_list)); + Emit.end_assembly(); + close_out oc + +let call_linker file_list startup_file output_name = + let libname = + if !Clflags.gprofile + then "libasmrunp" ^ ext_lib + else "libasmrun" ^ ext_lib in + let runtime_lib = + try + if !Clflags.nopervasives then "" + else find_in_path !load_path libname + with Not_found -> + raise(Error(File_not_found libname)) in + let c_lib = + if !Clflags.nopervasives then "" else Config.native_c_libraries in + let cmd = + match Config.ccomp_type with + "cc" -> + if not !Clflags.output_c_object then + Printf.sprintf "%s %s -o %s %s %s %s %s %s %s %s %s" + !Clflags.c_linker + (if !Clflags.gprofile then Config.cc_profile else "") + (Filename.quote output_name) + (Clflags.std_include_flag "-I") + (String.concat " " (List.rev !Clflags.ccopts)) + (Filename.quote startup_file) + (Ccomp.quote_files (List.rev file_list)) + (Ccomp.quote_files + (List.map (fun dir -> if dir = "" then "" else "-L" ^ dir) + !load_path)) + (Ccomp.quote_files (List.rev !Clflags.ccobjs)) + (Filename.quote runtime_lib) + c_lib + else + Printf.sprintf "%s -o %s %s %s" + Config.native_partial_linker + (Filename.quote output_name) + (Filename.quote startup_file) + (Ccomp.quote_files (List.rev file_list)) + | "msvc" -> + if not !Clflags.output_c_object then + Printf.sprintf "%s /Fe%s %s %s %s %s %s %s %s" + !Clflags.c_linker + (Filename.quote output_name) + (Clflags.std_include_flag "-I") + (Filename.quote startup_file) + (Ccomp.quote_files (List.rev file_list)) + (Ccomp.quote_files + (List.rev_map Ccomp.expand_libname !Clflags.ccobjs)) + (Filename.quote runtime_lib) + c_lib + (String.concat " " (List.rev !Clflags.ccopts)) + else + Printf.sprintf "%s /out:%s %s %s" + Config.native_partial_linker + (Filename.quote output_name) + (Filename.quote startup_file) + (Ccomp.quote_files (List.rev file_list)) + | _ -> assert false + in if Ccomp.command cmd <> 0 then raise(Error Linking_error) + +let object_file_name name = + let file_name = + try + find_in_path !load_path name + with Not_found -> + fatal_error "Asmlink.object_file_name: not found" in + if Filename.check_suffix file_name ".cmx" then + Filename.chop_suffix file_name ".cmx" ^ ext_obj + else if Filename.check_suffix file_name ".cmxa" then + Filename.chop_suffix file_name ".cmxa" ^ ext_lib + else + fatal_error "Asmlink.object_file_name: bad ext" + +(* Main entry point *) + +let link ppf objfiles output_name = + let stdlib = + if !Clflags.gprofile then "stdlib.p.cmxa" else "stdlib.cmxa" in + let stdexit = + if !Clflags.gprofile then "std_exit.p.cmx" else "std_exit.cmx" in + let objfiles = + if !Clflags.nopervasives then objfiles + else if !Clflags.output_c_object then stdlib :: objfiles + else stdlib :: (objfiles @ [stdexit]) in + let units_tolink = List.fold_right scan_file objfiles [] in + Array.iter remove_required Runtimedef.builtin_exceptions; + begin match extract_missing_globals() with + [] -> () + | mg -> raise(Error(Missing_implementations mg)) + end; + List.iter + (fun (info, file_name, crc) -> check_consistency file_name info crc) + units_tolink; + Clflags.ccobjs := !Clflags.ccobjs @ !lib_ccobjs; + Clflags.ccopts := !lib_ccopts @ !Clflags.ccopts; (* put user's opts first *) + let startup = Filename.temp_file "camlstartup" ext_asm in + make_startup_file ppf startup units_tolink; + let startup_obj = Filename.temp_file "camlstartup" ext_obj in + if Proc.assemble_file startup startup_obj <> 0 then + raise(Error(Assembler_error startup)); + try + call_linker (List.map object_file_name objfiles) startup_obj output_name; + if not !Clflags.keep_startup_file then remove_file startup; + remove_file startup_obj + with x -> + remove_file startup_obj; + raise x + +(* Error report *) + +open Format + +let report_error ppf = function + | File_not_found name -> + fprintf ppf "Cannot find file %s" name + | Not_an_object_file name -> + fprintf ppf "The file %s is not a compilation unit description" name + | Missing_implementations l -> + let print_references ppf = function + | [] -> () + | r1 :: rl -> + fprintf ppf "%s" r1; + List.iter (fun r -> fprintf ppf ",@ %s" r) rl in + let print_modules ppf = + List.iter + (fun (md, rq) -> + fprintf ppf "@ @[%s referenced from %a@]" md + print_references rq) in + fprintf ppf + "@[No implementations provided for the following modules:%a@]" + print_modules l + | Inconsistent_interface(intf, file1, file2) -> + fprintf ppf + "@[Files %s@ and %s@ make inconsistent assumptions \ + over interface %s@]" + file1 file2 intf + | Inconsistent_implementation(intf, file1, file2) -> + fprintf ppf + "@[Files %s@ and %s@ make inconsistent assumptions \ + over implementation %s@]" + file1 file2 intf + | Assembler_error file -> + fprintf ppf "Error while assembling %s" file + | Linking_error -> + fprintf ppf "Error during linking" + | Multiple_definition(modname, file1, file2) -> + fprintf ppf + "@[Files %s@ and %s@ both define a module named %s@]" + file1 file2 modname diff --git a/asmcomp/asmlink.mli b/asmcomp/asmlink.mli new file mode 100644 index 00000000..e57fbff3 --- /dev/null +++ b/asmcomp/asmlink.mli @@ -0,0 +1,37 @@ +(***********************************************************************) +(* *) +(* 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: asmlink.mli,v 1.10 2002/06/11 14:15:11 xleroy Exp $ *) + +(* Link a set of .cmx/.o files and produce an executable *) + +open Format + +val link: formatter -> string list -> string -> unit + +val check_consistency: string -> Compilenv.unit_infos -> Digest.t -> unit +val extract_crc_interfaces: unit -> (string * Digest.t) list +val extract_crc_implementations: unit -> (string * Digest.t) list + +type error = + File_not_found of string + | Not_an_object_file of string + | Missing_implementations of (string * string list) list + | Inconsistent_interface of string * string * string + | Inconsistent_implementation of string * string * string + | Assembler_error of string + | Linking_error + | Multiple_definition of string * string * string + +exception Error of error + +val report_error: formatter -> error -> unit diff --git a/asmcomp/asmpackager.ml b/asmcomp/asmpackager.ml new file mode 100644 index 00000000..828d255d --- /dev/null +++ b/asmcomp/asmpackager.ml @@ -0,0 +1,315 @@ +(***********************************************************************) +(* *) +(* 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: asmpackager.ml,v 1.8 2003/07/03 16:21:47 xleroy Exp $ *) + +(* "Package" a set of .cmx/.o files into one .cmx/.o file having the + original compilation units as sub-modules. *) + +open Printf +open Misc +open Lambda +open Clambda +open Compilenv + +type error = + Illegal_renaming of string * string + | Forward_reference of string * string + | Linking_error + | Assembler_error of string + | File_not_found of string + | No_binutils + +exception Error of error + +(* Read the unit information from a .cmx file. *) + +let read_unit_info cmxfile = + let (info, crc) = Compilenv.read_unit_info cmxfile in + if info.ui_name + <> String.capitalize(Filename.basename(chop_extension_if_any cmxfile)) + then raise(Error(Illegal_renaming(cmxfile, info.ui_name))); + Asmlink.check_consistency cmxfile info crc; + info + +(* Check absence of forward references *) + +let check_units cmxfiles units unit_names = + let rec check forbidden = function + [] -> () + | (cmxfile, infos) :: tl -> + List.iter + (fun (unit, _) -> + if List.mem unit forbidden + then raise(Error(Forward_reference(cmxfile, unit)))) + infos.ui_imports_cmx; + check (list_remove infos.ui_name forbidden) tl in + check unit_names (List.combine cmxfiles units) + +(* Rename symbols in an object file. All defined symbols of the form + [T] or [T]__xxx, where [T] belongs to the list [units], are prefixed by + [pref]__ . Return the list of renamed symbols. *) + +let extract_symbols units symbolfile = + let symbs = ref [] in + let ic = open_in symbolfile in + begin try + while true do + let l = input_line ic in + try + let i = 3 + (try search_substring " T " l 0 + with Not_found -> search_substring " D " l 0) in + let j = try search_substring "__" l i + with Not_found -> String.length l in + let k = if l.[i] = '_' then i + 1 else i in + if List.mem (String.sub l k (j - k)) units then + symbs := (String.sub l i (String.length l - i)) :: !symbs + with Not_found -> + () + done + with End_of_file -> close_in ic + | x -> close_in ic; raise x + end; + !symbs + +let max_cmdline_length = 3500 (* safe approximation *) + +let remove_leading_underscore s = + if String.length s > 0 && s.[0] = '_' + then String.sub s 1 (String.length s - 1) + else s + +let prefix_symbol p s = + if String.length s > 0 && s.[0] = '_' + then "_" ^ p ^ "__" ^ String.sub s 1 (String.length s - 1) + else p ^ "__" ^ s + +let rename_in_object_file units pref objfile = + let symbolfile = Filename.temp_file "camlsymbols" "" in + try + let nm_cmdline = + sprintf "%s %s > %s" + Config.binutils_nm + (Filename.quote objfile) (Filename.quote symbolfile) in + if Ccomp.command nm_cmdline <> 0 then raise(Error Linking_error); + let symbols_to_rename = + extract_symbols units symbolfile in + let cmdline = + Buffer.create max_cmdline_length in + let rec call_objcopy = function + [] -> + Buffer.add_char cmdline ' '; + Buffer.add_string cmdline (Filename.quote objfile); + if Ccomp.command (Buffer.contents cmdline) <> 0 + then raise(Error Linking_error) + | s :: rem -> + if Buffer.length cmdline >= max_cmdline_length then begin + Buffer.add_char cmdline ' '; + Buffer.add_string cmdline (Filename.quote objfile); + if Ccomp.command (Buffer.contents cmdline) <> 0 + then raise(Error Linking_error); + Buffer.reset cmdline; + Buffer.add_string cmdline Config.binutils_objcopy + end; + bprintf cmdline " --redefine-sym '%s=%s'" s (prefix_symbol pref s); + call_objcopy rem in + Buffer.add_string cmdline Config.binutils_objcopy; + call_objcopy symbols_to_rename; + remove_file symbolfile; + List.map remove_leading_underscore symbols_to_rename + with x -> + remove_file symbolfile; + raise x + +(* Rename function symbols and global symbols in value approximations *) + +let rename_approx mapping approx = + + let ren_label lbl = + try Tbl.find lbl mapping with Not_found -> lbl in + let ren_ident id = + if Ident.persistent id + then Ident.create_persistent(ren_label(Ident.name id)) + else id in + + let rec ren_ulambda = function + Uvar id -> + Uvar(ren_ident id) + | Uconst cst -> + Uconst cst + | Udirect_apply(lbl, args) -> + Udirect_apply(ren_label lbl, List.map ren_ulambda args) + | Ugeneric_apply(fn, args) -> + Ugeneric_apply(ren_ulambda fn, List.map ren_ulambda args) + | Uclosure(fns, env) -> + (* never present in an inlined function body *) + assert false + | Uoffset(lam, ofs) -> Uoffset(ren_ulambda lam, ofs) + | Ulet(id, u, body) -> Ulet(id, ren_ulambda u, ren_ulambda body) + | Uletrec(defs, body) -> + (* never present in an inlined function body *) + assert false + | Uprim(prim, args) -> + let prim' = + match prim with + Pgetglobal id -> Pgetglobal(ren_ident id) + | Psetglobal id -> assert false (* never present in inlined fn body *) + | _ -> prim in + Uprim(prim', List.map ren_ulambda args) + | Uswitch(u, cases) -> + Uswitch(ren_ulambda u, + {cases with + us_actions_consts = Array.map ren_ulambda cases.us_actions_consts; + us_actions_blocks = Array.map ren_ulambda cases.us_actions_blocks}) + | Ustaticfail(tag, args) -> + Ustaticfail(tag, List.map ren_ulambda args) + | Ucatch(nfail, ids, u1, u2) -> + Ucatch(nfail, ids, ren_ulambda u1, ren_ulambda u2) + | Utrywith(u1, id, u2) -> + Utrywith(ren_ulambda u1, id, ren_ulambda u2) + | Uifthenelse(u1, u2, u3) -> + Uifthenelse(ren_ulambda u1, ren_ulambda u2, ren_ulambda u3) + | Usequence(u1, u2) -> + Usequence(ren_ulambda u1, ren_ulambda u2) + | Uwhile(u1, u2) -> + Uwhile(ren_ulambda u1, ren_ulambda u2) + | Ufor(id, u1, u2, dir, u3) -> + Ufor(id, ren_ulambda u1, ren_ulambda u2, dir, ren_ulambda u3) + | Uassign(id, u) -> + Uassign(id, ren_ulambda u) + | Usend(u1, u2, ul) -> + Usend(ren_ulambda u1, ren_ulambda u2, List.map ren_ulambda ul) in + + let rec ren_approx = function + Value_closure(fd, res) -> + let fd' = + {fd with + fun_label = ren_label fd.fun_label; + fun_inline = + match fd.fun_inline with + None -> None + | Some(params, body) -> Some(params, ren_ulambda body)} in + Value_closure(fd', ren_approx res) + | Value_tuple comps -> + Value_tuple (Array.map ren_approx comps) + | app -> app + + in ren_approx approx + +(* Make the .cmx file for the package *) + +let build_package_cmx units unit_names target symbols_to_rename cmxfile = + let filter lst = + List.filter (fun (name, crc) -> not (List.mem name unit_names)) lst in + let union lst = + List.fold_left + (List.fold_left + (fun accu n -> if List.mem n accu then accu else n :: accu)) + [] lst in + let mapping = + List.fold_left (fun tbl s -> Tbl.add s (target ^ "__" ^ s) tbl) + Tbl.empty symbols_to_rename in + let defines = + map_end (fun s -> target ^ "__" ^ s) + (List.concat (List.map (fun info -> info.ui_defines) units)) + [target] in + let approx = + Compilenv.global_approx (Ident.create_persistent target) in + let pkg_infos = + { ui_name = target; + ui_defines = defines; + ui_imports_cmi = (target, Env.crc_of_unit target) :: + filter(Asmlink.extract_crc_interfaces()); + ui_imports_cmx = filter(Asmlink.extract_crc_implementations()); + ui_approx = rename_approx mapping approx; + ui_curry_fun = union(List.map (fun info -> info.ui_curry_fun) units); + ui_apply_fun = union(List.map (fun info -> info.ui_apply_fun) units); + ui_force_link = List.exists (fun info -> info.ui_force_link) units + } in + Compilenv.write_unit_info pkg_infos cmxfile + +(* Make the .o file for the package (not renamed yet) *) + +let make_package_object ppf unit_names objfiles + targetobj targetname coercion = + let objtemp = Filename.temp_file "camlpackage" Config.ext_obj in + Location.input_name := targetname; (* set the name of the "current" input *) + Compilenv.reset targetname; (* set the name of the "current" compunit *) + Asmgen.compile_implementation + (chop_extension_if_any objtemp) ppf + (Translmod.transl_store_package + (List.map Ident.create_persistent unit_names) + (Ident.create_persistent targetname) coercion); + let ld_cmd = + sprintf "%s -o %s %s %s" + Config.native_pack_linker + (Filename.quote targetobj) + (Filename.quote objtemp) + (Ccomp.quote_files objfiles) in + let retcode = Ccomp.command ld_cmd in + remove_file objtemp; + if retcode <> 0 then raise(Error Linking_error) + +(* Make the .cmx and the .o for the package *) + +let package_object_files ppf cmxfiles targetcmx + targetobj targetname coercion = + let units = map_left_right read_unit_info cmxfiles in + let unit_names = List.map (fun info -> info.ui_name) units in + check_units cmxfiles units unit_names; + let objfiles = + List.map (fun f -> chop_extension_if_any f ^ Config.ext_obj) cmxfiles in + make_package_object ppf unit_names objfiles targetobj targetname coercion; + let symbols = rename_in_object_file unit_names targetname targetobj in + build_package_cmx units unit_names targetname symbols targetcmx + +(* The entry point *) + +let package_files ppf files targetcmx = + if Config.binutils_objcopy = "" || Config.binutils_nm = "" + then raise (Error No_binutils); + let cmxfiles = + List.map + (fun f -> + try find_in_path !Config.load_path f + with Not_found -> raise(Error(File_not_found f))) + files in + let prefix = chop_extension_if_any targetcmx in + let targetcmi = prefix ^ ".cmi" in + let targetobj = prefix ^ Config.ext_obj in + let targetname = String.capitalize(Filename.basename prefix) in + try + let coercion = Typemod.package_units cmxfiles targetcmi targetname in + package_object_files ppf cmxfiles targetcmx targetobj targetname coercion + with x -> + remove_file targetcmx; remove_file targetobj; + raise x + +(* Error report *) + +open Format + +let report_error ppf = function + Illegal_renaming(file, id) -> + fprintf ppf "Wrong file naming: %s@ contains the code for@ %s" + file id + | Forward_reference(file, ident) -> + fprintf ppf "Forward reference to %s in file %s" ident file + | File_not_found file -> + fprintf ppf "File %s not found" file + | Assembler_error file -> + fprintf ppf "Error while assembling %s" file + | Linking_error -> + fprintf ppf "Error during partial linking" + | No_binutils -> + fprintf ppf "ocamlopt -pack is not supported on this platform.@ \ + Reason: the GNU `binutils' tools are not available" diff --git a/asmcomp/asmpackager.mli b/asmcomp/asmpackager.mli new file mode 100644 index 00000000..054ff7b1 --- /dev/null +++ b/asmcomp/asmpackager.mli @@ -0,0 +1,30 @@ +(***********************************************************************) +(* *) +(* 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: asmpackager.mli,v 1.1 2002/02/08 16:55:30 xleroy Exp $ *) + +(* "Package" a set of .cmx/.o files into one .cmx/.o file having the + original compilation units as sub-modules. *) + +val package_files: Format.formatter -> string list -> string -> unit + +type error = + Illegal_renaming of string * string + | Forward_reference of string * string + | Linking_error + | Assembler_error of string + | File_not_found of string + | No_binutils + +exception Error of error + +val report_error: Format.formatter -> error -> unit diff --git a/asmcomp/clambda.ml b/asmcomp/clambda.ml new file mode 100644 index 00000000..25d0b8c2 --- /dev/null +++ b/asmcomp/clambda.ml @@ -0,0 +1,66 @@ +(***********************************************************************) +(* *) +(* 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: clambda.ml,v 1.15 2001/02/19 20:15:36 maranget Exp $ *) + +(* A variant of the "lambda" code with direct / indirect calls explicit + and closures explicit too *) + +open Asttypes +open Lambda + +type function_label = string + +type ulambda = + Uvar of Ident.t + | Uconst of structured_constant + | Udirect_apply of function_label * ulambda list + | Ugeneric_apply of ulambda * ulambda list + | Uclosure of (function_label * int * Ident.t list * ulambda) list + * ulambda list + | Uoffset of ulambda * int + | Ulet of Ident.t * ulambda * ulambda + | Uletrec of (Ident.t * ulambda) list * ulambda + | Uprim of primitive * ulambda list + | Uswitch of ulambda * ulambda_switch + | Ustaticfail of int * ulambda list + | Ucatch of int * Ident.t list * ulambda * ulambda + | Utrywith of ulambda * Ident.t * ulambda + | Uifthenelse of ulambda * ulambda * ulambda + | Usequence of ulambda * ulambda + | Uwhile of ulambda * ulambda + | Ufor of Ident.t * ulambda * ulambda * direction_flag * ulambda + | Uassign of Ident.t * ulambda + | Usend of ulambda * ulambda * ulambda list + +and ulambda_switch = + { us_index_consts: int array; + us_actions_consts : ulambda array; + us_index_blocks: int array; + us_actions_blocks: ulambda array} + +(* Description of known functions *) + +type function_description = + { fun_label: function_label; (* Label of direct entry point *) + fun_arity: int; (* Number of arguments *) + mutable fun_closed: bool; (* True if environment not used *) + mutable fun_inline: (Ident.t list * ulambda) option } + +(* Approximation of values *) + +type value_approximation = + Value_closure of function_description * value_approximation + | Value_tuple of value_approximation array + | Value_unknown + | Value_integer of int + | Value_constptr of int diff --git a/asmcomp/clambda.mli b/asmcomp/clambda.mli new file mode 100644 index 00000000..f536ac8e --- /dev/null +++ b/asmcomp/clambda.mli @@ -0,0 +1,66 @@ +(***********************************************************************) +(* *) +(* 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: clambda.mli,v 1.15 2001/02/19 20:15:36 maranget Exp $ *) + +(* A variant of the "lambda" code with direct / indirect calls explicit + and closures explicit too *) + +open Asttypes +open Lambda + +type function_label = string + +type ulambda = + Uvar of Ident.t + | Uconst of structured_constant + | Udirect_apply of function_label * ulambda list + | Ugeneric_apply of ulambda * ulambda list + | Uclosure of (function_label * int * Ident.t list * ulambda) list + * ulambda list + | Uoffset of ulambda * int + | Ulet of Ident.t * ulambda * ulambda + | Uletrec of (Ident.t * ulambda) list * ulambda + | Uprim of primitive * ulambda list + | Uswitch of ulambda * ulambda_switch + | Ustaticfail of int * ulambda list + | Ucatch of int * Ident.t list * ulambda * ulambda + | Utrywith of ulambda * Ident.t * ulambda + | Uifthenelse of ulambda * ulambda * ulambda + | Usequence of ulambda * ulambda + | Uwhile of ulambda * ulambda + | Ufor of Ident.t * ulambda * ulambda * direction_flag * ulambda + | Uassign of Ident.t * ulambda + | Usend of ulambda * ulambda * ulambda list + +and ulambda_switch = + { us_index_consts: int array; + us_actions_consts: ulambda array; + us_index_blocks: int array; + us_actions_blocks: ulambda array} + +(* Description of known functions *) + +type function_description = + { fun_label: function_label; (* Label of direct entry point *) + fun_arity: int; (* Number of arguments *) + mutable fun_closed: bool; (* True if environment not used *) + mutable fun_inline: (Ident.t list * ulambda) option } + +(* Approximation of values *) + +type value_approximation = + Value_closure of function_description * value_approximation + | Value_tuple of value_approximation array + | Value_unknown + | Value_integer of int + | Value_constptr of int diff --git a/asmcomp/closure.ml b/asmcomp/closure.ml new file mode 100644 index 00000000..7595d63b --- /dev/null +++ b/asmcomp/closure.ml @@ -0,0 +1,737 @@ +(***********************************************************************) +(* *) +(* 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: closure.ml,v 1.42 2003/04/25 12:26:58 xleroy Exp $ *) + +(* Introduction of closures, uncurrying, recognition of direct calls *) + +open Misc +open Asttypes +open Primitive +open Lambda +open Switch +open Clambda + +(* Auxiliaries for compiling functions *) + +let rec split_list n l = + if n <= 0 then ([], l) else begin + match l with + [] -> fatal_error "Closure.split_list" + | a::l -> let (l1, l2) = split_list (n-1) l in (a::l1, l2) + end + +let rec build_closure_env env_param pos = function + [] -> Tbl.empty + | id :: rem -> + Tbl.add id (Uprim(Pfield pos, [Uvar env_param])) + (build_closure_env env_param (pos+1) rem) + +(* Check if a variable occurs in a [clambda] term. *) + +let occurs_var var u = + let rec occurs = function + Uvar v -> v = var + | Uconst cst -> false + | Udirect_apply(lbl, args) -> List.exists occurs args + | Ugeneric_apply(funct, args) -> occurs funct || List.exists occurs args + | Uclosure(fundecls, clos) -> List.exists occurs clos + | Uoffset(u, ofs) -> occurs u + | Ulet(id, def, body) -> occurs def || occurs body + | Uletrec(decls, body) -> + List.exists (fun (id, u) -> occurs u) decls || occurs body + | Uprim(p, args) -> List.exists occurs args + | Uswitch(arg, s) -> + occurs arg || + occurs_array s.us_actions_consts || occurs_array s.us_actions_blocks + | Ustaticfail (_, args) -> List.exists occurs args + | Ucatch(_, _, body, hdlr) -> occurs body || occurs hdlr + | Utrywith(body, exn, hdlr) -> occurs body || occurs hdlr + | Uifthenelse(cond, ifso, ifnot) -> + occurs cond || occurs ifso || occurs ifnot + | Usequence(u1, u2) -> occurs u1 || occurs u2 + | Uwhile(cond, body) -> occurs cond || occurs body + | Ufor(id, lo, hi, dir, body) -> occurs lo || occurs hi || occurs body + | Uassign(id, u) -> id = var || occurs u + | Usend(met, obj, args) -> + occurs met || occurs obj || List.exists occurs args + and occurs_array a = + try + for i = 0 to Array.length a - 1 do + if occurs a.(i) then raise Exit + done; + false + with Exit -> + true + in occurs u + +(* Determine whether the estimated size of a clambda term is below + some threshold *) + +let prim_size prim args = + match prim with + Pidentity -> 0 + | Pgetglobal id -> 1 + | Psetglobal id -> 1 + | Pmakeblock(tag, mut) -> 5 + List.length args + | Pfield f -> 1 + | Psetfield(f, isptr) -> if isptr then 4 else 1 + | Pfloatfield f -> 1 + | Psetfloatfield f -> 1 + | Pccall p -> (if p.prim_alloc then 10 else 4) + List.length args + | Praise -> 4 + | Pstringlength -> 5 + | Pstringrefs | Pstringsets -> 6 + | Pmakearray kind -> 5 + List.length args + | Parraylength kind -> if kind = Pgenarray then 6 else 2 + | Parrayrefu kind -> if kind = Pgenarray then 12 else 2 + | Parraysetu kind -> if kind = Pgenarray then 16 else 4 + | Parrayrefs kind -> if kind = Pgenarray then 18 else 8 + | Parraysets kind -> if kind = Pgenarray then 22 else 10 + | Pbittest -> 3 + | Pbigarrayref(ndims, _, _) -> 4 + ndims * 6 + | Pbigarrayset(ndims, _, _) -> 4 + ndims * 6 + | _ -> 2 (* arithmetic and comparisons *) + +(* Very raw approximation of switch cost *) + +let lambda_smaller lam threshold = + let size = ref 0 in + let rec lambda_size lam = + if !size > threshold then raise Exit; + match lam with + Uvar v -> () + | Uconst(Const_base(Const_int _ | Const_char _ | Const_float _ | + Const_int32 _ | Const_int64 _ | Const_nativeint _) | + Const_pointer _) -> incr size + | Uconst _ -> + raise Exit (* avoid duplication of structured constants *) + | Udirect_apply(fn, args) -> + size := !size + 4; lambda_list_size args + | Ugeneric_apply(fn, args) -> + size := !size + 6; lambda_size fn; lambda_list_size args + | Uclosure(defs, vars) -> + raise Exit (* inlining would duplicate function definitions *) + | Uoffset(lam, ofs) -> + incr size; lambda_size lam + | Ulet(id, lam, body) -> + lambda_size lam; lambda_size body + | Uletrec(bindings, body) -> + raise Exit (* usually too large *) + | Uprim(prim, args) -> + size := !size + prim_size prim args; + lambda_list_size args + | Uswitch(lam, cases) -> + if Array.length cases.us_actions_consts > 1 then size := !size + 5 ; + if Array.length cases.us_actions_blocks > 1 then size := !size + 5 ; + lambda_size lam; + lambda_array_size cases.us_actions_consts ; + lambda_array_size cases.us_actions_blocks + | Ustaticfail (_,args) -> lambda_list_size args + | Ucatch(_, _, body, handler) -> + incr size; lambda_size body; lambda_size handler + | Utrywith(body, id, handler) -> + size := !size + 8; lambda_size body; lambda_size handler + | Uifthenelse(cond, ifso, ifnot) -> + size := !size + 2; + lambda_size cond; lambda_size ifso; lambda_size ifnot + | Usequence(lam1, lam2) -> + lambda_size lam1; lambda_size lam2 + | Uwhile(cond, body) -> + size := !size + 2; lambda_size cond; lambda_size body + | Ufor(id, low, high, dir, body) -> + size := !size + 4; lambda_size low; lambda_size high; lambda_size body + | Uassign(id, lam) -> + incr size; lambda_size lam + | Usend(met, obj, args) -> + size := !size + 8; + lambda_size met; lambda_size obj; lambda_list_size args + and lambda_list_size l = List.iter lambda_size l + and lambda_array_size a = Array.iter lambda_size a in + try + lambda_size lam; !size <= threshold + with Exit -> + false + +(* Check if a clambda term is ``pure'', + that is without side-effects *and* not containing function definitions *) + +let rec is_pure_clambda = function + Uvar v -> true + | Uconst cst -> true + | Uprim((Psetglobal _ | Psetfield _ | Psetfloatfield _ | + Pccall _ | Praise | Poffsetref _ | Pstringsetu | Pstringsets | + Parraysetu _ | Parraysets _ | Pbigarrayset _), _) -> false + | Uprim(p, args) -> List.for_all is_pure_clambda args + | _ -> false + +(* Simplify primitive operations on integers *) + +let make_const_int n = (Uconst(Const_base(Const_int n)), Value_integer n) +let make_const_ptr n = (Uconst(Const_pointer n), Value_constptr n) +let make_const_bool b = make_const_ptr(if b then 1 else 0) + +let simplif_prim_pure p (args, approxs) = + match approxs with + [Value_integer x] -> + begin match p with + Pidentity -> make_const_int x + | Pnegint -> make_const_int (-x) + | Poffsetint y -> make_const_int (x + y) + | _ -> (Uprim(p, args), Value_unknown) + end + | [Value_integer x; Value_integer y] -> + begin match p with + Paddint -> make_const_int(x + y) + | Psubint -> make_const_int(x - y) + | Pmulint -> make_const_int(x * y) + | Pdivint when y <> 0 -> make_const_int(x / y) + | Pmodint when y <> 0 -> make_const_int(x mod y) + | Pandint -> make_const_int(x land y) + | Porint -> make_const_int(x lor y) + | Pxorint -> make_const_int(x lxor y) + | Plslint -> make_const_int(x lsl y) + | Plsrint -> make_const_int(x lsr y) + | Pasrint -> make_const_int(x asr y) + | Pintcomp cmp -> + let result = match cmp with + Ceq -> x = y + | Cneq -> x <> y + | Clt -> x < y + | Cgt -> x > y + | Cle -> x <= y + | Cge -> x >= y in + make_const_bool result + | _ -> (Uprim(p, args), Value_unknown) + end + | [Value_constptr x] -> + begin match p with + Pidentity -> make_const_ptr x + | Pnot -> make_const_bool(x = 0) + | Pisint -> make_const_bool true + | _ -> (Uprim(p, args), Value_unknown) + end + | [Value_constptr x; Value_constptr y] -> + begin match p with + Psequand -> make_const_bool(x <> 0 && y <> 0) + | Psequor -> make_const_bool(x <> 0 || y <> 0) + | _ -> (Uprim(p, args), Value_unknown) + end + | _ -> + (Uprim(p, args), Value_unknown) + +let simplif_prim p (args, approxs as args_approxs) = + if List.for_all is_pure_clambda args + then simplif_prim_pure p args_approxs + else (Uprim(p, args), Value_unknown) + +(* Substitute variables in a [ulambda] term (a body of an inlined function) + and perform some more simplifications on integer primitives. + Also perform alpha-conversion on let-bound identifiers to avoid + clashes with locally-generated identifiers. + The variables must not be assigned in the term. + This is used to substitute "trivial" arguments for parameters + during inline expansion. *) + +let approx_ulam = function + Uconst(Const_base(Const_int n)) -> Value_integer n + | Uconst(Const_base(Const_char c)) -> Value_integer(Char.code c) + | Uconst(Const_pointer n) -> Value_constptr n + | _ -> Value_unknown + +let rec substitute sb ulam = + match ulam with + Uvar v -> + begin try Tbl.find v sb with Not_found -> ulam end + | Uconst cst -> ulam + | Udirect_apply(lbl, args) -> + Udirect_apply(lbl, List.map (substitute sb) args) + | Ugeneric_apply(fn, args) -> + Ugeneric_apply(substitute sb fn, List.map (substitute sb) args) + | Uclosure(defs, env) -> + (* never present in an inlined function body; painful to get right *) + assert false + | Uoffset(u, ofs) -> Uoffset(substitute sb u, ofs) + | Ulet(id, u1, u2) -> + let id' = Ident.rename id in + Ulet(id', substitute sb u1, substitute (Tbl.add id (Uvar id') sb) u2) + | Uletrec(bindings, body) -> + (* never present in an inlined function body; painful to get right *) + assert false + | Uprim(p, args) -> + let sargs = List.map (substitute sb) args in + let (res, _) = simplif_prim p (sargs, List.map approx_ulam sargs) in + res + | Uswitch(arg, sw) -> + Uswitch(substitute sb arg, + { sw with + us_actions_consts = + Array.map (substitute sb) sw.us_actions_consts; + us_actions_blocks = + Array.map (substitute sb) sw.us_actions_blocks; + }) + | Ustaticfail (nfail, args) -> + Ustaticfail (nfail, List.map (substitute sb) args) + | Ucatch(nfail, ids, u1, u2) -> + Ucatch(nfail, ids, substitute sb u1, substitute sb u2) + | Utrywith(u1, id, u2) -> + let id' = Ident.rename id in + Utrywith(substitute sb u1, id', substitute (Tbl.add id (Uvar id') sb) u2) + | Uifthenelse(u1, u2, u3) -> + begin match substitute sb u1 with + Uconst(Const_pointer n) -> + if n <> 0 then substitute sb u2 else substitute sb u3 + | su1 -> + Uifthenelse(su1, substitute sb u2, substitute sb u3) + end + | Usequence(u1, u2) -> Usequence(substitute sb u1, substitute sb u2) + | Uwhile(u1, u2) -> Uwhile(substitute sb u1, substitute sb u2) + | Ufor(id, u1, u2, dir, u3) -> + let id' = Ident.rename id in + Ufor(id', substitute sb u1, substitute sb u2, dir, + substitute (Tbl.add id (Uvar id') sb) u3) + | Uassign(id, u) -> + let id' = + try + match Tbl.find id sb with Uvar i -> i | _ -> assert false + with Not_found -> + id in + Uassign(id', substitute sb u) + | Usend(u1, u2, ul) -> + Usend(substitute sb u1, substitute sb u2, List.map (substitute sb) ul) + +(* Perform an inline expansion *) + +let is_simple_argument = function + Uvar _ -> true + | Uconst(Const_base(Const_int _ | Const_char _ | Const_float _ | + Const_int32 _ | Const_int64 _ | Const_nativeint _)) -> + true + | Uconst(Const_pointer _) -> true + | _ -> false + +let no_effects = function + Uclosure _ -> true + | Uconst(Const_base(Const_string _)) -> true + | u -> is_simple_argument u + +let rec bind_params subst params args body = + match (params, args) with + ([], []) -> substitute subst body + | (p1 :: pl, a1 :: al) -> + if is_simple_argument a1 then + bind_params (Tbl.add p1 a1 subst) pl al body + else begin + let p1' = Ident.rename p1 in + let body' = bind_params (Tbl.add p1 (Uvar p1') subst) pl al body in + if occurs_var p1 body then Ulet(p1', a1, body') + else if no_effects a1 then body' + else Usequence(a1, body') + end + | (_, _) -> assert false + +(* Check if a lambda term is ``pure'', + that is without side-effects *and* not containing function definitions *) + +let rec is_pure = function + Lvar v -> true + | Lconst cst -> true + | Lprim((Psetglobal _ | Psetfield _ | Psetfloatfield _ | + Pccall _ | Praise | Poffsetref _ | Pstringsetu | Pstringsets | + Parraysetu _ | Parraysets _), _) -> false + | Lprim(p, args) -> List.for_all is_pure args + | _ -> false + +(* Generate a direct application *) + +let direct_apply fundesc funct ufunct uargs = + let app_args = + if fundesc.fun_closed then uargs else uargs @ [ufunct] in + let app = + match fundesc.fun_inline with + None -> Udirect_apply(fundesc.fun_label, app_args) + | Some(params, body) -> bind_params Tbl.empty params app_args body in + (* If ufunct can contain side-effects or function definitions, + we must make sure that it is evaluated exactly once. + If the function is not closed, we evaluate ufunct as part of the + arguments. + If the function is closed, we force the evaluation of ufunct first. *) + if not fundesc.fun_closed || is_pure funct + then app + else Usequence(ufunct, app) + +(* Add [Value_integer] or [Value_constptr] info to the approximation + of an application *) + +let strengthen_approx appl approx = + match approx_ulam appl with + (Value_integer _ | Value_constptr _) as intapprox -> intapprox + | _ -> approx + +(* If a term has approximation Value_integer or Value_constptr and is pure, + replace it by an integer constant *) + +let check_constant_result lam ulam approx = + match approx with + Value_integer n when is_pure lam -> make_const_int n + | Value_constptr n when is_pure lam -> make_const_ptr n + | _ -> (ulam, approx) + +(* Evaluate an expression with known value for its side effects only, + or discard it if it's pure *) + +let sequence_constant_expr lam ulam1 (ulam2, approx2 as res2) = + if is_pure lam then res2 else (Usequence(ulam1, ulam2), approx2) + +(* Maintain the approximation of the global structure being defined *) + +let global_approx = ref([||] : value_approximation array) + +(* Maintain the nesting depth for functions *) + +let function_nesting_depth = ref 0 +let excessive_function_nesting_depth = 5 + +(* Uncurry an expression and explicitate closures. + Also return the approximation of the expression. + The approximation environment [fenv] maps idents to approximations. + Idents not bound in [fenv] approximate to [Value_unknown]. + The closure environment [cenv] maps idents to [ulambda] terms. + It is used to substitute environment accesses for free identifiers. *) + +let close_approx_var fenv cenv id = + let approx = try Tbl.find id fenv with Not_found -> Value_unknown in + match approx with + Value_integer n -> + make_const_int n + | Value_constptr n -> + make_const_ptr n + | approx -> + let subst = try Tbl.find id cenv with Not_found -> Uvar id in + (subst, approx) + +let close_var fenv cenv id = + let (ulam, app) = close_approx_var fenv cenv id in ulam + +exception Found of int + +let rec close fenv cenv = function + Lvar id -> + close_approx_var fenv cenv id + | Lconst cst -> + begin match cst with + Const_base(Const_int n) -> (Uconst cst, Value_integer n) + | Const_base(Const_char c) -> (Uconst cst, Value_integer(Char.code c)) + | Const_pointer n -> (Uconst cst, Value_constptr n) + | _ -> (Uconst cst, Value_unknown) + end + | Lfunction(kind, params, body) as funct -> + close_one_function fenv cenv (Ident.create "fun") funct + | Lapply(funct, args) -> + let nargs = List.length args in + begin match (close fenv cenv funct, close_list fenv cenv args) with + ((ufunct, Value_closure(fundesc, approx_res)), + [Uprim(Pmakeblock(_, _), uargs)]) + when List.length uargs = - fundesc.fun_arity -> + let app = direct_apply fundesc funct ufunct uargs in + (app, strengthen_approx app approx_res) + | ((ufunct, Value_closure(fundesc, approx_res)), uargs) + when nargs = fundesc.fun_arity -> + let app = direct_apply fundesc funct ufunct uargs in + (app, strengthen_approx app approx_res) + | ((ufunct, Value_closure(fundesc, approx_res)), uargs) + when fundesc.fun_arity > 0 && nargs > fundesc.fun_arity -> + let (first_args, rem_args) = split_list fundesc.fun_arity uargs in + (Ugeneric_apply(direct_apply fundesc funct ufunct first_args, + rem_args), + Value_unknown) + | ((ufunct, _), uargs) -> + (Ugeneric_apply(ufunct, uargs), Value_unknown) + end + | Lsend(met, obj, args) -> + let (umet, _) = close fenv cenv met in + let (uobj, _) = close fenv cenv obj in + (Usend(umet, uobj, close_list fenv cenv args), Value_unknown) + | Llet(str, id, lam, body) -> + let (ulam, alam) = close_named fenv cenv id lam in + begin match (str, alam) with + (Variable, _) -> + let (ubody, abody) = close fenv cenv body in + (Ulet(id, ulam, ubody), abody) + | (_, (Value_integer _ | Value_constptr _)) + when str = Alias || is_pure lam -> + close (Tbl.add id alam fenv) cenv body + | (_, _) -> + let (ubody, abody) = close (Tbl.add id alam fenv) cenv body in + (Ulet(id, ulam, ubody), abody) + end + | Lletrec(defs, body) -> + if List.for_all + (function (id, Lfunction(_, _, _)) -> true | _ -> false) + defs + then begin + (* Simple case: only function definitions *) + let (clos, infos) = close_functions fenv cenv defs in + let clos_ident = Ident.create "clos" in + let fenv_body = + List.fold_right + (fun (id, pos, approx) fenv -> Tbl.add id approx fenv) + infos fenv in + let (ubody, approx) = close fenv_body cenv body in + (Ulet(clos_ident, clos, + List.fold_right + (fun (id, pos, approx) body -> + Ulet(id, Uoffset(Uvar clos_ident, pos), body)) + infos ubody), + approx) + end else begin + (* General case: recursive definition of values *) + let rec clos_defs = function + [] -> ([], fenv) + | (id, lam) :: rem -> + let (udefs, fenv_body) = clos_defs rem in + let (ulam, approx) = close fenv cenv lam in + ((id, ulam) :: udefs, Tbl.add id approx fenv_body) in + let (udefs, fenv_body) = clos_defs defs in + let (ubody, approx) = close fenv_body cenv body in + (Uletrec(udefs, ubody), approx) + end + | Lprim(Pgetglobal id, []) as lam -> + check_constant_result lam + (Uprim(Pgetglobal id, [])) (Compilenv.global_approx id) + | Lprim(Pmakeblock(tag, mut) as prim, lams) -> + let (ulams, approxs) = List.split (List.map (close fenv cenv) lams) in + (Uprim(prim, ulams), + begin match mut with + Immutable -> Value_tuple(Array.of_list approxs) + | Mutable -> Value_unknown + end) + | Lprim(Pfield n, [lam]) -> + let (ulam, approx) = close fenv cenv lam in + let fieldapprox = + match approx with + Value_tuple a when n < Array.length a -> a.(n) + | _ -> Value_unknown in + check_constant_result lam (Uprim(Pfield n, [ulam])) fieldapprox + | Lprim(Psetfield(n, _), [Lprim(Pgetglobal id, []); lam]) -> + let (ulam, approx) = close fenv cenv lam in + (!global_approx).(n) <- approx; + (Uprim(Psetfield(n, false), [Uprim(Pgetglobal id, []); ulam]), + Value_unknown) + | Lprim(p, args) -> + simplif_prim p (close_list_approx fenv cenv args) + | Lswitch(arg, sw) as l -> +(* NB: failaction might get copied, thus it should be some Lstaticraise *) + let (uarg, _) = close fenv cenv arg in + let const_index, const_actions = + close_switch fenv cenv sw.sw_consts sw.sw_numconsts sw.sw_failaction + and block_index, block_actions = + close_switch fenv cenv sw.sw_blocks sw.sw_numblocks sw.sw_failaction in + (Uswitch(uarg, + {us_index_consts = const_index; + us_actions_consts = const_actions; + us_index_blocks = block_index; + us_actions_blocks = block_actions}), + Value_unknown) + | Lstaticraise (i, args) -> + (Ustaticfail (i, close_list fenv cenv args), Value_unknown) + | Lstaticcatch(body, (i, vars), handler) -> + let (ubody, _) = close fenv cenv body in + let (uhandler, _) = close fenv cenv handler in + (Ucatch(i, vars, ubody, uhandler), Value_unknown) + | Ltrywith(body, id, handler) -> + let (ubody, _) = close fenv cenv body in + let (uhandler, _) = close fenv cenv handler in + (Utrywith(ubody, id, uhandler), Value_unknown) + | Lifthenelse(arg, ifso, ifnot) -> + begin match close fenv cenv arg with + (uarg, Value_constptr n) -> + sequence_constant_expr arg uarg + (close fenv cenv (if n = 0 then ifnot else ifso)) + | (uarg, _ ) -> + let (uifso, _) = close fenv cenv ifso in + let (uifnot, _) = close fenv cenv ifnot in + (Uifthenelse(uarg, uifso, uifnot), Value_unknown) + end + | Lsequence(lam1, lam2) -> + let (ulam1, _) = close fenv cenv lam1 in + let (ulam2, approx) = close fenv cenv lam2 in + (Usequence(ulam1, ulam2), approx) + | Lwhile(cond, body) -> + let (ucond, _) = close fenv cenv cond in + let (ubody, _) = close fenv cenv body in + (Uwhile(ucond, ubody), Value_unknown) + | Lfor(id, lo, hi, dir, body) -> + let (ulo, _) = close fenv cenv lo in + let (uhi, _) = close fenv cenv hi in + let (ubody, _) = close fenv cenv body in + (Ufor(id, ulo, uhi, dir, ubody), Value_unknown) + | Lassign(id, lam) -> + let (ulam, _) = close fenv cenv lam in + (Uassign(id, ulam), Value_unknown) + | Levent _ | Lifused _ -> assert false + +and close_list fenv cenv = function + [] -> [] + | lam :: rem -> + let (ulam, _) = close fenv cenv lam in + ulam :: close_list fenv cenv rem + +and close_list_approx fenv cenv = function + [] -> ([], []) + | lam :: rem -> + let (ulam, approx) = close fenv cenv lam in + let (ulams, approxs) = close_list_approx fenv cenv rem in + (ulam :: ulams, approx :: approxs) + +and close_named fenv cenv id = function + Lfunction(kind, params, body) as funct -> + close_one_function fenv cenv id funct + | lam -> + close fenv cenv lam + +(* Build a shared closure for a set of mutually recursive functions *) + +and close_functions fenv cenv fun_defs = + (* Update and check nesting depth *) + incr function_nesting_depth; + let initially_closed = + !function_nesting_depth < excessive_function_nesting_depth in + (* Determine the free variables of the functions *) + let fv = + IdentSet.elements (free_variables (Lletrec(fun_defs, lambda_unit))) in + (* Build the function descriptors for the functions. + Initially all functions are assumed not to need their environment + parameter. *) + let uncurried_defs = + List.map + (function + (id, (Lfunction(kind, params, body) as def)) -> + let label = + Compilenv.current_unit_name() ^ "__" ^ Ident.unique_name id in + let arity = List.length params in + let fundesc = + {fun_label = label; + fun_arity = (if kind = Tupled then -arity else arity); + fun_closed = initially_closed; + fun_inline = None } in + (id, params, body, fundesc) + | (_, _) -> fatal_error "Closure.close_functions") + fun_defs in + (* Build an approximate fenv for compiling the functions *) + let fenv_rec = + List.fold_right + (fun (id, params, body, fundesc) fenv -> + Tbl.add id (Value_closure(fundesc, Value_unknown)) fenv) + uncurried_defs fenv in + (* Determine the offsets of each function's closure in the shared block *) + let env_pos = ref (-1) in + let clos_offsets = + List.map + (fun (id, params, body, fundesc) -> + let pos = !env_pos + 1 in + env_pos := !env_pos + 1 + (if fundesc.fun_arity <> 1 then 3 else 2); + pos) + uncurried_defs in + let fv_pos = !env_pos in + (* This reference will be set to false if the hypothesis that a function + does not use its environment parameter is invalidated. *) + let useless_env = ref initially_closed in + (* Translate each function definition *) + let clos_fundef (id, params, body, fundesc) env_pos = + let env_param = Ident.create "env" in + let cenv_fv = + build_closure_env env_param (fv_pos - env_pos) fv in + let cenv_body = + List.fold_right2 + (fun (id, params, arity, body) pos env -> + Tbl.add id (Uoffset(Uvar env_param, pos - env_pos)) env) + uncurried_defs clos_offsets cenv_fv in + let (ubody, approx) = close fenv_rec cenv_body body in + if !useless_env && occurs_var env_param ubody then useless_env := false; + let fun_params = if !useless_env then params else params @ [env_param] in + ((fundesc.fun_label, fundesc.fun_arity, fun_params, ubody), + (id, env_pos, Value_closure(fundesc, approx))) in + (* Translate all function definitions. *) + let clos_info_list = + if initially_closed then begin + let cl = List.map2 clos_fundef uncurried_defs clos_offsets in + (* If the hypothesis that the environment parameters are useless has been + invalidated, then set [fun_closed] to false in all descriptions and + recompile *) + if !useless_env then cl else begin + List.iter + (fun (id, params, body, fundesc) -> fundesc.fun_closed <- false) + uncurried_defs; + List.map2 clos_fundef uncurried_defs clos_offsets + end + end else + (* Excessive closure nesting: assume environment parameter is used *) + List.map2 clos_fundef uncurried_defs clos_offsets + in + (* Update nesting depth *) + decr function_nesting_depth; + (* Return the Uclosure node and the list of all identifiers defined, + with offsets and approximations. *) + let (clos, infos) = List.split clos_info_list in + (Uclosure(clos, List.map (close_var fenv cenv) fv), infos) + +(* Same, for one non-recursive function *) + +and close_one_function fenv cenv id funct = + match close_functions fenv cenv [id, funct] with + ((Uclosure([_, _, params, body], _) as clos), + [_, _, (Value_closure(fundesc, _) as approx)]) -> + (* See if the function can be inlined *) + if lambda_smaller body (!Clflags.inline_threshold + List.length params) + then fundesc.fun_inline <- Some(params, body); + (clos, approx) + | _ -> fatal_error "Closure.close_one_function" + +(* Close a switch *) + +and close_switch fenv cenv cases num_keys default = + let index = Array.create num_keys 0 + and store = mk_store Pervasives.(=) in + + (* First default case *) + begin match default with + | Some def when List.length cases < num_keys -> + ignore (store.act_store def) + | _ -> () + end ; + (* Then all other cases *) + List.iter + (fun (key,lam) -> + index.(key) <- store.act_store lam) + cases ; + (* Compile action *) + let actions = + Array.map + (fun lam -> + let ulam,_ = close fenv cenv lam in + ulam) + (store.act_get ()) in + match actions with + | [| |] -> [| |], [| |] (* May happen when default is None *) + | _ -> index, actions + + +(* The entry point *) + +let intro size lam = + function_nesting_depth := 0; + global_approx := Array.create size Value_unknown; + Compilenv.set_global_approx(Value_tuple !global_approx); + let (ulam, approx) = close Tbl.empty Tbl.empty lam in + global_approx := [||]; + ulam diff --git a/asmcomp/closure.mli b/asmcomp/closure.mli new file mode 100644 index 00000000..eac7ce39 --- /dev/null +++ b/asmcomp/closure.mli @@ -0,0 +1,18 @@ +(***********************************************************************) +(* *) +(* 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: closure.mli,v 1.5 1999/11/17 18:56:30 xleroy Exp $ *) + +(* Introduction of closures, uncurrying, recognition of direct calls *) + +val intro: int -> Lambda.lambda -> Clambda.ulambda + diff --git a/asmcomp/cmm.ml b/asmcomp/cmm.ml new file mode 100644 index 00000000..6ec37fd4 --- /dev/null +++ b/asmcomp/cmm.ml @@ -0,0 +1,132 @@ +(***********************************************************************) +(* *) +(* 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: cmm.ml,v 1.20 2002/11/24 15:55:24 xleroy Exp $ *) + +type machtype_component = + Addr + | Int + | Float + +type machtype = machtype_component array + +let typ_void = ([||] : machtype_component array) +let typ_addr = [|Addr|] +let typ_int = [|Int|] +let typ_float = [|Float|] + +let size_component = function + Addr -> Arch.size_addr + | Int -> Arch.size_int + | Float -> Arch.size_float + +let size_machtype mty = + let size = ref 0 in + for i = 0 to Array.length mty - 1 do + size := !size + size_component mty.(i) + done; + !size + +type comparison = + Ceq + | Cne + | Clt + | Cle + | Cgt + | Cge + +let negate_comparison = function + Ceq -> Cne | Cne -> Ceq + | Clt -> Cge | Cle -> Cgt + | Cgt -> Cle | Cge -> Clt + +let swap_comparison = function + Ceq -> Ceq | Cne -> Cne + | Clt -> Cgt | Cle -> Cge + | Cgt -> Clt | Cge -> Cle + +type memory_chunk = + Byte_unsigned + | Byte_signed + | Sixteen_unsigned + | Sixteen_signed + | Thirtytwo_unsigned + | Thirtytwo_signed + | Word + | Single + | Double + | Double_u + +type operation = + Capply of machtype + | Cextcall of string * machtype * bool + | Cload of memory_chunk + | Calloc + | Cstore of memory_chunk + | Caddi | Csubi | Cmuli | Cdivi | Cmodi + | Cand | Cor | Cxor | Clsl | Clsr | Casr + | Ccmpi of comparison + | Cadda | Csuba + | Ccmpa of comparison + | Cnegf | Cabsf + | Caddf | Csubf | Cmulf | Cdivf + | Cfloatofint | Cintoffloat + | Ccmpf of comparison + | Craise + | Ccheckbound + +type expression = + Cconst_int of int + | Cconst_natint of nativeint + | Cconst_float of string + | Cconst_symbol of string + | Cconst_pointer of int + | Cconst_natpointer of nativeint + | Cvar of Ident.t + | Clet of Ident.t * expression * expression + | Cassign of Ident.t * expression + | Ctuple of expression list + | Cop of operation * expression list + | Csequence of expression * expression + | Cifthenelse of expression * expression * expression + | Cswitch of expression * int array * expression array + | Cloop of expression + | Ccatch of int * Ident.t list * expression * expression + | Cexit of int * expression list + | Ctrywith of expression * Ident.t * expression + +type fundecl = + { fun_name: string; + fun_args: (Ident.t * machtype) list; + fun_body: expression; + fun_fast: bool } + +type data_item = + Cdefine_symbol of string + | Cdefine_label of int + | Cglobal_symbol of string + | Cint8 of int + | Cint16 of int + | Cint32 of nativeint + | Cint of nativeint + | Csingle of string + | Cdouble of string + | Csymbol_address of string + | Clabel_address of int + | Cstring of string + | Cskip of int + | Calign of int + +type phrase = + Cfunction of fundecl + | Cdata of data_item list + diff --git a/asmcomp/cmm.mli b/asmcomp/cmm.mli new file mode 100644 index 00000000..6568d1a2 --- /dev/null +++ b/asmcomp/cmm.mli @@ -0,0 +1,118 @@ +(***********************************************************************) +(* *) +(* 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: cmm.mli,v 1.20 2002/11/24 15:55:24 xleroy Exp $ *) + +(* Second intermediate language (machine independent) *) + +type machtype_component = + Addr + | Int + | Float + +type machtype = machtype_component array + +val typ_void: machtype +val typ_addr: machtype +val typ_int: machtype +val typ_float: machtype + +val size_component: machtype_component -> int +val size_machtype: machtype -> int + +type comparison = + Ceq + | Cne + | Clt + | Cle + | Cgt + | Cge + +val negate_comparison: comparison -> comparison +val swap_comparison: comparison -> comparison + +type memory_chunk = + Byte_unsigned + | Byte_signed + | Sixteen_unsigned + | Sixteen_signed + | Thirtytwo_unsigned + | Thirtytwo_signed + | Word + | Single + | Double (* 64-bit-aligned 64-bit float *) + | Double_u (* word-aligned 64-bit float *) + +type operation = + Capply of machtype + | Cextcall of string * machtype * bool + | Cload of memory_chunk + | Calloc + | Cstore of memory_chunk + | Caddi | Csubi | Cmuli | Cdivi | Cmodi + | Cand | Cor | Cxor | Clsl | Clsr | Casr + | Ccmpi of comparison + | Cadda | Csuba + | Ccmpa of comparison + | Cnegf | Cabsf + | Caddf | Csubf | Cmulf | Cdivf + | Cfloatofint | Cintoffloat + | Ccmpf of comparison + | Craise + | Ccheckbound + +type expression = + Cconst_int of int + | Cconst_natint of nativeint + | Cconst_float of string + | Cconst_symbol of string + | Cconst_pointer of int + | Cconst_natpointer of nativeint + | Cvar of Ident.t + | Clet of Ident.t * expression * expression + | Cassign of Ident.t * expression + | Ctuple of expression list + | Cop of operation * expression list + | Csequence of expression * expression + | Cifthenelse of expression * expression * expression + | Cswitch of expression * int array * expression array + | Cloop of expression + | Ccatch of int * Ident.t list * expression * expression + | Cexit of int * expression list + | Ctrywith of expression * Ident.t * expression + +type fundecl = + { fun_name: string; + fun_args: (Ident.t * machtype) list; + fun_body: expression; + fun_fast: bool } + +type data_item = + Cdefine_symbol of string + | Cdefine_label of int + | Cglobal_symbol of string + | Cint8 of int + | Cint16 of int + | Cint32 of nativeint + | Cint of nativeint + | Csingle of string + | Cdouble of string + | Csymbol_address of string + | Clabel_address of int + | Cstring of string + | Cskip of int + | Calign of int + +type phrase = + Cfunction of fundecl + | Cdata of data_item list + diff --git a/asmcomp/cmmgen.ml b/asmcomp/cmmgen.ml new file mode 100644 index 00000000..519f7d59 --- /dev/null +++ b/asmcomp/cmmgen.ml @@ -0,0 +1,1839 @@ +(***********************************************************************) +(* *) +(* 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: cmmgen.ml,v 1.91 2003/04/25 13:26:55 xleroy Exp $ *) + +(* Translation from closed lambda to C-- *) + +open Misc +open Arch +open Asttypes +open Primitive +open Types +open Lambda +open Clambda +open Cmm + +(* Local binding of complex expressions *) + +let bind name arg fn = + match arg with + Cvar _ | Cconst_int _ | Cconst_natint _ | Cconst_symbol _ + | Cconst_pointer _ | Cconst_natpointer _ -> fn arg + | _ -> let id = Ident.create name in Clet(id, arg, fn (Cvar id)) + +let bind_nonvar name arg fn = + match arg with + Cconst_int _ | Cconst_natint _ | Cconst_symbol _ + | Cconst_pointer _ | Cconst_natpointer _ -> fn arg + | _ -> let id = Ident.create name in Clet(id, arg, fn (Cvar id)) + +(* Block headers. Meaning of the tag field: see stdlib/obj.ml *) + +let float_tag = Cconst_int Obj.double_tag +let floatarray_tag = Cconst_int Obj.double_array_tag + +let block_header tag sz = + Nativeint.add (Nativeint.shift_left (Nativeint.of_int sz) 10) + (Nativeint.of_int tag) +let closure_header sz = block_header Obj.closure_tag sz +let infix_header ofs = block_header Obj.infix_tag ofs +let float_header = block_header Obj.double_tag (size_float / size_addr) +let floatarray_header len = + block_header Obj.double_array_tag (len * size_float / size_addr) +let string_header len = + block_header Obj.string_tag ((len + size_addr) / size_addr) +let boxedint_header = block_header Obj.custom_tag 2 + +let alloc_block_header tag sz = Cconst_natint(block_header tag sz) +let alloc_float_header = Cconst_natint(float_header) +let alloc_floatarray_header len = Cconst_natint(floatarray_header len) +let alloc_closure_header sz = Cconst_natint(closure_header sz) +let alloc_infix_header ofs = Cconst_natint(infix_header ofs) +let alloc_boxedint_header = Cconst_natint(boxedint_header) + +(* Integers *) + +let max_repr_int = max_int asr 1 +let min_repr_int = min_int asr 1 + +let int_const n = + if n <= max_repr_int && n >= min_repr_int + then Cconst_int((n lsl 1) + 1) + else Cconst_natint + (Nativeint.add (Nativeint.shift_left (Nativeint.of_int n) 1) 1n) + +let add_const c n = + if n = 0 then c else Cop(Caddi, [c; Cconst_int n]) + +let incr_int = function + Cconst_int n when n < max_int -> Cconst_int(n+1) + | Cop(Caddi, [c; Cconst_int n]) when n < max_int -> add_const c (n + 1) + | c -> add_const c 1 + +let decr_int = function + Cconst_int n when n > min_int -> Cconst_int(n-1) + | Cop(Caddi, [c; Cconst_int n]) when n > min_int -> add_const c (n - 1) + | c -> add_const c (-1) + +let add_int c1 c2 = + match (c1, c2) with + (Cop(Caddi, [c1; Cconst_int n1]), + Cop(Caddi, [c2; Cconst_int n2])) when no_overflow_add n1 n2 -> + add_const (Cop(Caddi, [c1; c2])) (n1 + n2) + | (Cop(Caddi, [c1; Cconst_int n1]), c2) -> + add_const (Cop(Caddi, [c1; c2])) n1 + | (c1, Cop(Caddi, [c2; Cconst_int n2])) -> + add_const (Cop(Caddi, [c1; c2])) n2 + | (Cconst_int _, _) -> + Cop(Caddi, [c2; c1]) + | (_, _) -> + Cop(Caddi, [c1; c2]) + +let sub_int c1 c2 = + match (c1, c2) with + (Cop(Caddi, [c1; Cconst_int n1]), + Cop(Caddi, [c2; Cconst_int n2])) when no_overflow_sub n1 n2 -> + add_const (Cop(Csubi, [c1; c2])) (n1 - n2) + | (Cop(Caddi, [c1; Cconst_int n1]), c2) -> + add_const (Cop(Csubi, [c1; c2])) n1 + | (c1, Cop(Caddi, [c2; Cconst_int n2])) when n2 <> min_int -> + add_const (Cop(Csubi, [c1; c2])) (-n2) + | (c1, Cconst_int n) when n <> min_int -> + add_const c1 (-n) + | (c1, c2) -> + Cop(Csubi, [c1; c2]) + +let mul_int c1 c2 = + match (c1, c2) with + (Cconst_int 0, _) -> c1 + | (Cconst_int 1, _) -> c2 + | (_, Cconst_int 0) -> c2 + | (_, Cconst_int 1) -> c1 + | (_, _) -> Cop(Cmuli, [c1; c2]) + +let tag_int = function + Cconst_int n -> int_const n + | c -> Cop(Caddi, [Cop(Clsl, [c; Cconst_int 1]); Cconst_int 1]) + +let force_tag_int = function + Cconst_int n -> int_const n + | c -> Cop(Cor, [Cop(Clsl, [c; Cconst_int 1]); Cconst_int 1]) + +let untag_int = function + Cconst_int n -> Cconst_int(n asr 1) + | Cop(Caddi, [Cop(Clsl, [c; Cconst_int 1]); Cconst_int 1]) -> c + | Cop(Cor, [Cop(Casr, [c; Cconst_int n]); Cconst_int 1]) + when n > 0 && n < size_int * 8 -> + Cop(Casr, [c; Cconst_int (n+1)]) + | Cop(Cor, [Cop(Clsr, [c; Cconst_int n]); Cconst_int 1]) + when n > 0 && n < size_int * 8 -> + Cop(Clsr, [c; Cconst_int (n+1)]) + | Cop(Cor, [c; Cconst_int 1]) -> Cop(Casr, [c; Cconst_int 1]) + | c -> Cop(Casr, [c; Cconst_int 1]) + +let lsl_int c1 c2 = + match (c1, c2) with + (Cop(Clsl, [c; Cconst_int n1]), Cconst_int n2) + when n1 > 0 && n2 > 0 && n1 + n2 < size_int * 8 -> + Cop(Clsl, [c; Cconst_int (n1 + n2)]) + | (_, _) -> + Cop(Clsl, [c1; c2]) + +let ignore_low_bit_int = function + Cop(Caddi, [(Cop(Clsl, [_; Cconst_int 1]) as c); Cconst_int 1]) -> c + | Cop(Cor, [c; Cconst_int 1]) -> c + | c -> c + +(* Bool *) + +let test_bool = function + Cop(Caddi, [Cop(Clsl, [c; Cconst_int 1]); Cconst_int 1]) -> c + | Cop(Clsl, [c; Cconst_int 1]) -> c + | c -> Cop(Ccmpi Cne, [c; Cconst_int 1]) + +(* Float *) + +let box_float c = Cop(Calloc, [alloc_float_header; c]) + +let unbox_float = function + Cop(Calloc, [header; c]) -> c + | c -> Cop(Cload Double_u, [c]) + +(* Complex *) + +let box_complex c_re c_im = + Cop(Calloc, [alloc_floatarray_header 2; c_re; c_im]) + +let complex_re c = Cop(Cload Double_u, [c]) +let complex_im c = Cop(Cload Double_u, + [Cop(Cadda, [c; Cconst_int size_float])]) + +(* Unit *) + +let return_unit c = Csequence(c, Cconst_pointer 1) + +let rec remove_unit = function + Cconst_pointer 1 -> Ctuple [] + | Csequence(c, Cconst_pointer 1) -> c + | Csequence(c1, c2) -> + Csequence(c1, remove_unit c2) + | Cifthenelse(cond, ifso, ifnot) -> + Cifthenelse(cond, remove_unit ifso, remove_unit ifnot) + | Cswitch(sel, index, cases) -> + Cswitch(sel, index, Array.map remove_unit cases) + | Ccatch(io, ids, body, handler) -> + Ccatch(io, ids, remove_unit body, remove_unit handler) + | Ctrywith(body, exn, handler) -> + Ctrywith(remove_unit body, exn, remove_unit handler) + | Clet(id, c1, c2) -> + Clet(id, c1, remove_unit c2) + | Cop(Capply mty, args) -> + Cop(Capply typ_void, args) + | Cop(Cextcall(proc, mty, alloc), args) -> + Cop(Cextcall(proc, typ_void, alloc), args) + | Cexit (_,_) as c -> c + | Ctuple [] as c -> c + | c -> Csequence(c, Ctuple []) + +(* Access to block fields *) + +let field_address ptr n = + if n = 0 + then ptr + else Cop(Cadda, [ptr; Cconst_int(n * size_addr)]) + +let get_field ptr n = + Cop(Cload Word, [field_address ptr n]) + +let set_field ptr n newval = + Cop(Cstore Word, [field_address ptr n; newval]) + +let header ptr = + Cop(Cload Word, [Cop(Cadda, [ptr; Cconst_int(-size_int)])]) + +let tag_offset = + if big_endian then -1 else -size_int + +let get_tag ptr = + if Proc.word_addressed then (* If byte loads are slow *) + Cop(Cand, [header ptr; Cconst_int 255]) + else (* If byte loads are efficient *) + Cop(Cload Byte_unsigned, + [Cop(Cadda, [ptr; Cconst_int(tag_offset)])]) + +(* Array indexing *) + +let log2_size_addr = Misc.log2 size_addr +let log2_size_float = Misc.log2 size_float + +let wordsize_shift = 9 +let numfloat_shift = 9 + log2_size_float - log2_size_addr + +let is_addr_array_hdr hdr = + Cop(Ccmpi Cne, [Cop(Cand, [hdr; Cconst_int 255]); floatarray_tag]) + +let is_addr_array_ptr ptr = + Cop(Ccmpi Cne, [get_tag ptr; floatarray_tag]) + +let addr_array_length hdr = Cop(Clsr, [hdr; Cconst_int wordsize_shift]) +let float_array_length hdr = Cop(Clsr, [hdr; Cconst_int numfloat_shift]) + +let lsl_const c n = + Cop(Clsl, [c; Cconst_int n]) + +let array_indexing log2size ptr ofs = + match ofs with + Cconst_int n -> + let i = n asr 1 in + if i = 0 then ptr else Cop(Cadda, [ptr; Cconst_int(i lsl log2size)]) + | Cop(Caddi, [Cop(Clsl, [c; Cconst_int 1]); Cconst_int 1]) -> + Cop(Cadda, [ptr; lsl_const c log2size]) + | Cop(Caddi, [c; Cconst_int n]) -> + Cop(Cadda, [Cop(Cadda, [ptr; lsl_const c (log2size - 1)]); + Cconst_int((n-1) lsl (log2size - 1))]) + | _ -> + Cop(Cadda, [Cop(Cadda, [ptr; lsl_const ofs (log2size - 1)]); + Cconst_int((-1) lsl (log2size - 1))]) + +let addr_array_ref arr ofs = + Cop(Cload Word, [array_indexing log2_size_addr arr ofs]) +let unboxed_float_array_ref arr ofs = + Cop(Cload Double_u, [array_indexing log2_size_float arr ofs]) +let float_array_ref arr ofs = + box_float(unboxed_float_array_ref arr ofs) + +let addr_array_set arr ofs newval = + Cop(Cextcall("modify", typ_void, false), + [array_indexing log2_size_addr arr ofs; newval]) +let int_array_set arr ofs newval = + Cop(Cstore Word, [array_indexing log2_size_addr arr ofs; newval]) +let float_array_set arr ofs newval = + Cop(Cstore Double_u, [array_indexing log2_size_float arr ofs; newval]) + +(* String length *) + +let string_length exp = + bind "str" exp (fun str -> + let tmp_var = Ident.create "tmp" in + Clet(tmp_var, + Cop(Csubi, + [Cop(Clsl, + [Cop(Clsr, [header str; Cconst_int 10]); + Cconst_int log2_size_addr]); + Cconst_int 1]), + Cop(Csubi, + [Cvar tmp_var; + Cop(Cload Byte_unsigned, + [Cop(Cadda, [str; Cvar tmp_var])])]))) + +(* Message sending *) + +let lookup_label obj lab = + bind "lab" lab (fun lab -> + let table = Cop (Cload Word, [obj]) in + let buck_index = Cop(Clsr, [lab; Cconst_int 16]) in + let bucket = Cop(Cload Word, [Cop (Cadda, [table; buck_index])]) in + let item_index = Cop(Cand, [lab; Cconst_int (255 * size_addr)]) in + Cop (Cload Word, [Cop (Cadda, [bucket; item_index])])) + +(* Allocation *) + +let make_alloc_generic set_fn tag wordsize args = + if wordsize <= Config.max_young_wosize then + Cop(Calloc, Cconst_natint(block_header tag wordsize) :: args) + else begin + let id = Ident.create "alloc" in + let rec fill_fields idx = function + [] -> Cvar id + | e1::el -> Csequence(set_fn (Cvar id) (Cconst_int idx) e1, + fill_fields (idx + 2) el) in + Clet(id, + Cop(Cextcall("alloc", typ_addr, true), + [Cconst_int wordsize; Cconst_int tag]), + fill_fields 1 args) + end + +let make_alloc tag args = + make_alloc_generic addr_array_set tag (List.length args) args +let make_float_alloc tag args = + make_alloc_generic float_array_set tag + (List.length args * size_float / size_addr) args + +(* To compile "let rec" over values *) + +let fundecls_size fundecls = + let sz = ref (-1) in + List.iter + (fun (label, arity, params, body) -> + sz := !sz + 1 + (if arity = 1 then 2 else 3)) + fundecls; + !sz + +type rhs_kind = + | RHS_block of int + | RHS_nonrec +;; +let rec expr_size = function + | Uclosure(fundecls, clos_vars) -> + RHS_block (fundecls_size fundecls + List.length clos_vars) + | Ulet(id, exp, body) -> + expr_size body + | Uletrec(bindings, body) -> + expr_size body + | Uprim(Pmakeblock(tag, mut), args) -> + RHS_block (List.length args) + | Uprim(Pmakearray(Paddrarray | Pintarray), args) -> + RHS_block (List.length args) + | Usequence(exp, exp') -> + expr_size exp' + | _ -> RHS_nonrec + +(* Record application and currying functions *) + +let apply_function n = + Compilenv.need_apply_fun n; "caml_apply" ^ string_of_int n +let curry_function n = + Compilenv.need_curry_fun n; + if n >= 0 + then "caml_curry" ^ string_of_int n + else "caml_tuplify" ^ string_of_int (-n) + +(* Comparisons *) + +let transl_comparison = function + Lambda.Ceq -> Ceq + | Lambda.Cneq -> Cne + | Lambda.Cge -> Cge + | Lambda.Cgt -> Cgt + | Lambda.Cle -> Cle + | Lambda.Clt -> Clt + +(* Translate structured constants *) + +let const_label = ref 0 + +let new_const_label () = + incr const_label; + !const_label + +let new_const_symbol () = + incr const_label; + Compilenv.current_unit_name () ^ "__" ^ string_of_int !const_label + +let structured_constants = ref ([] : (string * structured_constant) list) + +let transl_constant = function + Const_base(Const_int n) -> + int_const n + | Const_base(Const_char c) -> + Cconst_int(((Char.code c) lsl 1) + 1) + | Const_pointer n -> + if n <= max_repr_int && n >= min_repr_int + then Cconst_pointer((n lsl 1) + 1) + else Cconst_natpointer + (Nativeint.add (Nativeint.shift_left (Nativeint.of_int n) 1) 1n) + | cst -> + let lbl = new_const_symbol() in + structured_constants := (lbl, cst) :: !structured_constants; + Cconst_symbol lbl + +(* Translate constant closures *) + +let constant_closures = + ref ([] : (string * (string * int * Ident.t list * ulambda) list) list) + +(* Boxed integers *) + +let box_int_constant bi n = + match bi with + Pnativeint -> Const_base(Const_nativeint n) + | Pint32 -> Const_base(Const_int32 (Nativeint.to_int32 n)) + | Pint64 -> Const_base(Const_int64 (Int64.of_nativeint n)) + +let operations_boxed_int bi = + match bi with + Pnativeint -> "nativeint_ops" + | Pint32 -> "int32_ops" + | Pint64 -> "int64_ops" + +let box_int bi arg = + match arg with + Cconst_int n -> + transl_constant (box_int_constant bi (Nativeint.of_int n)) + | Cconst_natint n -> + transl_constant (box_int_constant bi n) + | _ -> + let arg' = + if bi = Pint32 && size_int = 8 && big_endian + then Cop(Clsl, [arg; Cconst_int 32]) + else arg in + Cop(Calloc, [alloc_boxedint_header; + Cconst_symbol(operations_boxed_int bi); + arg]) + +let unbox_int bi arg = + match arg with + Cop(Calloc, [hdr; ops; Cop(Clsl, [contents; Cconst_int 32])]) + when bi = Pint32 && size_int = 8 && big_endian -> + (* Force sign-extension of low 32 bits *) + Cop(Casr, [Cop(Clsl, [contents; Cconst_int 32]); Cconst_int 32]) + | Cop(Calloc, [hdr; ops; contents]) + when bi = Pint32 && size_int = 8 && not big_endian -> + (* Force sign-extension of low 32 bits *) + Cop(Casr, [Cop(Clsl, [contents; Cconst_int 32]); Cconst_int 32]) + | Cop(Calloc, [hdr; ops; contents]) -> + contents + | _ -> + Cop(Cload(if bi = Pint32 then Thirtytwo_signed else Word), + [Cop(Cadda, [arg; Cconst_int size_addr])]) + +let make_unsigned_int bi arg = + if bi = Pint32 && size_int = 8 + then Cop(Cand, [arg; Cconst_natint 0xFFFFFFFFn]) + else arg + +(* Big arrays *) + +let bigarray_elt_size = function + Pbigarray_unknown -> assert false + | Pbigarray_float32 -> 4 + | Pbigarray_float64 -> 8 + | Pbigarray_sint8 -> 1 + | Pbigarray_uint8 -> 1 + | Pbigarray_sint16 -> 2 + | Pbigarray_uint16 -> 2 + | Pbigarray_int32 -> 4 + | Pbigarray_int64 -> 8 + | Pbigarray_caml_int -> size_int + | Pbigarray_native_int -> size_int + | Pbigarray_complex32 -> 8 + | Pbigarray_complex64 -> 16 + +let bigarray_indexing elt_kind layout b args = + let rec ba_indexing dim_ofs delta_ofs = function + [] -> assert false + | [arg] -> + bind "idx" (untag_int arg) + (fun idx -> + Csequence( + Cop(Ccheckbound, [Cop(Cload Word,[field_address b dim_ofs]); idx]), + idx)) + | arg1 :: argl -> + let rem = ba_indexing (dim_ofs + delta_ofs) delta_ofs argl in + bind "idx" (untag_int arg1) + (fun idx -> + bind "bound" (Cop(Cload Word, [field_address b dim_ofs])) + (fun bound -> + Csequence(Cop(Ccheckbound, [bound; idx]), + add_int (mul_int rem bound) idx))) in + let offset = + match layout with + Pbigarray_unknown_layout -> + assert false + | Pbigarray_c_layout -> + ba_indexing (4 + List.length args) (-1) (List.rev args) + | Pbigarray_fortran_layout -> + ba_indexing 5 1 (List.map (fun idx -> sub_int idx (Cconst_int 2)) args) + and elt_size = + bigarray_elt_size elt_kind in + let byte_offset = + if elt_size = 1 + then offset + else Cop(Clsl, [offset; Cconst_int(log2 elt_size)]) in + Cop(Cadda, [Cop(Cload Word, [field_address b 1]); byte_offset]) + +let bigarray_word_kind = function + Pbigarray_unknown -> assert false + | Pbigarray_float32 -> Single + | Pbigarray_float64 -> Double + | Pbigarray_sint8 -> Byte_signed + | Pbigarray_uint8 -> Byte_unsigned + | Pbigarray_sint16 -> Sixteen_signed + | Pbigarray_uint16 -> Sixteen_unsigned + | Pbigarray_int32 -> Thirtytwo_signed + | Pbigarray_int64 -> Word + | Pbigarray_caml_int -> Word + | Pbigarray_native_int -> Word + | Pbigarray_complex32 -> Single + | Pbigarray_complex64 -> Double + +let bigarray_get elt_kind layout b args = + match elt_kind with + Pbigarray_complex32 | Pbigarray_complex64 -> + let kind = bigarray_word_kind elt_kind in + let sz = bigarray_elt_size elt_kind / 2 in + bind "addr" (bigarray_indexing elt_kind layout b args) (fun addr -> + box_complex + (Cop(Cload kind, [addr])) + (Cop(Cload kind, [Cop(Cadda, [addr; Cconst_int sz])]))) + | _ -> + Cop(Cload (bigarray_word_kind elt_kind), + [bigarray_indexing elt_kind layout b args]) + +let bigarray_set elt_kind layout b args newval = + match elt_kind with + Pbigarray_complex32 | Pbigarray_complex64 -> + let kind = bigarray_word_kind elt_kind in + let sz = bigarray_elt_size elt_kind / 2 in + bind "newval" newval (fun newv -> + bind "addr" (bigarray_indexing elt_kind layout b args) (fun addr -> + Csequence( + Cop(Cstore kind, [addr; complex_re newv]), + Cop(Cstore kind, + [Cop(Cadda, [addr; Cconst_int sz]); complex_im newv])))) + | _ -> + Cop(Cstore (bigarray_word_kind elt_kind), + [bigarray_indexing elt_kind layout b args; newval]) + +(* Simplification of some primitives into C calls *) + +let default_prim name = + { prim_name = name; prim_arity = 0 (*ignored*); + prim_alloc = true; prim_native_name = ""; prim_native_float = false } + +let simplif_primitive_32bits = function + Pbintofint Pint64 -> Pccall (default_prim "int64_of_int") + | Pintofbint Pint64 -> Pccall (default_prim "int64_to_int") + | Pcvtbint(Pint32, Pint64) -> Pccall (default_prim "int64_of_int32") + | Pcvtbint(Pint64, Pint32) -> Pccall (default_prim "int64_to_int32") + | Pcvtbint(Pnativeint, Pint64) -> Pccall (default_prim "int64_of_nativeint") + | Pcvtbint(Pint64, Pnativeint) -> Pccall (default_prim "int64_to_nativeint") + | Pnegbint Pint64 -> Pccall (default_prim "int64_neg") + | Paddbint Pint64 -> Pccall (default_prim "int64_add") + | Psubbint Pint64 -> Pccall (default_prim "int64_sub") + | Pmulbint Pint64 -> Pccall (default_prim "int64_mul") + | Pdivbint Pint64 -> Pccall (default_prim "int64_div") + | Pmodbint Pint64 -> Pccall (default_prim "int64_mod") + | Pandbint Pint64 -> Pccall (default_prim "int64_and") + | Porbint Pint64 -> Pccall (default_prim "int64_or") + | Pxorbint Pint64 -> Pccall (default_prim "int64_xor") + | Plslbint Pint64 -> Pccall (default_prim "int64_shift_left") + | Plsrbint Pint64 -> Pccall (default_prim "int64_shift_right_unsigned") + | Pasrbint Pint64 -> Pccall (default_prim "int64_shift_right") + | Pbintcomp(Pint64, Lambda.Ceq) -> Pccall (default_prim "equal") + | Pbintcomp(Pint64, Lambda.Cneq) -> Pccall (default_prim "notequal") + | Pbintcomp(Pint64, Lambda.Clt) -> Pccall (default_prim "lessthan") + | Pbintcomp(Pint64, Lambda.Cgt) -> Pccall (default_prim "greaterthan") + | Pbintcomp(Pint64, Lambda.Cle) -> Pccall (default_prim "lessequal") + | Pbintcomp(Pint64, Lambda.Cge) -> Pccall (default_prim "greaterequal") + | Pbigarrayref(n, Pbigarray_int64, layout) -> + Pccall (default_prim ("bigarray_get_" ^ string_of_int n)) + | Pbigarrayset(n, Pbigarray_int64, layout) -> + Pccall (default_prim ("bigarray_set_" ^ string_of_int n)) + | p -> p + +let simplif_primitive p = + match p with + Pbigarrayref(n, Pbigarray_unknown, layout) -> + Pccall (default_prim ("bigarray_get_" ^ string_of_int n)) + | Pbigarrayset(n, Pbigarray_unknown, layout) -> + Pccall (default_prim ("bigarray_set_" ^ string_of_int n)) + | Pbigarrayref(n, kind, Pbigarray_unknown_layout) -> + Pccall (default_prim ("bigarray_get_" ^ string_of_int n)) + | Pbigarrayset(n, kind, Pbigarray_unknown_layout) -> + Pccall (default_prim ("bigarray_set_" ^ string_of_int n)) + | p -> + if size_int = 8 then p else simplif_primitive_32bits p + +(* Build switchers both for constants and blocks *) + +(* constants first *) + +let transl_isout h arg = tag_int (Cop(Ccmpa Clt, [h ; arg])) + +exception Found of int + +let make_switch_gen arg cases acts = + let lcases = Array.length cases in + let new_cases = Array.create lcases 0 in + let store = Switch.mk_store (=) in + + for i = 0 to Array.length cases-1 do + let act = cases.(i) in + let new_act = store.Switch.act_store act in + new_cases.(i) <- new_act + done ; + Cswitch + (arg, new_cases, + Array.map + (fun n -> acts.(n)) + (store.Switch.act_get ())) + + +(* Then for blocks *) + +module SArgBlocks = +struct + type primitive = operation + + let eqint = Ccmpi Ceq + let neint = Ccmpi Cne + let leint = Ccmpi Cle + let ltint = Ccmpi Clt + let geint = Ccmpi Cge + let gtint = Ccmpi Cgt + + type act = expression + + let default = Cexit (0,[]) + let make_prim p args = Cop (p,args) + let make_offset arg n = add_const arg n + let make_isout h arg = Cop (Ccmpa Clt, [h ; arg]) + let make_isin h arg = Cop (Ccmpa Cge, [h ; arg]) + let make_if cond ifso ifnot = Cifthenelse (cond, ifso, ifnot) + let make_switch arg cases actions = + make_switch_gen arg cases actions + let bind arg body = bind "switcher" arg body + +end + +module SwitcherBlocks = Switch.Make(SArgBlocks) + +(* Auxiliary functions for optimizing "let" of boxed numbers (floats and + boxed integers *) + +type unboxed_number_kind = + No_unboxing + | Boxed_float + | Boxed_integer of boxed_integer + +let is_unboxed_number = function + Uconst(Const_base(Const_float f)) -> + Boxed_float + | Uprim(p, _) -> + begin match simplif_primitive p with + Pccall p -> if p.prim_native_float then Boxed_float else No_unboxing + | Pfloatfield _ -> Boxed_float + | Pfloatofint -> Boxed_float + | Pnegfloat -> Boxed_float + | Pabsfloat -> Boxed_float + | Paddfloat -> Boxed_float + | Psubfloat -> Boxed_float + | Pmulfloat -> Boxed_float + | Pdivfloat -> Boxed_float + | Parrayrefu Pfloatarray -> Boxed_float + | Parrayrefs Pfloatarray -> Boxed_float + | Pbintofint bi -> Boxed_integer bi + | Pcvtbint(src, dst) -> Boxed_integer dst + | Pnegbint bi -> Boxed_integer bi + | Paddbint bi -> Boxed_integer bi + | Psubbint bi -> Boxed_integer bi + | Pmulbint bi -> Boxed_integer bi + | Pdivbint bi -> Boxed_integer bi + | Pmodbint bi -> Boxed_integer bi + | Pandbint bi -> Boxed_integer bi + | Porbint bi -> Boxed_integer bi + | Pxorbint bi -> Boxed_integer bi + | Plslbint bi -> Boxed_integer bi + | Plsrbint bi -> Boxed_integer bi + | Pasrbint bi -> Boxed_integer bi + | Pbigarrayref(_, (Pbigarray_float32 | Pbigarray_float64), _) -> + Boxed_float + | Pbigarrayref(_, Pbigarray_int32, _) -> Boxed_integer Pint32 + | Pbigarrayref(_, Pbigarray_int64, _) -> Boxed_integer Pint64 + | Pbigarrayref(_, Pbigarray_native_int, _) -> Boxed_integer Pnativeint + | _ -> No_unboxing + end + | _ -> No_unboxing + +let subst_boxed_number unbox_fn boxed_id unboxed_id exp = + let need_boxed = ref false in + let assigned = ref false in + let rec subst = function + Cvar id as e -> + if Ident.same id boxed_id then need_boxed := true; e + | Clet(id, arg, body) -> Clet(id, subst arg, subst body) + | Cassign(id, arg) -> + if Ident.same id boxed_id then begin + assigned := true; + Cassign(unboxed_id, subst(unbox_fn arg)) + end else + Cassign(id, subst arg) + | Ctuple argv -> Ctuple(List.map subst argv) + | Cop(Cload _, [Cvar id]) as e -> + if Ident.same id boxed_id then Cvar unboxed_id else e + | Cop(Cload _, [Cop(Cadda, [Cvar id; _])]) as e -> + if Ident.same id boxed_id then Cvar unboxed_id else e + | Cop(op, argv) -> Cop(op, List.map subst argv) + | Csequence(e1, e2) -> Csequence(subst e1, subst e2) + | Cifthenelse(e1, e2, e3) -> Cifthenelse(subst e1, subst e2, subst e3) + | Cswitch(arg, index, cases) -> + Cswitch(subst arg, index, Array.map subst cases) + | Cloop e -> Cloop(subst e) + | Ccatch(nfail, ids, e1, e2) -> Ccatch(nfail, ids, subst e1, subst e2) + | Cexit (nfail, el) -> Cexit (nfail, List.map subst el) + | Ctrywith(e1, id, e2) -> Ctrywith(subst e1, id, subst e2) + | e -> e in + let res = subst exp in + (res, !need_boxed, !assigned) + +(* Translate an expression *) + +let functions = (Queue.create() : (string * Ident.t list * ulambda) Queue.t) + +let rec transl = function + Uvar id -> + Cvar id + | Uconst sc -> + transl_constant sc + | Uclosure(fundecls, []) -> + let lbl = new_const_symbol() in + constant_closures := (lbl, fundecls) :: !constant_closures; + List.iter + (fun (label, arity, params, body) -> + Queue.add (label, params, body) functions) + fundecls; + Cconst_symbol lbl + | Uclosure(fundecls, clos_vars) -> + let block_size = + fundecls_size fundecls + List.length clos_vars in + let rec transl_fundecls pos = function + [] -> + List.map transl clos_vars + | (label, arity, params, body) :: rem -> + Queue.add (label, params, body) functions; + let header = + if pos = 0 + then alloc_closure_header block_size + else alloc_infix_header pos in + if arity = 1 then + header :: + Cconst_symbol label :: + int_const 1 :: + transl_fundecls (pos + 3) rem + else + header :: + Cconst_symbol(curry_function arity) :: + int_const arity :: + Cconst_symbol label :: + transl_fundecls (pos + 4) rem in + Cop(Calloc, transl_fundecls 0 fundecls) + | Uoffset(arg, offset) -> + field_address (transl arg) offset + | Udirect_apply(lbl, args) -> + Cop(Capply typ_addr, Cconst_symbol lbl :: List.map transl args) + | Ugeneric_apply(clos, [arg]) -> + bind "fun" (transl clos) (fun clos -> + Cop(Capply typ_addr, [get_field clos 0; transl arg; clos])) + | Ugeneric_apply(clos, args) -> + let arity = List.length args in + let cargs = Cconst_symbol(apply_function arity) :: + List.map transl (args @ [clos]) in + Cop(Capply typ_addr, cargs) + | Usend(met, obj, []) -> + bind "obj" (transl obj) (fun obj -> + bind "met" (lookup_label obj (transl met)) (fun clos -> + Cop(Capply typ_addr, [get_field clos 0; obj; clos]))) + | Usend(met, obj, args) -> + let arity = List.length args + 1 in + bind "obj" (transl obj) (fun obj -> + bind "met" (lookup_label obj (transl met)) (fun clos -> + let cargs = Cconst_symbol(apply_function arity) :: + obj :: (List.map transl args) @ [clos] in + Cop(Capply typ_addr, cargs))) + | Ulet(id, exp, body) -> + begin match is_unboxed_number exp with + No_unboxing -> + Clet(id, transl exp, transl body) + | Boxed_float -> + transl_unbox_let box_float unbox_float transl_unbox_float + id exp body + | Boxed_integer bi -> + transl_unbox_let (box_int bi) (unbox_int bi) (transl_unbox_int bi) + id exp body + end + | Uletrec(bindings, body) -> + transl_letrec bindings (transl body) + + (* Primitives *) + | Uprim(prim, args) -> + begin match (simplif_primitive prim, args) with + (Pgetglobal id, []) -> + Cconst_symbol(Ident.name id) + | (Pmakeblock(tag, mut), []) -> + transl_constant(Const_block(tag, [])) + | (Pmakeblock(tag, mut), args) -> + make_alloc tag (List.map transl args) + | (Pccall prim, args) -> + if prim.prim_native_float then + box_float + (Cop(Cextcall(prim.prim_native_name, typ_float, false), + List.map transl_unbox_float args)) + else begin + let name = + if prim.prim_native_name <> "" + then prim.prim_native_name + else prim.prim_name in + Cop(Cextcall(name, typ_addr, prim.prim_alloc), + List.map transl args) + end + | (Pmakearray kind, []) -> + transl_constant(Const_block(0, [])) + | (Pmakearray kind, args) -> + begin match kind with + Pgenarray -> + Cop(Cextcall("make_array", typ_addr, true), + [make_alloc 0 (List.map transl args)]) + | Paddrarray | Pintarray -> + make_alloc 0 (List.map transl args) + | Pfloatarray -> + make_float_alloc Obj.double_array_tag + (List.map transl_unbox_float args) + end + | (Pbigarrayref(num_dims, elt_kind, layout), arg1 :: argl) -> + let elt = + bigarray_get elt_kind layout + (transl arg1) (List.map transl argl) in + begin match elt_kind with + Pbigarray_float32 | Pbigarray_float64 -> box_float elt + | Pbigarray_complex32 | Pbigarray_complex64 -> elt + | Pbigarray_int32 -> box_int Pint32 elt + | Pbigarray_int64 -> box_int Pint64 elt + | Pbigarray_native_int -> box_int Pnativeint elt + | Pbigarray_caml_int -> force_tag_int elt + | _ -> tag_int elt + end + | (Pbigarrayset(num_dims, elt_kind, layout), arg1 :: argl) -> + let (argidx, argnewval) = split_last argl in + return_unit(bigarray_set elt_kind layout + (transl arg1) + (List.map transl argidx) + (match elt_kind with + Pbigarray_float32 | Pbigarray_float64 -> + transl_unbox_float argnewval + | Pbigarray_complex32 | Pbigarray_complex64 -> transl argnewval + | Pbigarray_int32 -> transl_unbox_int Pint32 argnewval + | Pbigarray_int64 -> transl_unbox_int Pint64 argnewval + | Pbigarray_native_int -> transl_unbox_int Pnativeint argnewval + | _ -> untag_int (transl argnewval))) + | (p, [arg]) -> + transl_prim_1 p arg + | (p, [arg1; arg2]) -> + transl_prim_2 p arg1 arg2 + | (p, [arg1; arg2; arg3]) -> + transl_prim_3 p arg1 arg2 arg3 + | (_, _) -> + fatal_error "Cmmgen.transl:prim" + end + + (* Control structures *) + | Uswitch(arg, s) -> + (* As in the bytecode interpreter, only matching against constants + can be checked *) + if Array.length s.us_index_blocks = 0 then + Cswitch + (untag_int (transl arg), + s.us_index_consts, + Array.map transl s.us_actions_consts) + else if Array.length s.us_index_consts = 0 then + transl_switch (get_tag (transl arg)) + s.us_index_blocks s.us_actions_blocks + else + bind "switch" (transl arg) (fun arg -> + Cifthenelse( + Cop(Cand, [arg; Cconst_int 1]), + transl_switch + (untag_int arg) s.us_index_consts s.us_actions_consts, + transl_switch + (get_tag arg) s.us_index_blocks s.us_actions_blocks)) + | Ustaticfail (nfail, args) -> + Cexit (nfail, List.map transl args) + | Ucatch(nfail, [], body, handler) -> + make_catch nfail (transl body) (transl handler) + | Ucatch(nfail, ids, body, handler) -> + Ccatch(nfail, ids, transl body, transl handler) + | Utrywith(body, exn, handler) -> + Ctrywith(transl body, exn, transl handler) + | Uifthenelse(Uprim(Pnot, [arg]), ifso, ifnot) -> + transl (Uifthenelse(arg, ifnot, ifso)) + | Uifthenelse(cond, ifso, Ustaticfail (nfail, [])) -> + exit_if_false cond (transl ifso) nfail + | Uifthenelse(cond, Ustaticfail (nfail, []), ifnot) -> + exit_if_true cond nfail (transl ifnot) + | Uifthenelse(Uprim(Psequand, _) as cond, ifso, ifnot) -> + let raise_num = next_raise_count () in + make_catch + raise_num + (exit_if_false cond (transl ifso) raise_num) + (transl ifnot) + | Uifthenelse(Uprim(Psequor, _) as cond, ifso, ifnot) -> + let raise_num = next_raise_count () in + make_catch + raise_num + (exit_if_true cond raise_num (transl ifnot)) + (transl ifso) + | Uifthenelse (Uifthenelse (cond, condso, condnot), ifso, ifnot) -> + let num_true = next_raise_count () in + make_catch + num_true + (make_catch2 + (fun shared_false -> + Cifthenelse + (test_bool (transl cond), + exit_if_true condso num_true shared_false, + exit_if_true condnot num_true shared_false)) + (transl ifnot)) + (transl ifso) + | Uifthenelse(cond, ifso, ifnot) -> + Cifthenelse(test_bool(transl cond), transl ifso, transl ifnot) + | Usequence(exp1, exp2) -> + Csequence(remove_unit(transl exp1), transl exp2) + | Uwhile(cond, body) -> + let raise_num = next_raise_count () in + return_unit + (Ccatch + (raise_num, [], + Cloop(exit_if_false cond (remove_unit(transl body)) raise_num), + Ctuple [])) + | Ufor(id, low, high, dir, body) -> + let tst = match dir with Upto -> Cgt | Downto -> Clt in + let inc = match dir with Upto -> Caddi | Downto -> Csubi in + let raise_num = next_raise_count () in + let id_prev = Ident.rename id in + return_unit + (Clet + (id, transl low, + bind_nonvar "bound" (transl high) (fun high -> + Ccatch + (raise_num, [], + Cifthenelse + (Cop(Ccmpi tst, [Cvar id; high]), Cexit (raise_num, []), + Cloop + (Csequence + (remove_unit(transl body), + Clet(id_prev, Cvar id, + Csequence + (Cassign(id, + Cop(inc, [Cvar id; Cconst_int 2])), + Cifthenelse + (Cop(Ccmpi Ceq, [Cvar id_prev; high]), + Cexit (raise_num,[]), Ctuple [])))))), + Ctuple [])))) + | Uassign(id, exp) -> + return_unit(Cassign(id, transl exp)) + +and transl_prim_1 p arg = + match p with + (* Generic operations *) + Pidentity -> + transl arg + | Pignore -> + return_unit(remove_unit (transl arg)) + (* Heap operations *) + | Pfield n -> + get_field (transl arg) n + | Pfloatfield n -> + let ptr = transl arg in + box_float( + Cop(Cload Double_u, + [if n = 0 then ptr + else Cop(Cadda, [ptr; Cconst_int(n * size_float)])])) + (* Exceptions *) + | Praise -> + Cop(Craise, [transl arg]) + (* Integer operations *) + | Pnegint -> + Cop(Csubi, [Cconst_int 2; transl arg]) + | Poffsetint n -> + if no_overflow_lsl n then + add_const (transl arg) (n lsl 1) + else + transl_prim_2 Paddint arg (Uconst (Const_base(Const_int n))) + | Poffsetref n -> + return_unit + (bind "ref" (transl arg) (fun arg -> + Cop(Cstore Word, + [arg; add_const (Cop(Cload Word, [arg])) (n lsl 1)]))) + (* Floating-point operations *) + | Pfloatofint -> + box_float(Cop(Cfloatofint, [untag_int(transl arg)])) + | Pintoffloat -> + tag_int(Cop(Cintoffloat, [transl_unbox_float arg])) + | Pnegfloat -> + box_float(Cop(Cnegf, [transl_unbox_float arg])) + | Pabsfloat -> + box_float(Cop(Cabsf, [transl_unbox_float arg])) + (* String operations *) + | Pstringlength -> + tag_int(string_length (transl arg)) + (* Array operations *) + | Parraylength kind -> + begin match kind with + Pgenarray -> + let len = + if wordsize_shift = numfloat_shift then + Cop(Clsr, [header(transl arg); Cconst_int wordsize_shift]) + else + bind "header" (header(transl arg)) (fun hdr -> + Cifthenelse(is_addr_array_hdr hdr, + Cop(Clsr, [hdr; Cconst_int wordsize_shift]), + Cop(Clsr, [hdr; Cconst_int numfloat_shift]))) in + Cop(Cor, [len; Cconst_int 1]) + | Paddrarray | Pintarray -> + Cop(Cor, [addr_array_length(header(transl arg)); Cconst_int 1]) + | Pfloatarray -> + Cop(Cor, [float_array_length(header(transl arg)); Cconst_int 1]) + end + (* Boolean operations *) + | Pnot -> + Cop(Csubi, [Cconst_int 4; transl arg]) (* 1 -> 3, 3 -> 1 *) + (* Test integer/block *) + | Pisint -> + tag_int(Cop(Cand, [transl arg; Cconst_int 1])) + (* Boxed integers *) + | Pbintofint bi -> + box_int bi (untag_int (transl arg)) + | Pintofbint bi -> + force_tag_int (transl_unbox_int bi arg) + | Pcvtbint(bi1, bi2) -> + box_int bi2 (transl_unbox_int bi1 arg) + | Pnegbint bi -> + box_int bi (Cop(Csubi, [Cconst_int 0; transl_unbox_int bi arg])) + | _ -> + fatal_error "Cmmgen.transl_prim_1" + +and transl_prim_2 p arg1 arg2 = + match p with + (* Heap operations *) + Psetfield(n, ptr) -> + if ptr then + return_unit(Cop(Cextcall("modify", typ_void, false), + [field_address (transl arg1) n; transl arg2])) + else + return_unit(set_field (transl arg1) n (transl arg2)) + | Psetfloatfield n -> + let ptr = transl arg1 in + return_unit( + Cop(Cstore Double_u, + [if n = 0 then ptr + else Cop(Cadda, [ptr; Cconst_int(n * size_float)]); + transl_unbox_float arg2])) + + (* Boolean operations *) + | Psequand -> + Cifthenelse(test_bool(transl arg1), transl arg2, Cconst_int 1) + | Psequor -> + Cifthenelse(test_bool(transl arg1), Cconst_int 3, transl arg2) + + (* Integer operations *) + | Paddint -> + decr_int(add_int (transl arg1) (transl arg2)) + | Psubint -> + incr_int(sub_int (transl arg1) (transl arg2)) + | Pmulint -> + incr_int(Cop(Cmuli, [decr_int(transl arg1); untag_int(transl arg2)])) + | Pdivint -> + tag_int(Cop(Cdivi, [untag_int(transl arg1); untag_int(transl arg2)])) + | Pmodint -> + tag_int(Cop(Cmodi, [untag_int(transl arg1); untag_int(transl arg2)])) + | Pandint -> + Cop(Cand, [transl arg1; transl arg2]) + | Porint -> + Cop(Cor, [transl arg1; transl arg2]) + | Pxorint -> + Cop(Cor, [Cop(Cxor, [ignore_low_bit_int(transl arg1); + ignore_low_bit_int(transl arg2)]); + Cconst_int 1]) + | Plslint -> + incr_int(lsl_int (decr_int(transl arg1)) (untag_int(transl arg2))) + | Plsrint -> + Cop(Cor, [Cop(Clsr, [transl arg1; untag_int(transl arg2)]); + Cconst_int 1]) + | Pasrint -> + Cop(Cor, [Cop(Casr, [transl arg1; untag_int(transl arg2)]); + Cconst_int 1]) + | Pintcomp cmp -> + tag_int(Cop(Ccmpi(transl_comparison cmp), [transl arg1; transl arg2])) + | Pisout -> + transl_isout (transl arg1) (transl arg2) + (* Float operations *) + | Paddfloat -> + box_float(Cop(Caddf, + [transl_unbox_float arg1; transl_unbox_float arg2])) + | Psubfloat -> + box_float(Cop(Csubf, + [transl_unbox_float arg1; transl_unbox_float arg2])) + | Pmulfloat -> + box_float(Cop(Cmulf, + [transl_unbox_float arg1; transl_unbox_float arg2])) + | Pdivfloat -> + box_float(Cop(Cdivf, + [transl_unbox_float arg1; transl_unbox_float arg2])) + | Pfloatcomp cmp -> + tag_int(Cop(Ccmpf(transl_comparison cmp), + [transl_unbox_float arg1; transl_unbox_float arg2])) + + (* String operations *) + | Pstringrefu -> + tag_int(Cop(Cload Byte_unsigned, + [add_int (transl arg1) (untag_int(transl arg2))])) + | Pstringrefs -> + tag_int + (bind "str" (transl arg1) (fun str -> + bind "index" (untag_int (transl arg2)) (fun idx -> + Csequence( + Cop(Ccheckbound, [string_length str; idx]), + Cop(Cload Byte_unsigned, [add_int str idx]))))) + + (* Array operations *) + | Parrayrefu kind -> + begin match kind with + Pgenarray -> + bind "arr" (transl arg1) (fun arr -> + bind "index" (transl arg2) (fun idx -> + Cifthenelse(is_addr_array_ptr arr, + addr_array_ref arr idx, + float_array_ref arr idx))) + | Paddrarray | Pintarray -> + addr_array_ref (transl arg1) (transl arg2) + | Pfloatarray -> + float_array_ref (transl arg1) (transl arg2) + end + | Parrayrefs kind -> + begin match kind with + Pgenarray -> + bind "index" (transl arg2) (fun idx -> + bind "arr" (transl arg1) (fun arr -> + bind "header" (header arr) (fun hdr -> + Cifthenelse(is_addr_array_hdr hdr, + Csequence(Cop(Ccheckbound, [addr_array_length hdr; idx]), + addr_array_ref arr idx), + Csequence(Cop(Ccheckbound, [float_array_length hdr; idx]), + float_array_ref arr idx))))) + | Paddrarray | Pintarray -> + bind "index" (transl arg2) (fun idx -> + bind "arr" (transl arg1) (fun arr -> + Csequence(Cop(Ccheckbound, [addr_array_length(header arr); idx]), + addr_array_ref arr idx))) + | Pfloatarray -> + box_float( + bind "index" (transl arg2) (fun idx -> + bind "arr" (transl arg1) (fun arr -> + Csequence(Cop(Ccheckbound, + [float_array_length(header arr); idx]), + unboxed_float_array_ref arr idx)))) + end + + (* Operations on bitvects *) + | Pbittest -> + bind "index" (untag_int(transl arg2)) (fun idx -> + tag_int( + Cop(Cand, [Cop(Clsr, [Cop(Cload Byte_unsigned, + [add_int (transl arg1) + (Cop(Clsr, [idx; Cconst_int 3]))]); + Cop(Cand, [idx; Cconst_int 7])]); + Cconst_int 1]))) + + (* Boxed integers *) + | Paddbint bi -> + box_int bi (Cop(Caddi, + [transl_unbox_int bi arg1; transl_unbox_int bi arg2])) + | Psubbint bi -> + box_int bi (Cop(Csubi, + [transl_unbox_int bi arg1; transl_unbox_int bi arg2])) + | Pmulbint bi -> + box_int bi (Cop(Cmuli, + [transl_unbox_int bi arg1; transl_unbox_int bi arg2])) + | Pdivbint bi -> + box_int bi (Cop(Cdivi, + [transl_unbox_int bi arg1; transl_unbox_int bi arg2])) + | Pmodbint bi -> + box_int bi (Cop(Cmodi, + [transl_unbox_int bi arg1; transl_unbox_int bi arg2])) + | Pandbint bi -> + box_int bi (Cop(Cand, + [transl_unbox_int bi arg1; transl_unbox_int bi arg2])) + | Porbint bi -> + box_int bi (Cop(Cor, + [transl_unbox_int bi arg1; transl_unbox_int bi arg2])) + | Pxorbint bi -> + box_int bi (Cop(Cxor, + [transl_unbox_int bi arg1; transl_unbox_int bi arg2])) + | Plslbint bi -> + box_int bi (Cop(Clsl, + [transl_unbox_int bi arg1; untag_int(transl arg2)])) + | Plsrbint bi -> + box_int bi (Cop(Clsr, + [make_unsigned_int bi (transl_unbox_int bi arg1); + untag_int(transl arg2)])) + | Pasrbint bi -> + box_int bi (Cop(Casr, + [transl_unbox_int bi arg1; untag_int(transl arg2)])) + | Pbintcomp(bi, cmp) -> + tag_int (Cop(Ccmpi(transl_comparison cmp), + [transl_unbox_int bi arg1; transl_unbox_int bi arg2])) + | _ -> + fatal_error "Cmmgen.transl_prim_2" + +and transl_prim_3 p arg1 arg2 arg3 = + match p with + (* String operations *) + Pstringsetu -> + return_unit(Cop(Cstore Byte_unsigned, + [add_int (transl arg1) (untag_int(transl arg2)); + untag_int(transl arg3)])) + | Pstringsets -> + return_unit + (bind "str" (transl arg1) (fun str -> + bind "index" (untag_int (transl arg2)) (fun idx -> + Csequence( + Cop(Ccheckbound, [string_length str; idx]), + Cop(Cstore Byte_unsigned, + [add_int str idx; untag_int(transl arg3)]))))) + + (* Array operations *) + | Parraysetu kind -> + return_unit(begin match kind with + Pgenarray -> + bind "newval" (transl arg3) (fun newval -> + bind "index" (transl arg2) (fun index -> + bind "arr" (transl arg1) (fun arr -> + Cifthenelse(is_addr_array_ptr arr, + addr_array_set arr index newval, + float_array_set arr index (unbox_float newval))))) + | Paddrarray -> + addr_array_set (transl arg1) (transl arg2) (transl arg3) + | Pintarray -> + int_array_set (transl arg1) (transl arg2) (transl arg3) + | Pfloatarray -> + float_array_set (transl arg1) (transl arg2) (transl_unbox_float arg3) + end) + | Parraysets kind -> + return_unit(begin match kind with + Pgenarray -> + bind "newval" (transl arg3) (fun newval -> + bind "index" (transl arg2) (fun idx -> + bind "arr" (transl arg1) (fun arr -> + bind "header" (header arr) (fun hdr -> + Cifthenelse(is_addr_array_hdr hdr, + Csequence(Cop(Ccheckbound, [addr_array_length hdr; idx]), + addr_array_set arr idx newval), + Csequence(Cop(Ccheckbound, [float_array_length hdr; idx]), + float_array_set arr idx + (unbox_float newval))))))) + | Paddrarray -> + bind "index" (transl arg2) (fun idx -> + bind "arr" (transl arg1) (fun arr -> + Csequence(Cop(Ccheckbound, [addr_array_length(header arr); idx]), + addr_array_set arr idx (transl arg3)))) + | Pintarray -> + bind "index" (transl arg2) (fun idx -> + bind "arr" (transl arg1) (fun arr -> + Csequence(Cop(Ccheckbound, [addr_array_length(header arr); idx]), + int_array_set arr idx (transl arg3)))) + | Pfloatarray -> + bind "index" (transl arg2) (fun idx -> + bind "arr" (transl arg1) (fun arr -> + Csequence(Cop(Ccheckbound, [float_array_length(header arr);idx]), + float_array_set arr idx (transl_unbox_float arg3)))) + end) + | _ -> + fatal_error "Cmmgen.transl_prim_3" + +and transl_unbox_float = function + Uconst(Const_base(Const_float f)) -> Cconst_float f + | exp -> unbox_float(transl exp) + +and transl_unbox_int bi = function + Uconst(Const_base(Const_int32 n)) -> + Cconst_natint (Nativeint.of_int32 n) + | Uconst(Const_base(Const_nativeint n)) -> + Cconst_natint n + | Uconst(Const_base(Const_int64 n)) -> + assert (size_int = 8); Cconst_natint (Int64.to_nativeint n) + | Uprim(Pbintofint bi', [Uconst(Const_base(Const_int i))]) when bi = bi' -> + Cconst_int i + | exp -> unbox_int bi (transl exp) + +and transl_unbox_let box_fn unbox_fn transl_unbox_fn id exp body = + let unboxed_id = Ident.create (Ident.name id) in + let (tr_body, need_boxed, is_assigned) = + subst_boxed_number unbox_fn id unboxed_id (transl body) in + if need_boxed && is_assigned then + Clet(id, transl exp, transl body) + else + Clet(unboxed_id, transl_unbox_fn exp, + if need_boxed + then Clet(id, box_fn(Cvar unboxed_id), tr_body) + else tr_body) + +and make_catch ncatch body handler = match body with +| Cexit (nexit,[]) when nexit=ncatch -> handler +| _ -> Ccatch (ncatch, [], body, handler) + +and make_catch2 mk_body handler = match handler with +| Cexit (_,[])|Ctuple []|Cconst_int _|Cconst_pointer _ -> + mk_body handler +| _ -> + let nfail = next_raise_count () in + make_catch + nfail + (mk_body (Cexit (nfail,[]))) + handler + +and exit_if_true cond nfail otherwise = + match cond with + | Uconst (Const_pointer 0) -> otherwise + | Uconst (Const_pointer 1) -> Cexit (nfail,[]) + | Uprim(Psequor, [arg1; arg2]) -> + exit_if_true arg1 nfail (exit_if_true arg2 nfail otherwise) + | Uprim(Psequand, _) -> + begin match otherwise with + | Cexit (raise_num,[]) -> + exit_if_false cond (Cexit (nfail,[])) raise_num + | _ -> + let raise_num = next_raise_count () in + make_catch + raise_num + (exit_if_false cond (Cexit (nfail,[])) raise_num) + otherwise + end + | Uprim(Pnot, [arg]) -> + exit_if_false arg otherwise nfail + | Uifthenelse (cond, ifso, ifnot) -> + make_catch2 + (fun shared -> + Cifthenelse + (test_bool (transl cond), + exit_if_true ifso nfail shared, + exit_if_true ifnot nfail shared)) + otherwise + | _ -> + Cifthenelse(test_bool(transl cond), Cexit (nfail, []), otherwise) + +and exit_if_false cond otherwise nfail = + match cond with + | Uconst (Const_pointer 0) -> Cexit (nfail,[]) + | Uconst (Const_pointer 1) -> otherwise + | Uprim(Psequand, [arg1; arg2]) -> + exit_if_false arg1 (exit_if_false arg2 otherwise nfail) nfail + | Uprim(Psequor, _ ) -> + begin match otherwise with + | Cexit (raise_num,[]) -> + exit_if_true cond raise_num (Cexit (nfail,[])) + | _ -> + let raise_num = next_raise_count () in + make_catch + raise_num + (exit_if_true cond raise_num (Cexit (nfail,[]))) + otherwise + end + | Uprim(Pnot, [arg]) -> + exit_if_true arg nfail otherwise + | Uifthenelse (cond, ifso, ifnot) -> + make_catch2 + (fun shared -> + Cifthenelse + (test_bool (transl cond), + exit_if_false ifso shared nfail, + exit_if_false ifnot shared nfail)) + otherwise + | _ -> + Cifthenelse(test_bool(transl cond), otherwise, Cexit (nfail, [])) + +and transl_switch arg index cases = match Array.length cases with +| 0 -> fatal_error "Cmmgen.transl_switch" +| 1 -> transl cases.(0) +| _ -> + let n_index = Array.length index in + let actions = Array.map transl cases in + + let inters = ref [] + and this_high = ref (n_index-1) + and this_low = ref (n_index-1) + and this_act = ref index.(n_index-1) in + for i = n_index-2 downto 0 do + let act = index.(i) in + if act = !this_act then + decr this_low + else begin + inters := (!this_low, !this_high, !this_act) :: !inters ; + this_high := i ; + this_low := i ; + this_act := act + end + done ; + inters := (0, !this_high, !this_act) :: !inters ; + bind "switcher" arg + (fun a -> + SwitcherBlocks.zyva + (0,n_index-1) + (fun i -> Cconst_int i) + a + (Array.of_list !inters) actions) + +and transl_letrec bindings cont = + let bsz = List.map (fun (id, exp) -> (id, exp, expr_size exp)) bindings in + let rec init_blocks = function + | [] -> fill_nonrec bsz + | (id, exp, RHS_block sz) :: rem -> + Clet(id, Cop(Cextcall("alloc_dummy", typ_addr, true), [int_const sz]), + init_blocks rem) + | (id, exp, RHS_nonrec) :: rem -> + Clet (id, Cconst_int 0, init_blocks rem) + and fill_nonrec = function + | [] -> fill_blocks bsz + | (id, exp, RHS_block sz) :: rem -> fill_nonrec rem + | (id, exp, RHS_nonrec) :: rem -> + Clet (id, transl exp, fill_nonrec rem) + and fill_blocks = function + | [] -> cont + | (id, exp, RHS_block _) :: rem -> + Csequence(Cop(Cextcall("update_dummy", typ_void, false), + [Cvar id; transl exp]), + fill_blocks rem) + | (id, exp, RHS_nonrec) :: rem -> + fill_blocks rem + in init_blocks bsz + +(* Translate a function definition *) + +let transl_function lbl params body = + Cfunction {fun_name = lbl; + fun_args = List.map (fun id -> (id, typ_addr)) params; + fun_body = transl body; + fun_fast = !Clflags.optimize_for_speed} + +(* Translate all function definitions *) + +module StringSet = + Set.Make(struct + type t = string + let compare = compare + end) + +let rec transl_all_functions already_translated cont = + try + let (lbl, params, body) = Queue.take functions in + if StringSet.mem lbl already_translated then + transl_all_functions already_translated cont + else begin + transl_all_functions (StringSet.add lbl already_translated) + (transl_function lbl params body :: cont) + end + with Queue.Empty -> + cont + +(* Emit structured constants *) + +let rec emit_constant symb cst cont = + match cst with + Const_base(Const_float s) -> + Cint(float_header) :: Cdefine_symbol symb :: Cdouble s :: cont + | Const_base(Const_string s) -> + Cint(string_header (String.length s)) :: + Cdefine_symbol symb :: + emit_string_constant s cont + | Const_base(Const_int32 n) -> + Cint(boxedint_header) :: Cdefine_symbol symb :: + emit_boxed_int32_constant n cont + | Const_base(Const_int64 n) -> + Cint(boxedint_header) :: Cdefine_symbol symb :: + emit_boxed_int64_constant n cont + | Const_base(Const_nativeint n) -> + Cint(boxedint_header) :: Cdefine_symbol symb :: + emit_boxed_nativeint_constant n cont + | Const_block(tag, fields) -> + let (emit_fields, cont1) = emit_constant_fields fields cont in + Cint(block_header tag (List.length fields)) :: + Cdefine_symbol symb :: + emit_fields @ cont1 + | Const_float_array(fields) -> + Cint(floatarray_header (List.length fields)) :: + Cdefine_symbol symb :: + Misc.map_end (fun f -> Cdouble f) fields cont + | _ -> fatal_error "gencmm.emit_constant" + +and emit_constant_fields fields cont = + match fields with + [] -> ([], cont) + | f1 :: fl -> + let (data1, cont1) = emit_constant_field f1 cont in + let (datal, contl) = emit_constant_fields fl cont1 in + (data1 :: datal, contl) + +and emit_constant_field field cont = + match field with + Const_base(Const_int n) -> + (Cint(Nativeint.add (Nativeint.shift_left (Nativeint.of_int n) 1) 1n), + cont) + | Const_base(Const_char c) -> + (Cint(Nativeint.of_int(((Char.code c) lsl 1) + 1)), cont) + | Const_base(Const_float s) -> + let lbl = new_const_label() in + (Clabel_address lbl, + Cint(float_header) :: Cdefine_label lbl :: Cdouble s :: cont) + | Const_base(Const_string s) -> + let lbl = new_const_label() in + (Clabel_address lbl, + Cint(string_header (String.length s)) :: Cdefine_label lbl :: + emit_string_constant s cont) + | Const_base(Const_int32 n) -> + let lbl = new_const_label() in + (Clabel_address lbl, + Cint(boxedint_header) :: Cdefine_label lbl :: + emit_boxed_int32_constant n cont) + | Const_base(Const_int64 n) -> + let lbl = new_const_label() in + (Clabel_address lbl, + Cint(boxedint_header) :: Cdefine_label lbl :: + emit_boxed_int64_constant n cont) + | Const_base(Const_nativeint n) -> + let lbl = new_const_label() in + (Clabel_address lbl, + Cint(boxedint_header) :: Cdefine_label lbl :: + emit_boxed_nativeint_constant n cont) + | Const_pointer n -> + (Cint(Nativeint.add (Nativeint.shift_left (Nativeint.of_int n) 1) 1n), + cont) + | Const_block(tag, fields) -> + let lbl = new_const_label() in + let (emit_fields, cont1) = emit_constant_fields fields cont in + (Clabel_address lbl, + Cint(block_header tag (List.length fields)) :: Cdefine_label lbl :: + emit_fields @ cont1) + | Const_float_array(fields) -> + let lbl = new_const_label() in + (Clabel_address lbl, + Cint(floatarray_header (List.length fields)) :: Cdefine_label lbl :: + Misc.map_end (fun f -> Cdouble f) fields cont) + +and emit_string_constant s cont = + let n = size_int - 1 - (String.length s) mod size_int in + Cstring s :: Cskip n :: Cint8 n :: cont + +and emit_boxed_int32_constant n cont = + let n = Nativeint.of_int32 n in + if size_int = 8 then + Csymbol_address("int32_ops") :: Cint32 n :: Cint32 0n :: cont + else + Csymbol_address("int32_ops") :: Cint n :: cont + +and emit_boxed_nativeint_constant n cont = + Csymbol_address("nativeint_ops") :: Cint n :: cont + +and emit_boxed_int64_constant n cont = + let lo = Int64.to_nativeint n in + if size_int = 8 then + Csymbol_address("int64_ops") :: Cint lo :: cont + else begin + let hi = Int64.to_nativeint (Int64.shift_right n 32) in + if big_endian then + Csymbol_address("int64_ops") :: Cint hi :: Cint lo :: cont + else + Csymbol_address("int64_ops") :: Cint lo :: Cint hi :: cont + end + +(* Emit constant closures *) + +let emit_constant_closure symb fundecls cont = + match fundecls with + [] -> assert false + | (label, arity, params, body) :: remainder -> + let rec emit_others pos = function + [] -> cont + | (label, arity, params, body) :: rem -> + if arity = 1 then + Cint(infix_header pos) :: + Csymbol_address label :: + Cint 3n :: + emit_others (pos + 3) rem + else + Cint(infix_header pos) :: + Csymbol_address(curry_function arity) :: + Cint(Nativeint.of_int (arity lsl 1 + 1)) :: + Csymbol_address label :: + emit_others (pos + 4) rem in + Cint(closure_header (fundecls_size fundecls)) :: + Cdefine_symbol symb :: + if arity = 1 then + Csymbol_address label :: + Cint 3n :: + emit_others 3 remainder + else + Csymbol_address(curry_function arity) :: + Cint(Nativeint.of_int (arity lsl 1 + 1)) :: + Csymbol_address label :: + emit_others 4 remainder + +(* Emit all structured constants *) + +let emit_all_constants cont = + let c = ref cont in + List.iter + (fun (lbl, cst) -> c := Cdata(emit_constant lbl cst []) :: !c) + !structured_constants; + structured_constants := []; + List.iter + (fun (symb, fundecls) -> + c := Cdata(emit_constant_closure symb fundecls []) :: !c) + !constant_closures; + constant_closures := []; + !c + +(* Translate a compilation unit *) + +let compunit size ulam = + let glob = Compilenv.current_unit_name () in + let init_code = transl ulam in + let c1 = [Cfunction {fun_name = glob ^ "__entry"; fun_args = []; + fun_body = init_code; fun_fast = false}] in + let c2 = transl_all_functions StringSet.empty c1 in + let c3 = emit_all_constants c2 in + Cdata [Cint(block_header 0 size); + Cglobal_symbol glob; + Cdefine_symbol glob; + Cskip(size * size_addr)] :: c3 + +(* Generate an application function: + (defun caml_applyN (a1 ... aN clos) + (if (= clos.arity N) + (app clos.direct a1 ... aN clos) + (let (clos1 (app clos.code a1 clos) + clos2 (app clos1.code a2 clos) + ... + closN-1 (app closN-2.code aN-1 closN-2)) + (app closN-1.code aN closN-1)))) +*) + +let apply_function arity = + let arg = Array.create arity (Ident.create "arg") in + for i = 1 to arity - 1 do arg.(i) <- Ident.create "arg" done; + let clos = Ident.create "clos" in + let rec app_fun clos n = + if n = arity-1 then + Cop(Capply typ_addr, + [get_field (Cvar clos) 0; Cvar arg.(n); Cvar clos]) + else begin + let newclos = Ident.create "clos" in + Clet(newclos, + Cop(Capply typ_addr, + [get_field (Cvar clos) 0; Cvar arg.(n); Cvar clos]), + app_fun newclos (n+1)) + end in + let all_args = Array.to_list arg @ [clos] in + let body = + Cifthenelse( + Cop(Ccmpi Ceq, [get_field (Cvar clos) 1; int_const arity]), + Cop(Capply typ_addr, + get_field (Cvar clos) 2 :: List.map (fun s -> Cvar s) all_args), + app_fun clos 0) in + Cfunction + {fun_name = "caml_apply" ^ string_of_int arity; + fun_args = List.map (fun id -> (id, typ_addr)) all_args; + fun_body = body; + fun_fast = true} + +(* Generate tuplifying functions: + (defun caml_tuplifyN (arg clos) + (app clos.direct #0(arg) ... #N-1(arg) clos)) *) + +let tuplify_function arity = + let arg = Ident.create "arg" in + let clos = Ident.create "clos" in + let rec access_components i = + if i >= arity + then [] + else get_field (Cvar arg) i :: access_components(i+1) in + Cfunction + {fun_name = "caml_tuplify" ^ string_of_int arity; + fun_args = [arg, typ_addr; clos, typ_addr]; + fun_body = + Cop(Capply typ_addr, + get_field (Cvar clos) 2 :: access_components 0 @ [Cvar clos]); + fun_fast = true} + +(* Generate currying functions: + (defun caml_curryN (arg clos) + (alloc HDR caml_curryN_1 arg clos)) + (defun caml_curryN_1 (arg clos) + (alloc HDR caml_curryN_2 arg clos)) + ... + (defun caml_curryN_N-1 (arg clos) + (let (closN-2 clos.cdr + closN-3 closN-2.cdr + ... + clos1 clos2.cdr + clos clos1.cdr) + (app clos.direct + clos1.car clos2.car ... closN-2.car clos.car arg clos))) *) + +let final_curry_function arity = + let last_arg = Ident.create "arg" in + let last_clos = Ident.create "clos" in + let rec curry_fun args clos n = + if n = 0 then + Cop(Capply typ_addr, + get_field (Cvar clos) 2 :: + args @ [Cvar last_arg; Cvar clos]) + else begin + let newclos = Ident.create "clos" in + Clet(newclos, + get_field (Cvar clos) 3, + curry_fun (get_field (Cvar clos) 2 :: args) newclos (n-1)) + end in + Cfunction + {fun_name = "caml_curry" ^ string_of_int arity ^ + "_" ^ string_of_int (arity-1); + fun_args = [last_arg, typ_addr; last_clos, typ_addr]; + fun_body = curry_fun [] last_clos (arity-1); + fun_fast = true} + +let rec intermediate_curry_functions arity num = + if num = arity - 1 then + [final_curry_function arity] + else begin + let name1 = "caml_curry" ^ string_of_int arity in + let name2 = if num = 0 then name1 else name1 ^ "_" ^ string_of_int num in + let arg = Ident.create "arg" and clos = Ident.create "clos" in + Cfunction + {fun_name = name2; + fun_args = [arg, typ_addr; clos, typ_addr]; + fun_body = Cop(Calloc, + [alloc_closure_header 4; + Cconst_symbol(name1 ^ "_" ^ string_of_int (num+1)); + int_const 1; Cvar arg; Cvar clos]); + fun_fast = true} + :: intermediate_curry_functions arity (num+1) + end + +let curry_function arity = + if arity >= 0 + then intermediate_curry_functions arity 0 + else [tuplify_function (-arity)] + +(* Generate the entry point *) + +let entry_point namelist = + let incr_global_inited = + Cop(Cstore Word, + [Cconst_symbol "caml_globals_inited"; + Cop(Caddi, [Cop(Cload Word, [Cconst_symbol "caml_globals_inited"]); + Cconst_int 1])]) in + let body = + List.fold_right + (fun name next -> + Csequence(Cop(Capply typ_void, [Cconst_symbol(name ^ "__entry")]), + Csequence(incr_global_inited, next))) + namelist (Cconst_int 1) in + Cfunction {fun_name = "caml_program"; + fun_args = []; + fun_body = body; + fun_fast = false} + +(* Generate the table of globals *) + +let cint_zero = Cint 0n + +let global_table namelist = + Cdata(Cglobal_symbol "caml_globals" :: + Cdefine_symbol "caml_globals" :: + List.map (fun name -> Csymbol_address name) namelist @ + [cint_zero]) + +let globals_map namelist = + Cdata(Cglobal_symbol "globals_map" :: + emit_constant "globals_map" + (Const_base (Const_string (Marshal.to_string namelist []))) []) + +(* Generate the master table of frame descriptors *) + +let frame_table namelist = + Cdata(Cglobal_symbol "caml_frametable" :: + Cdefine_symbol "caml_frametable" :: + List.map (fun name -> Csymbol_address(name ^ "__frametable")) namelist + @ [cint_zero]) + +(* Generate the table of module data and code segments *) + +let segment_table namelist symbol begname endname = + Cdata(Cglobal_symbol symbol :: + Cdefine_symbol symbol :: + List.fold_right + (fun name lst -> + Csymbol_address(name ^ begname) :: + Csymbol_address(name ^ endname) :: lst) + namelist + [cint_zero]) + +let data_segment_table namelist = + segment_table namelist "caml_data_segments" "__data_begin" "__data_end" + +let code_segment_table namelist = + segment_table namelist "caml_code_segments" "__code_begin" "__code_end" + +(* Initialize a predefined exception *) + +let predef_exception name = + Cdata(Cglobal_symbol name :: + emit_constant name (Const_block(0,[Const_base(Const_string name)])) []) diff --git a/asmcomp/cmmgen.mli b/asmcomp/cmmgen.mli new file mode 100644 index 00000000..c66e2270 --- /dev/null +++ b/asmcomp/cmmgen.mli @@ -0,0 +1,27 @@ +(***********************************************************************) +(* *) +(* 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: cmmgen.mli,v 1.11 2003/03/06 15:59:54 xleroy Exp $ *) + +(* Translation from closed lambda to C-- *) + +val compunit: int -> Clambda.ulambda -> Cmm.phrase list + +val apply_function: int -> Cmm.phrase +val curry_function: int -> Cmm.phrase list +val entry_point: string list -> Cmm.phrase +val global_table: string list -> Cmm.phrase +val globals_map: (string * string) list -> Cmm.phrase +val frame_table: string list -> Cmm.phrase +val data_segment_table: string list -> Cmm.phrase +val code_segment_table: string list -> Cmm.phrase +val predef_exception: string -> Cmm.phrase diff --git a/asmcomp/codegen.ml b/asmcomp/codegen.ml new file mode 100644 index 00000000..c737884d --- /dev/null +++ b/asmcomp/codegen.ml @@ -0,0 +1,101 @@ +(***********************************************************************) +(* *) +(* 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: codegen.ml,v 1.7 2000/04/21 08:10:29 weis Exp $ *) + +(* From C-- to assembly code *) + +open Format +open Cmm + +let dump_cmm = ref false +let dump_selection = ref false +let dump_live = ref false +let dump_spill = ref false +let dump_split = ref false +let dump_interf = ref false +let dump_prefer = ref false +let dump_regalloc = ref false +let dump_reload = ref false +let dump_linear = ref false + +let rec regalloc fd = + if !dump_live then Printmach.phase "Liveness analysis" fd; + Interf.build_graph fd; + if !dump_interf then Printmach.interferences(); + if !dump_prefer then Printmach.preferences(); + Coloring.allocate_registers(); + if !dump_regalloc then + Printmach.phase "After register allocation" fd; + let (newfd, redo_regalloc) = Reload.fundecl fd in + if !dump_reload then + Printmach.phase "After insertion of reloading code" newfd; + if redo_regalloc + then begin Reg.reinit(); Liveness.fundecl newfd; regalloc newfd end + else newfd + +let fundecl ppf fd_cmm = + if !dump_cmm then begin + fprintf ppf "*** C-- code@."; + fprintf ppf "%a@." Printcmm.fundecl fd_cmm + end; + Reg.reset(); + let fd_sel = Sequence.fundecl fd_cmm in + if !dump_selection then + Printmach.phase "After instruction selection" fd_sel; + Liveness.fundecl fd_sel; + if !dump_live then Printmach.phase "Liveness analysis" fd_sel; + let fd_spill = Spill.fundecl fd_sel in + Liveness.fundecl fd_spill; + if !dump_spill then + Printmach.phase "After spilling" fd_spill; + let fd_split = Split.fundecl fd_spill in + Liveness.fundecl fd_split; + if !dump_split then + Printmach.phase "After live range splitting" fd_split; + let fd_reload = regalloc fd_split in + let fd_linear = Linearize.fundecl fd_reload in + if !dump_linear then begin + printf "*** Linearized code@."; + Printlinear.fundecl fd_linear; print_newline() + end; + Emit.fundecl fd_linear + +let phrase = function + Cfunction fd -> fundecl fd + | Cdata dl -> Emit.data dl + +let file filename = + let ic = open_in filename in + let lb = Lexing.from_channel ic in + try + while true do + phrase(Parsecmm.phrase Lexcmm.token lb) + done + with + End_of_file -> + close_in ic + | Lexcmm.Error msg -> + close_in ic; Lexcmm.report_error lb msg + | Parsing.Parse_error -> + close_in ic; + prerr_string "Syntax error near character "; + prerr_int (Lexing.lexeme_start lb); + prerr_newline() + | Parsecmmaux.Error msg -> + close_in ic; Parsecmmaux.report_error msg + | x -> + close_in ic; raise x + + + + diff --git a/asmcomp/codegen.mli b/asmcomp/codegen.mli new file mode 100644 index 00000000..51189632 --- /dev/null +++ b/asmcomp/codegen.mli @@ -0,0 +1,29 @@ +(***********************************************************************) +(* *) +(* 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: codegen.mli,v 1.4 1999/11/17 18:56:31 xleroy Exp $ *) + +(* From C-- to assembly code *) + +val phrase: Cmm.phrase -> unit +val file: string -> unit + +val dump_cmm: bool ref +val dump_selection: bool ref +val dump_live: bool ref +val dump_spill: bool ref +val dump_split: bool ref +val dump_interf: bool ref +val dump_prefer: bool ref +val dump_regalloc: bool ref +val dump_reload: bool ref +val dump_linear: bool ref diff --git a/asmcomp/coloring.ml b/asmcomp/coloring.ml new file mode 100644 index 00000000..2144c978 --- /dev/null +++ b/asmcomp/coloring.ml @@ -0,0 +1,299 @@ +(***********************************************************************) +(* *) +(* 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: coloring.ml,v 1.12 2000/12/28 13:02:49 weis Exp $ *) + +(* Register allocation by coloring of the interference graph *) + +open Reg + +(* Preallocation of spilled registers in the stack. *) + +let allocate_spilled reg = + if reg.spill then begin + let cl = Proc.register_class reg in + let nslots = Proc.num_stack_slots.(cl) in + let conflict = Array.create nslots false in + List.iter + (fun r -> + match r.loc with + Stack(Local n) -> + if Proc.register_class r = cl then conflict.(n) <- true + | _ -> ()) + reg.interf; + let slot = ref 0 in + while !slot < nslots && conflict.(!slot) do incr slot done; + reg.loc <- Stack(Local !slot); + if !slot >= nslots then Proc.num_stack_slots.(cl) <- !slot + 1 + end + +(* Compute the degree (= number of neighbours of the same type) + of each register, and split them in two sets: + unconstrained (degree < number of available registers) + and constrained (degree >= number of available registers). + Spilled registers are ignored in the process. *) + +let unconstrained = ref Reg.Set.empty +let constrained = ref Reg.Set.empty + +let find_degree reg = + if reg.spill then () else begin + let cl = Proc.register_class reg in + let avail_regs = Proc.num_available_registers.(cl) in + if avail_regs = 0 then + (* Don't bother computing the degree if there are no regs + in this class *) + unconstrained := Reg.Set.add reg !unconstrained + else begin + let deg = ref 0 in + List.iter + (fun r -> if not r.spill && Proc.register_class r = cl then incr deg) + reg.interf; + reg.degree <- !deg; + if !deg >= avail_regs + then constrained := Reg.Set.add reg !constrained + else unconstrained := Reg.Set.add reg !unconstrained + end + end + +(* Remove a register from the interference graph *) + +let remove_reg reg = + reg.degree <- 0; (* 0 means r is no longer part of the graph *) + let cl = Proc.register_class reg in + List.iter + (fun r -> + if Proc.register_class r = cl && r.degree > 0 then begin + let olddeg = r.degree in + r.degree <- olddeg - 1; + if olddeg = Proc.num_available_registers.(cl) then begin + (* r was constrained and becomes unconstrained *) + constrained := Reg.Set.remove r !constrained; + unconstrained := Reg.Set.add r !unconstrained + end + end) + reg.interf + +(* Remove all registers one by one, unconstrained if possible, otherwise + constrained with lowest spill cost. Return the list of registers removed + in reverse order. + The spill cost measure is [r.spill_cost / r.degree]. + [r.spill_cost] estimates the number of accesses to this register. *) + +let rec remove_all_regs stack = + if not (Reg.Set.is_empty !unconstrained) then begin + (* Pick any unconstrained register *) + let r = Reg.Set.choose !unconstrained in + unconstrained := Reg.Set.remove r !unconstrained; + remove_all_regs (r :: stack) + end else + if not (Reg.Set.is_empty !constrained) then begin + (* Find a constrained reg with minimal cost *) + let r = ref Reg.dummy in + let min_degree = ref 0 and min_spill_cost = ref 1 in + (* initially !min_spill_cost / !min_degree is +infty *) + Reg.Set.iter + (fun r2 -> + (* if r2.spill_cost / r2.degree < !min_spill_cost / !min_degree *) + if r2.spill_cost * !min_degree < !min_spill_cost * r2.degree + then begin + r := r2; min_degree := r2.degree; min_spill_cost := r2.spill_cost + end) + !constrained; + constrained := Reg.Set.remove !r !constrained; + remove_all_regs (!r :: stack) + end else + stack (* All regs have been removed *) + +(* Iterate over all registers preferred by the given register (transitively) *) + +let iter_preferred f reg = + let rec walk r w = + if not r.visited then begin + f r w; + begin match r.prefer with + [] -> () + | p -> r.visited <- true; + List.iter (fun (r1, w1) -> walk r1 (min w w1)) p; + r.visited <- false + end + end in + reg.visited <- true; + List.iter (fun (r, w) -> walk r w) reg.prefer; + reg.visited <- false + +(* Where to start the search for a suitable register. + Used to introduce some "randomness" in the choice between registers + with equal scores. This offers more opportunities for scheduling. *) + +let start_register = Array.create Proc.num_register_classes 0 + +(* Assign a location to a register, the best we can *) + +let assign_location reg = + let cl = Proc.register_class reg in + let first_reg = Proc.first_available_register.(cl) in + let num_regs = Proc.num_available_registers.(cl) in + let last_reg = first_reg + num_regs in + let score = Array.create num_regs 0 in + let best_score = ref (-1000000) and best_reg = ref (-1) in + let start = start_register.(cl) in + if num_regs > 0 then begin + (* Favor the registers that have been assigned to pseudoregs for which + we have a preference. If these pseudoregs have not been assigned + already, avoid the registers with which they conflict. *) + iter_preferred + (fun r w -> + match r.loc with + Reg n -> if n >= first_reg && n < last_reg then + score.(n - first_reg) <- score.(n - first_reg) + w + | Unknown -> + List.iter + (fun neighbour -> + match neighbour.loc with + Reg n -> if n >= first_reg && n < last_reg then + score.(n - first_reg) <- score.(n - first_reg) - w + | _ -> ()) + r.interf + | _ -> ()) + reg; + List.iter + (fun neighbour -> + (* Prohibit the registers that have been assigned + to our neighbours *) + begin match neighbour.loc with + Reg n -> if n >= first_reg && n < last_reg then + score.(n - first_reg) <- (-1000000) + | _ -> () + end; + (* Avoid the registers that have been assigned to pseudoregs + for which our neighbours have a preference *) + iter_preferred + (fun r w -> + match r.loc with + Reg n -> if n >= first_reg && n < last_reg then + score.(n - first_reg) <- score.(n - first_reg) - (w - 1) + (* w-1 to break the symmetry when two conflicting regs + have the same preference for a third reg. *) + | _ -> ()) + neighbour) + reg.interf; + (* Pick the register with the best score *) + for n = start to num_regs - 1 do + if score.(n) > !best_score then begin + best_score := score.(n); + best_reg := n + end + done; + for n = 0 to start - 1 do + if score.(n) > !best_score then begin + best_score := score.(n); + best_reg := n + end + done + end; + (* Found a register? *) + if !best_reg >= 0 then begin + reg.loc <- Reg(first_reg + !best_reg); + if Proc.rotate_registers then + start_register.(cl) <- (if start+1 >= num_regs then 0 else start+1) + end else begin + (* Sorry, we must put the pseudoreg in a stack location *) + (* First, check if we have a preference for an incoming location + we do not conflict with. *) + let best_score = ref 0 and best_incoming_loc = ref (-1) in + List.iter + (fun (r, w) -> + match r.loc with + Stack(Incoming n) -> + if w > !best_score + && List.for_all (fun neighbour -> neighbour.loc <> r.loc) + reg.interf + then begin + best_score := w; + best_incoming_loc := n + end + | _ -> ()) + reg.prefer; + if !best_incoming_loc >= 0 then + reg.loc <- Stack(Incoming !best_incoming_loc) + else begin + (* Now, look for a location in the local area *) + let nslots = Proc.num_stack_slots.(cl) in + let score = Array.create nslots 0 in + (* Compute the scores as for registers *) + List.iter + (fun (r, w) -> + match r.loc with + Stack(Local n) -> if Proc.register_class r = cl then + score.(n) <- score.(n) + w + | Unknown -> + List.iter + (fun neighbour -> + match neighbour.loc with + Stack(Local n) -> + if Proc.register_class neighbour = cl + then score.(n) <- score.(n) - w + | _ -> ()) + r.interf + | _ -> ()) + reg.prefer; + List.iter + (fun neighbour -> + begin match neighbour.loc with + Stack(Local n) -> + if Proc.register_class neighbour = cl then + score.(n) <- (-1000000) + | _ -> () + end; + List.iter + (fun (r, w) -> + match r.loc with + Stack(Local n) -> if Proc.register_class r = cl then + score.(n) <- score.(n) - w + | _ -> ()) + neighbour.prefer) + reg.interf; + (* Pick the location with the best score *) + let best_score = ref (-1000000) and best_slot = ref (-1) in + for n = 0 to nslots - 1 do + if score.(n) > !best_score then begin + best_score := score.(n); + best_slot := n + end + done; + (* Found one? *) + if !best_slot >= 0 then + reg.loc <- Stack(Local !best_slot) + else begin + (* Allocate a new stack slot *) + reg.loc <- Stack(Local nslots); + Proc.num_stack_slots.(cl) <- nslots + 1 + end + end + end; + (* Cancel the preferences of this register so that they don't influence + transitively the allocation of registers that prefer this reg. *) + reg.prefer <- [] + +let allocate_registers() = + (* First pass: preallocate spill registers + Second pass: compute the degrees + Third pass: determine coloring order by successive removals of regs + Fourth pass: assign registers in that order *) + for i = 0 to Proc.num_register_classes - 1 do + Proc.num_stack_slots.(i) <- 0; + start_register.(i) <- 0 + done; + List.iter allocate_spilled (Reg.all_registers()); + List.iter find_degree (Reg.all_registers()); + List.iter assign_location (remove_all_regs []) diff --git a/asmcomp/coloring.mli b/asmcomp/coloring.mli new file mode 100644 index 00000000..729a1d62 --- /dev/null +++ b/asmcomp/coloring.mli @@ -0,0 +1,17 @@ +(***********************************************************************) +(* *) +(* 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: coloring.mli,v 1.4 1999/11/17 18:56:31 xleroy Exp $ *) + +(* Register allocation by coloring of the interference graph *) + +val allocate_registers: unit -> unit diff --git a/asmcomp/comballoc.ml b/asmcomp/comballoc.ml new file mode 100644 index 00000000..fba74937 --- /dev/null +++ b/asmcomp/comballoc.ml @@ -0,0 +1,89 @@ +(***********************************************************************) +(* *) +(* 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: comballoc.ml,v 1.3 2000/08/11 19:50:50 maranget Exp $ *) + +(* Combine heap allocations occurring in the same basic block *) + +open Mach + +type allocation_state = + No_alloc (* no allocation is pending *) + | Pending_alloc of Reg.t * int (* an allocation is pending *) +(* The arguments of Pending_alloc(reg, ofs) are: + reg the register holding the result of the last allocation + ofs the alloc position in the allocated block *) + +let allocated_size = function + No_alloc -> 0 + | Pending_alloc(reg, ofs) -> ofs + +let rec combine i allocstate = + match i.desc with + Iend | Ireturn | Iexit _ | Iraise -> + (i, allocated_size allocstate) + | Iop(Ialloc sz) -> + begin match allocstate with + No_alloc -> + let (newnext, newsz) = + combine i.next (Pending_alloc(i.res.(0), sz)) in + (instr_cons (Iop(Ialloc newsz)) i.arg i.res newnext, 0) + | Pending_alloc(reg, ofs) -> + if ofs + sz < Config.max_young_wosize then begin + let (newnext, newsz) = + combine i.next (Pending_alloc(reg, ofs + sz)) in + (instr_cons (Iop(Iintop_imm(Iadd, ofs))) [| reg |] i.res newnext, + newsz) + end else begin + let (newnext, newsz) = + combine i.next (Pending_alloc(i.res.(0), sz)) in + (instr_cons (Iop(Ialloc newsz)) i.arg i.res newnext, ofs) + end + end + | Iop(Icall_ind | Icall_imm _ | Iextcall(_, _) | + Itailcall_ind | Itailcall_imm _) -> + let newnext = combine_restart i.next in + (instr_cons i.desc i.arg i.res newnext, allocated_size allocstate) + | Iop op -> + let (newnext, sz) = combine i.next allocstate in + (instr_cons i.desc i.arg i.res newnext, sz) + | Iifthenelse(test, ifso, ifnot) -> + let newifso = combine_restart ifso in + let newifnot = combine_restart ifnot in + let newnext = combine_restart i.next in + (instr_cons (Iifthenelse(test, newifso, newifnot)) i.arg i.res newnext, + allocated_size allocstate) + | Iswitch(table, cases) -> + let newcases = Array.map combine_restart cases in + let newnext = combine_restart i.next in + (instr_cons (Iswitch(table, newcases)) i.arg i.res newnext, + allocated_size allocstate) + | Iloop(body) -> + let newbody = combine_restart body in + (instr_cons (Iloop(newbody)) i.arg i.res i.next, + allocated_size allocstate) + | Icatch(io, body, handler) -> + let (newbody, sz) = combine body allocstate in + let newhandler = combine_restart handler in + let newnext = combine_restart i.next in + (instr_cons (Icatch(io, newbody, newhandler)) i.arg i.res newnext, sz) + | Itrywith(body, handler) -> + let (newbody, sz) = combine body allocstate in + let newhandler = combine_restart handler in + let newnext = combine_restart i.next in + (instr_cons (Itrywith(newbody, newhandler)) i.arg i.res newnext, sz) + +and combine_restart i = + let (newi, _) = combine i No_alloc in newi + +let fundecl f = + {f with fun_body = combine_restart f.fun_body} diff --git a/asmcomp/comballoc.mli b/asmcomp/comballoc.mli new file mode 100644 index 00000000..d0ff57ff --- /dev/null +++ b/asmcomp/comballoc.mli @@ -0,0 +1,17 @@ +(***********************************************************************) +(* *) +(* 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: comballoc.mli,v 1.2 1999/11/17 18:56:32 xleroy Exp $ *) + +(* Combine heap allocations occurring in the same basic block *) + +val fundecl: Mach.fundecl -> Mach.fundecl diff --git a/asmcomp/compilenv.ml b/asmcomp/compilenv.ml new file mode 100644 index 00000000..5508bed5 --- /dev/null +++ b/asmcomp/compilenv.ml @@ -0,0 +1,169 @@ +(***********************************************************************) +(* *) +(* 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: compilenv.ml,v 1.18 2002/06/07 07:35:25 xleroy Exp $ *) + +(* Compilation environments for compilation units *) + +open Config +open Misc +open Clambda + +type error = + Not_a_unit_info of string + | Corrupted_unit_info of string + | Illegal_renaming of string * string + +exception Error of error + +(* Each .o file has a matching .cmx file that provides the following infos + on the compilation unit: + - list of other units imported, with CRCs of their .cmx files + - approximation of the structure implemented + (includes descriptions of known functions: arity and direct entry + points) + - list of currying functions and application functions needed + The .cmx file contains these infos (as an externed record) plus a CRC + of these infos *) + +type unit_infos = + { mutable ui_name: string; (* Name of unit implemented *) + mutable ui_defines: string list; (* Unit and sub-units implemented *) + mutable ui_imports_cmi: (string * Digest.t) list; (* Interfaces imported *) + mutable ui_imports_cmx: (string * Digest.t) list; (* Infos imported *) + mutable ui_approx: value_approximation; (* Approx of the structure *) + mutable ui_curry_fun: int list; (* Currying functions needed *) + mutable ui_apply_fun: int list; (* Apply functions needed *) + mutable ui_force_link: bool } (* Always linked *) + +(* Each .a library has a matching .cmxa file that provides the following + infos on the library: *) + +type library_infos = + { lib_units: (unit_infos * Digest.t) list; (* List of unit infos w/ CRCs *) + lib_ccobjs: string list; (* C object files needed *) + lib_ccopts: string list } (* Extra opts to C compiler *) + +let global_approx_table = + (Hashtbl.create 17 : (string, value_approximation) Hashtbl.t) + +let current_unit = + { ui_name = ""; + ui_defines = []; + ui_imports_cmi = []; + ui_imports_cmx = []; + ui_approx = Value_unknown; + ui_curry_fun = []; + ui_apply_fun = []; + ui_force_link = false } + +let reset name = + Hashtbl.clear global_approx_table; + current_unit.ui_name <- name; + current_unit.ui_defines <- [name]; + current_unit.ui_imports_cmi <- []; + current_unit.ui_imports_cmx <- []; + current_unit.ui_curry_fun <- []; + current_unit.ui_apply_fun <- []; + current_unit.ui_force_link <- false + +let current_unit_name () = + current_unit.ui_name + +let read_unit_info filename = + let ic = open_in_bin filename in + try + let buffer = String.create (String.length cmx_magic_number) in + really_input ic buffer 0 (String.length cmx_magic_number); + if buffer <> cmx_magic_number then begin + close_in ic; + raise(Error(Not_a_unit_info filename)) + end; + let ui = (input_value ic : unit_infos) in + let crc = Digest.input ic in + close_in ic; + (ui, crc) + with End_of_file | Failure _ -> + close_in ic; + raise(Error(Corrupted_unit_info(filename))) + +(* Return the approximation of a global identifier *) + +let cmx_not_found_crc = + "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" + +let global_approx global_ident = + let modname = Ident.name global_ident in + if modname = current_unit.ui_name then + current_unit.ui_approx + else begin + try + Hashtbl.find global_approx_table modname + with Not_found -> + let (approx, crc) = + try + let filename = + find_in_path_uncap !load_path (modname ^ ".cmx") in + let (ui, crc) = read_unit_info filename in + if ui.ui_name <> modname then + raise(Error(Illegal_renaming(ui.ui_name, filename))); + (ui.ui_approx, crc) + with Not_found -> + (Value_unknown, cmx_not_found_crc) in + current_unit.ui_imports_cmx <- + (modname, crc) :: current_unit.ui_imports_cmx; + Hashtbl.add global_approx_table modname approx; + approx + end + +(* Register the approximation of the module being compiled *) + +let set_global_approx approx = + current_unit.ui_approx <- approx + +(* Record that a currying function or application function is needed *) + +let need_curry_fun n = + if not (List.mem n current_unit.ui_curry_fun) then + current_unit.ui_curry_fun <- n :: current_unit.ui_curry_fun + +let need_apply_fun n = + if not (List.mem n current_unit.ui_apply_fun) then + current_unit.ui_apply_fun <- n :: current_unit.ui_apply_fun + +(* Write the description of the current unit *) + +let write_unit_info info filename = + let oc = open_out_bin filename in + output_string oc cmx_magic_number; + output_value oc info; + flush oc; + let crc = Digest.file filename in + Digest.output oc crc; + close_out oc + +let save_unit_info filename = + current_unit.ui_imports_cmi <- Env.imported_units(); + write_unit_info current_unit filename + +(* Error report *) + +open Format + +let report_error ppf = function + | Not_a_unit_info filename -> + fprintf ppf "%s@ is not a compilation unit description." filename + | Corrupted_unit_info filename -> + fprintf ppf "Corrupted compilation unit description@ %s" filename + | Illegal_renaming(modname, filename) -> + fprintf ppf "%s@ contains the description for unit@ %s" filename modname + diff --git a/asmcomp/compilenv.mli b/asmcomp/compilenv.mli new file mode 100644 index 00000000..3f1b373c --- /dev/null +++ b/asmcomp/compilenv.mli @@ -0,0 +1,82 @@ +(***********************************************************************) +(* *) +(* 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: compilenv.mli,v 1.12 2002/02/08 16:55:30 xleroy Exp $ *) + +(* Compilation environments for compilation units *) + +open Clambda + +(* Each .o file has a matching .cmx file that provides the following infos + on the compilation unit: + - list of other units imported, with CRCs of their .cmx files + - approximation of the structure implemented + (includes descriptions of known functions: arity and direct entry + points) + - list of currying functions and application functions needed + The .cmx file contains these infos (as an externed record) plus a CRC + of these infos *) + +type unit_infos = + { mutable ui_name: string; (* Name of unit implemented *) + mutable ui_defines: string list; (* Unit and sub-units implemented *) + mutable ui_imports_cmi: (string * Digest.t) list; (* Interfaces imported *) + mutable ui_imports_cmx: (string * Digest.t) list; (* Infos imported *) + mutable ui_approx: value_approximation; (* Approx of the structure *) + mutable ui_curry_fun: int list; (* Currying functions needed *) + mutable ui_apply_fun: int list; (* Apply functions needed *) + mutable ui_force_link: bool } (* Always linked *) + +(* Each .a library has a matching .cmxa file that provides the following + infos on the library: *) + +type library_infos = + { lib_units: (unit_infos * Digest.t) list; (* List of unit infos w/ CRCs *) + lib_ccobjs: string list; (* C object files needed *) + lib_ccopts: string list } (* Extra opts to C compiler *) + +val reset: string -> unit + (* Reset the environment and record the name of the unit being + compiled (arg). *) + +val current_unit_name: unit -> string + (* Return the name of the unit being compiled *) + +val global_approx: Ident.t -> Clambda.value_approximation + (* Return the approximation for the given global identifier *) +val set_global_approx: Clambda.value_approximation -> unit + (* Record the approximation of the unit being compiled *) + +val need_curry_fun: int -> unit +val need_apply_fun: int -> unit + (* Record the need of a currying (resp. application) function + with the given arity *) + +val read_unit_info: string -> unit_infos * Digest.t + (* Read infos and CRC from a [.cmx] file. *) +val write_unit_info: unit_infos -> string -> unit + (* Save the given infos in the given file *) +val save_unit_info: string -> unit + (* Save the infos for the current unit in the given file *) + +val cmx_not_found_crc: Digest.t + (* Special digest used in the [ui_imports_cmx] list to signal + that no [.cmx] file was found and used for the imported unit *) + +type error = + Not_a_unit_info of string + | Corrupted_unit_info of string + | Illegal_renaming of string * string + +exception Error of error + +val report_error: Format.formatter -> error -> unit diff --git a/asmcomp/emit.mli b/asmcomp/emit.mli new file mode 100644 index 00000000..20fc1dfd --- /dev/null +++ b/asmcomp/emit.mli @@ -0,0 +1,20 @@ +(***********************************************************************) +(* *) +(* 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: emit.mli,v 1.5 1999/11/17 18:56:32 xleroy Exp $ *) + +(* Generation of assembly code *) + +val fundecl: Linearize.fundecl -> unit +val data: Cmm.data_item list -> unit +val begin_assembly: unit -> unit +val end_assembly: unit -> unit diff --git a/asmcomp/emitaux.ml b/asmcomp/emitaux.ml new file mode 100644 index 00000000..1bfee7ac --- /dev/null +++ b/asmcomp/emitaux.ml @@ -0,0 +1,88 @@ +(***********************************************************************) +(* *) +(* 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: emitaux.ml,v 1.11 1999/11/17 18:56:33 xleroy Exp $ *) + +(* Common functions for emitting assembly code *) + +let output_channel = ref stdout + +let emit_string s = output_string !output_channel s + +let emit_int n = output_string !output_channel (string_of_int n) + +let emit_char c = output_char !output_channel c + +let emit_nativeint n = output_string !output_channel (Nativeint.to_string n) + +let emit_printf fmt = + Printf.fprintf !output_channel fmt + +let emit_symbol esc s = + for i = 0 to String.length s - 1 do + let c = s.[i] in + match c with + 'A'..'Z' | 'a'..'z' | '0'..'9' | '_' -> + output_char !output_channel c + | _ -> + Printf.fprintf !output_channel "%c%02x" esc (Char.code c) + done + +let emit_string_literal s = + let last_was_escape = ref false in + emit_string "\""; + for i = 0 to String.length s - 1 do + let c = s.[i] in + if c >= '0' && c <= '9' then + if !last_was_escape + then Printf.fprintf !output_channel "\\%o" (Char.code c) + else output_char !output_channel c + else if c >= ' ' && c <= '~' && c <> '"' (* '"' *) && c <> '\\' then begin + output_char !output_channel c; + last_was_escape := false + end else begin + Printf.fprintf !output_channel "\\%o" (Char.code c); + last_was_escape := true + end + done; + emit_string "\"" + +let emit_string_directive directive s = + let l = String.length s in + if l = 0 then () + else if l < 80 then begin + emit_string directive; + emit_string_literal s; + emit_char '\n' + end else begin + let i = ref 0 in + while !i < l do + let n = min (l - !i) 80 in + emit_string directive; + emit_string_literal (String.sub s !i n); + emit_char '\n'; + i := !i + n + done + end + +let emit_bytes_directive directive s = + let pos = ref 0 in + for i = 0 to String.length s - 1 do + if !pos = 0 + then emit_string directive + else emit_char ','; + emit_int(Char.code s.[i]); + incr pos; + if !pos >= 16 then begin emit_char '\n'; pos := 0 end + done; + if !pos > 0 then emit_char '\n' + diff --git a/asmcomp/emitaux.mli b/asmcomp/emitaux.mli new file mode 100644 index 00000000..f468df08 --- /dev/null +++ b/asmcomp/emitaux.mli @@ -0,0 +1,26 @@ +(***********************************************************************) +(* *) +(* 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: emitaux.mli,v 1.11 2003/07/05 11:12:39 xleroy Exp $ *) + +(* Common functions for emitting assembly code *) + +val output_channel: out_channel ref +val emit_string: string -> unit +val emit_int: int -> unit +val emit_nativeint: nativeint -> unit +val emit_symbol: char -> string -> unit +val emit_printf: ('a, out_channel, unit) format -> 'a +val emit_char: char -> unit +val emit_string_literal: string -> unit +val emit_string_directive: string -> string -> unit +val emit_bytes_directive: string -> string -> unit diff --git a/asmcomp/hppa/arch.ml b/asmcomp/hppa/arch.ml new file mode 100644 index 00000000..9a2e940c --- /dev/null +++ b/asmcomp/hppa/arch.ml @@ -0,0 +1,74 @@ +(***********************************************************************) +(* *) +(* 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: arch.ml,v 1.7 2002/11/29 15:03:36 xleroy Exp $ *) + +(* Specific operations for the HP PA-RISC processor *) + +open Misc +open Format + +(* Machine-specific command-line options *) + +let command_line_options = [] + +(* Specific operations *) + +type specific_operation = + Ishift1add + | Ishift2add + | Ishift3add + +(* Addressing modes *) + +type addressing_mode = + Ibased of string * int (* symbol + displ *) + | Iindexed of int (* reg + displ *) + +(* Sizes, endianness *) + +let big_endian = true + +let size_addr = 4 +let size_int = 4 +let size_float = 8 + +(* Operations on addressing modes *) + +let identity_addressing = Iindexed 0 + +let offset_addressing addr delta = + match addr with + Ibased(s, n) -> Ibased(s, n + delta) + | Iindexed n -> Iindexed(n + delta) + +let num_args_addressing = function + Ibased(s, n) -> 0 + | Iindexed n -> 1 + +(* Printing operations and addressing modes *) + +let print_addressing printreg addr ppf arg = + match addr with + | Ibased(s, n) -> + let idx = if n <> 0 then Printf.sprintf " + %i" n else "" in + fprintf ppf "\"%s\"%s" s idx + | Iindexed n -> + let idx = if n <> 0 then Printf.sprintf " + %i" n else "" in + fprintf ppf "%a%s" printreg arg.(0) idx + +let print_specific_operation printreg op ppf arg = + match op with + | Ishift1add -> fprintf ppf "%a << 1 + %a" printreg arg.(0) printreg arg.(1) + | Ishift2add -> fprintf ppf "%a << 2 + %a" printreg arg.(0) printreg arg.(1) + | Ishift3add -> fprintf ppf "%a << 3 + %a" printreg arg.(0) printreg arg.(1) + diff --git a/asmcomp/hppa/emit.mlp b/asmcomp/hppa/emit.mlp new file mode 100644 index 00000000..a2bc4383 --- /dev/null +++ b/asmcomp/hppa/emit.mlp @@ -0,0 +1,1103 @@ +(***********************************************************************) +(* *) +(* 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: emit.mlp,v 1.14 2002/11/24 15:55:25 xleroy Exp $ *) + +(* Emission of HP PA-RISC assembly code *) + +(* Must come before open Reg... *) +module StringSet = + Set.Make(struct + type t = string + let compare = compare + end) + +open Location +open Misc +open Cmm +open Arch +open Proc +open Reg +open Mach +open Linearize +open Emitaux + +(* Adaptation to HPUX and NextStep *) + +let hpux = + match Config.system with + "hpux" -> true + | "nextstep" -> false + | _ -> fatal_error "Emit_hppa.hpux" + +(* Tradeoff between code size and code speed *) + +let fastcode_flag = ref true + +(* Layout of the stack *) +(* Always keep the stack 8-aligned. *) + +let stack_offset = ref 0 + +let frame_size () = + let size = + !stack_offset + + 4 * num_stack_slots.(0) + 8 * num_stack_slots.(1) + + (if !contains_calls then 4 else 0) in + Misc.align size 8 + +let slot_offset loc cl = + match loc with + Incoming n -> -frame_size() - n + | Local n -> + if cl = 0 + then - !stack_offset - num_stack_slots.(1) * 8 - n * 4 - 4 + else - !stack_offset - n * 8 - 8 + | Outgoing n -> -n + +(* Output a label *) + +let label_prefix = if hpux then "L$" else "L" + +let emit_label lbl = + emit_string label_prefix; emit_int lbl + +(* Output a symbol *) + +let symbol_prefix = if hpux then "" else "_" + +let emit_symbol s = + emit_string symbol_prefix; Emitaux.emit_symbol '$' s + +(* Output a pseudo-register *) + +let emit_reg r = + match r.loc with + Reg r -> emit_string (register_name r) + | _ -> fatal_error "Emit.emit_reg" + +(* Output low address / high address prefixes *) + +let low_prefix = if hpux then "RR'" else "R\`" +let high_prefix = if hpux then "LR'" else "L\`" + +let is_immediate n = (n < 16) && (n >= -16) (* 5 bits *) + +let emit_int_low n = emit_string low_prefix; emit_int n +let emit_int_high n = emit_string high_prefix; emit_int n + +let emit_nativeint_low n = emit_string low_prefix; emit_nativeint n +let emit_nativeint_high n = emit_string high_prefix; emit_nativeint n + +let emit_symbol_low s = + if hpux + then `RR'{emit_symbol s}-$global$` + else `R\`{emit_symbol s}` + +let load_symbol_high s = + if hpux + then ` addil LR'{emit_symbol s}-$global$, %r27\n` + else ` ldil L\`{emit_symbol s}, %r1\n` + +let load_symbol_offset_high s ofs = + if hpux + then ` addil LR'{emit_symbol s}-$global$+{emit_int ofs}, %r27\n` + else ` ldil L\`{emit_symbol s}+{emit_int ofs}, %r1\n` + +(* Record imported and defined symbols *) + +let used_symbols = ref StringSet.empty +let defined_symbols = ref StringSet.empty +let called_symbols = ref StringSet.empty + +let use_symbol s = + if hpux then used_symbols := StringSet.add s !used_symbols +let define_symbol s = + defined_symbols := StringSet.add s !defined_symbols +let call_symbol s = + if hpux then begin + used_symbols := StringSet.add s !used_symbols; + called_symbols := StringSet.add s !called_symbols + end + +(* An external symbol is code if either it is branched to, or + it does not start with an uppercase letter (for calls to + runtime functions). We need to special-case a few data symbols + that start with a lower case. *) + +let data_imports = + ["caml_globals_inited"; "nativeint_ops"; "int32_ops"; "int64_ops"] + +let emit_import s = + if not(StringSet.mem s !defined_symbols) then begin + ` .import {emit_symbol s}`; + if (StringSet.mem s !called_symbols || s.[0] < 'A' || s.[0] > 'Z') + && not (List.mem s data_imports) + then `, code\n` + else `, data\n` + end + +let emit_imports () = + StringSet.iter emit_import !used_symbols; + used_symbols := StringSet.empty; + defined_symbols := StringSet.empty; + called_symbols := StringSet.empty + +(* Output an integer load / store *) + +let is_offset n = (n < 8192) && (n >= -8192) (* 14 bits *) + +let is_offset_native n = + n < Nativeint.of_int 8192 && n >= Nativeint.of_int (-8192) + +let emit_load instr addr arg dst = + match addr with + Ibased(s, 0) -> + use_symbol s; + load_symbol_high s; + ` {emit_string instr} {emit_symbol_low s}(%r1), {emit_reg dst}\n` + | Ibased(s, ofs) -> + load_symbol_offset_high s ofs; + use_symbol s; + ` {emit_string instr} {emit_symbol_low s}+{emit_int ofs}(%r1), {emit_reg dst}\n` + | Iindexed ofs -> + if is_offset ofs then + ` {emit_string instr} {emit_int ofs}({emit_reg arg.(0)}), {emit_reg dst}\n` + else begin + ` addil {emit_int_high ofs}, {emit_reg arg.(0)}\n`; + ` {emit_string instr} {emit_int_low ofs}(%r1), {emit_reg dst}\n` + end + +let emit_store instr addr arg src = + match addr with + Ibased(s, 0) -> + use_symbol s; + load_symbol_high s; + ` {emit_string instr} {emit_reg src}, {emit_symbol_low s}(%r1)\n` + | Ibased(s, ofs) -> + use_symbol s; + load_symbol_offset_high s ofs; + ` {emit_string instr} {emit_reg src}, {emit_symbol_low s}+{emit_int ofs}(%r1)\n` + | Iindexed ofs -> + if is_offset ofs then + ` {emit_string instr} {emit_reg src}, {emit_int ofs}({emit_reg arg.(1)})\n` + else begin + ` addil {emit_int_high ofs}, {emit_reg arg.(0)}\n`; + ` {emit_string instr} {emit_reg src}, {emit_int_low ofs}(%r1)\n` + end + +(* Output a floating-point load / store *) + +let emit_float_load addr arg dst doubleword = + match addr with + Ibased(s, 0) -> + use_symbol s; + load_symbol_high s; + ` ldo {emit_symbol_low s}(%r1), %r1\n`; + ` fldws 0(%r1), {emit_reg dst}L\n`; + if doubleword then + ` fldws 4(%r1), {emit_reg dst}R\n` + | Ibased(s, ofs) -> + use_symbol s; + load_symbol_offset_high s ofs; + ` ldo {emit_symbol_low s}+{emit_int ofs}(%r1), %r1\n`; + ` fldws 0(%r1), {emit_reg dst}L\n`; + if doubleword then + ` fldws 4(%r1), {emit_reg dst}R\n` + | Iindexed ofs -> + if is_immediate ofs && (is_immediate (ofs+4) || not doubleword) + then begin + ` fldws {emit_int ofs}({emit_reg arg.(0)}), {emit_reg dst}L\n`; + if doubleword then + ` fldws {emit_int (ofs+4)}({emit_reg arg.(0)}), {emit_reg dst}R\n` + end else begin + if is_offset ofs then + ` ldo {emit_int ofs}({emit_reg arg.(0)}), %r1\n` + else begin + ` addil {emit_int_high ofs}, {emit_reg arg.(0)}\n`; + ` ldo {emit_int_low ofs}(%r1), %r1\n` + end; + ` fldws 0(%r1), {emit_reg dst}L\n`; + if doubleword then + ` fldws 4(%r1), {emit_reg dst}R\n` + end + +let emit_float_store addr arg src doubleword = + match addr with + Ibased(s, 0) -> + use_symbol s; + load_symbol_high s; + ` ldo {emit_symbol_low s}(%r1), %r1\n`; + ` fstws {emit_reg src}L, 0(%r1)\n`; + if doubleword then + ` fstws {emit_reg src}R, 4(%r1)\n` + | Ibased(s, ofs) -> + use_symbol s; + load_symbol_offset_high s ofs; + ` ldo {emit_symbol_low s}+{emit_int ofs}(%r1), %r1\n`; + ` fstws {emit_reg src}L, 0(%r1)\n`; + if doubleword then + ` fstws {emit_reg src}R, 4(%r1)\n` + | Iindexed ofs -> + if is_immediate ofs && (is_immediate (ofs+4) || not doubleword) + then begin + ` fstws {emit_reg src}L, {emit_int ofs}({emit_reg arg.(1)})\n`; + if doubleword then + ` fstws {emit_reg src}R, {emit_int(ofs+4)}({emit_reg arg.(1)})\n` + end else begin + if is_offset ofs then + ` ldo {emit_int ofs}({emit_reg arg.(1)}), %r1\n` + else begin + ` addil {emit_int_high ofs}, {emit_reg arg.(1)}\n`; + ` ldo {emit_int_low ofs}(%r1), %r1\n` + end; + ` fstws {emit_reg src}L, 0(%r1)\n`; + if doubleword then + ` fstws {emit_reg src}R, 4(%r1)\n` + end + +(* Output an align directive. + Under HPUX: alignment = number of bytes + Undex NextStep: alignment = log2 of number of bytes *) + +let emit_align n = + if hpux + then ` .align {emit_int n}\n` + else ` .align {emit_int(Misc.log2 n)}\n` + +(* Record live pointers at call points *) + +type frame_descr = + { fd_lbl: int; (* Return address *) + fd_frame_size: int; (* Size of stack frame *) + fd_live_offset: int list } (* Offsets/regs of live addresses *) + +let frame_descriptors = ref([] : frame_descr list) + +let record_frame live = + let lbl = new_label() in + let live_offset = ref [] in + Reg.Set.iter + (function + {typ = Addr; loc = Reg r} -> + live_offset := ((r lsl 1) + 1) :: !live_offset + | {typ = Addr; loc = Stack s} as reg -> + live_offset := slot_offset s (register_class reg) :: !live_offset + | _ -> ()) + live; + frame_descriptors := + { fd_lbl = lbl; + fd_frame_size = frame_size(); + fd_live_offset = !live_offset } :: !frame_descriptors; + `{emit_label lbl}:\n` + +let emit_frame fd = + ` .long {emit_label fd.fd_lbl} + 3\n`; + ` .short {emit_int fd.fd_frame_size}\n`; + ` .short {emit_int (List.length fd.fd_live_offset)}\n`; + List.iter + (fun n -> + ` .short {emit_int n}\n`) + fd.fd_live_offset; + emit_align 4 + +(* Record floating-point constants *) + +let float_constants = ref ([] : (int * string) list) + +let emit_float_constant (lbl, cst) = + if hpux then begin + ` .space $TEXT$\n`; + ` .subspa $LIT$\n` + end else + ` .literal8\n`; + emit_align 8; + `{emit_label lbl}: .double {emit_string cst}\n` + +(* Record external calls and generate stub code for these *) + +let stub_label_table = (Hashtbl.create 19 : (string, int) Hashtbl.t) + +let stub_label symb = + try + Hashtbl.find stub_label_table symb + with Not_found -> + let lbl = new_label() in + Hashtbl.add stub_label_table symb lbl; + lbl + +let emit_stub symb lbl = + `{emit_label lbl}: ldil L\`{emit_symbol symb}, %r1\n`; + ` ble,n {emit_symbol_low symb}(4, %r1)\n` + +let emit_stubs () = + ` .text\n`; + emit_align 4; + Hashtbl.iter emit_stub stub_label_table + +(* Describe the registers used to pass arguments to a C function *) + +let describe_call arg = + ` .CALL RTNVAL=NO`; + let pos = ref 0 in + for i = 0 to Array.length arg - 1 do + if !pos < 4 then begin + match arg.(i).typ with + Float -> `, ARGW{emit_int !pos}=FR, ARGW{emit_int(!pos + 1)}=FU`; + pos := !pos + 2 + | _ -> `, ARGW{emit_int !pos}=GR`; + pos := !pos + 1 + end + done; + `\n` + +(* Output a function call *) + +let emit_call s retreg = + if hpux then begin + ` bl {emit_symbol s}, {emit_string retreg}\n`; + call_symbol s + end else + if StringSet.mem s !defined_symbols then + ` bl {emit_symbol s}, {emit_string retreg}\n` + else begin + let lbl = stub_label s in + ` jbsr {emit_symbol s}, {emit_string retreg}, {emit_label lbl}\n` + end + +(* Names of various instructions *) + +let name_for_int_operation = function + Iadd -> "add" + | Isub -> "sub" + | Iand -> "and" + | Ior -> "or" + | Ixor -> "xor" + | _ -> Misc.fatal_error "Emit.name_for_int_operation" + +let name_for_float_operation = function + Iaddf -> "fadd,dbl" + | Isubf -> "fsub,dbl" + | Imulf -> "fmpy,dbl" + | Idivf -> "fdiv,dbl" + | _ -> Misc.fatal_error "Emit.name_for_float_operation" + +let name_for_specific_operation = function + Ishift1add -> "sh1add" + | Ishift2add -> "sh2add" + | Ishift3add -> "sh3add" + +let name_for_int_comparison = function + Isigned Ceq -> "=" | Isigned Cne -> "<>" + | Isigned Cle -> "<=" | Isigned Cgt -> ">" + | Isigned Clt -> "<" | Isigned Cge -> ">=" + | Iunsigned Ceq -> "=" | Iunsigned Cne -> "<>" + | Iunsigned Cle -> "<<=" | Iunsigned Cgt -> ">>" + | Iunsigned Clt -> "<<" | Iunsigned Cge -> ">>=" + +let name_for_float_comparison cmp neg = + match cmp with + Ceq -> if neg then "=" else "!=" + | Cne -> if neg then "!=" else "=" + | Cle -> if neg then "<=" else "!<=" + | Cgt -> if neg then ">" else "!>" + | Clt -> if neg then "<" else "!<" + | Cge -> if neg then ">=" else "!>=" + +let negate_int_comparison = function + Isigned cmp -> Isigned(Cmm.negate_comparison cmp) + | Iunsigned cmp -> Iunsigned(Cmm.negate_comparison cmp) + +let swap_int_comparison = function + Isigned cmp -> Isigned(Cmm.swap_comparison cmp) + | Iunsigned cmp -> Iunsigned(Cmm.swap_comparison cmp) + + +(* Output the assembly code for an instruction *) + +(* Name of current function *) +let function_name = ref "" +(* Entry point for tail recursive calls *) +let tailrec_entry_point = ref 0 +(* Label of trap for out-of-range accesses *) +let range_check_trap = ref 0 + +let rec emit_instr i dslot = + match i.desc with + Lend -> () + | Lop(Imove | Ispill | Ireload) -> + let src = i.arg.(0) and dst = i.res.(0) in + begin match (src, dst) with + {loc = Reg rs; typ = (Int | Addr)}, {loc = Reg rd} -> + ` copy {emit_reg src}, {emit_reg dst}\n` + | {loc = Reg rs; typ = Float}, {loc = Reg rd; typ = Float} -> + ` fcpy,dbl {emit_reg src}, {emit_reg dst}\n` + | {loc = Reg rs; typ = (Int | Addr)}, {loc = Stack sd} -> + let ofs = slot_offset sd 0 in + ` stw {emit_reg src}, {emit_int ofs}(%r30)\n` + | {loc = Reg rs; typ = Float}, {loc = Stack sd} -> + let ofs = slot_offset sd 1 in + if is_immediate ofs then + ` fstds {emit_reg src}, {emit_int ofs}(%r30)\n` + else begin + ` ldo {emit_int ofs}(%r30), %r1\n`; + ` fstds {emit_reg src}, 0(%r1)\n` + end + | {loc = Stack ss; typ = (Int | Addr)}, {loc = Reg rd} -> + let ofs = slot_offset ss 0 in + ` ldw {emit_int ofs}(%r30), {emit_reg dst}\n` + | {loc = Stack ss; typ = Float}, {loc = Reg rd} -> + let ofs = slot_offset ss 1 in + if is_immediate ofs then + ` fldds {emit_int ofs}(%r30), {emit_reg dst}\n` + else begin + ` ldo {emit_int ofs}(%r30), %r1\n`; + ` fldds 0(%r1), {emit_reg dst}\n` + end + | (_, _) -> + fatal_error "Emit: Imove" + end + | Lop(Iconst_int n) -> + if is_offset_native n then + ` ldi {emit_nativeint n}, {emit_reg i.res.(0)}\n` + else begin + ` ldil {emit_nativeint_high n}, {emit_reg i.res.(0)}\n`; + ` ldo {emit_nativeint_low n}({emit_reg i.res.(0)}), {emit_reg i.res.(0)}\n` + end + | Lop(Iconst_float s) -> + let lbl = new_label() in + float_constants := (lbl, s) :: !float_constants; + ` ldil {emit_string high_prefix}{emit_label lbl}, %r1\n`; + ` ldo {emit_string low_prefix}{emit_label lbl}(%r1), %r1\n`; + ` fldds 0(%r1), {emit_reg i.res.(0)}\n` + | Lop(Iconst_symbol s) -> + use_symbol s; + load_symbol_high s; + ` ldo {emit_symbol_low s}(%r1), {emit_reg i.res.(0)}\n` + | Lop(Icall_ind) -> + ` ble 0(4, {emit_reg i.arg.(0)})\n`; (* retaddr in %r31 *) + ` copy %r31, %r2\n`; (* in delay slot: save retaddr in %r2 *) + record_frame i.live + | Lop(Icall_imm s) -> + emit_call s "%r2"; + fill_delay_slot dslot; + record_frame i.live + | Lop(Itailcall_ind) -> + let n = frame_size() in + ` bv 0({emit_reg i.arg.(0)})\n`; + if !contains_calls (* in delay slot *) + then ` ldwm {emit_int(-n)}(%r30), %r2\n` + else ` ldo {emit_int(-n)}(%r30), %r30\n` + | Lop(Itailcall_imm s) -> + let n = frame_size() in + if s = !function_name then begin + ` b,n {emit_label !tailrec_entry_point}\n` + end else begin + emit_call s "%r0"; + if !contains_calls (* in delay slot *) + then ` ldwm {emit_int(-n)}(%r30), %r2\n` + else ` ldo {emit_int(-n)}(%r30), %r30\n` + end + | Lop(Iextcall(s, alloc)) -> + if alloc then begin + call_symbol s; + if hpux then begin + ` ldil LR'{emit_symbol s}, %r22\n`; + describe_call i.arg; + emit_call "caml_c_call" "%r2"; + ` ldo RR'{emit_symbol s}(%r22), %r22\n` (* in delay slot *) + end else begin + ` ldil L\`{emit_symbol s}, %r22\n`; + emit_call "caml_c_call" "%r2"; + ` ldo {emit_symbol_low s}(%r22), %r22\n` (* in delay slot *) + end; + record_frame i.live + end else begin + if hpux then describe_call i.arg; + emit_call s "%r2"; + fill_delay_slot dslot + end + | Lop(Istackoffset n) -> + ` ldo {emit_int n}(%r30), %r30\n`; + stack_offset := !stack_offset + n + | Lop(Iload(chunk, addr)) -> + let dest = i.res.(0) in + begin match chunk with + Byte_unsigned -> + emit_load "ldb" addr i.arg dest + | Byte_signed -> + emit_load "ldb" addr i.arg dest; + ` extrs {emit_reg dest}, 31, 8, {emit_reg dest}\n` + | Sixteen_unsigned -> + emit_load "ldh" addr i.arg dest + | Sixteen_signed -> + emit_load "ldh" addr i.arg dest; + ` extrs {emit_reg dest}, 31, 16, {emit_reg dest}\n` + | Single -> + emit_float_load addr i.arg dest false; + ` fcnvff,sgl,dbl {emit_reg dest}L, {emit_reg dest}\n` + | Double | Double_u -> + emit_float_load addr i.arg dest true + | _ -> + emit_load "ldw" addr i.arg dest + end + | Lop(Istore(chunk, addr)) -> + let src = i.arg.(0) in + begin match chunk with + Byte_unsigned | Byte_signed -> + emit_store "stb" addr i.arg src + | Sixteen_unsigned | Sixteen_signed -> + emit_store "sth" addr i.arg src + | Single -> + ` fcnvff,dbl,sgl {emit_reg src}, %fr31L\n`; + emit_float_store addr i.arg (phys_reg 127) (* %fr31 *) false + | Double | Double_u -> + emit_float_store addr i.arg src true + | _ -> + emit_store "stw" addr i.arg src + end + | Lop(Ialloc n) -> + if !fastcode_flag then begin + let lbl_cont = new_label() in + ` ldw 0(%r4), %r1\n`; + ` ldo {emit_int (-n)}(%r3), %r3\n`; + ` comb,>>= %r3, %r1, {emit_label lbl_cont}\n`; + ` addi 4, %r3, {emit_reg i.res.(0)}\n`; (* in delay slot *) + emit_call "caml_call_gc" "%r2"; + (* Cannot use %r1 to pass size, since clobbered by glue call code *) + ` ldi {emit_int n}, %r29\n`; (* in delay slot *) + record_frame i.live; + ` addi 4, %r3, {emit_reg i.res.(0)}\n`; + `{emit_label lbl_cont}:\n` + end else begin + emit_call "caml_alloc" "%r2"; + (* Cannot use %r1 either *) + ` ldi {emit_int n}, %r29\n`; (* in delay slot *) + record_frame i.live; + ` addi 4, %r3, {emit_reg i.res.(0)}\n` (* in delay slot *) + end + | Lop(Iintop Imul) -> + ` stws,ma {emit_reg i.arg.(0)}, 8(%r30)\n`; + ` stw {emit_reg i.arg.(1)}, -4(%r30)\n`; + ` fldws -8(%r30), %fr31L\n`; + ` fldws -4(%r30), %fr31R\n`; + ` xmpyu %fr31L, %fr31R, %fr31\n`; + ` fstws %fr31R, -8(%r30)\n`; (* poor scheduling *) + ` ldws,mb -8(%r30), {emit_reg i.res.(0)}\n` + | Lop(Iintop Idiv) -> + (* Arguments are assumed to be in %r26 and %r25, result in %r29 *) + if hpux then + ` bl $$divI, %r31\n` + else begin + ` ldil L\`$$divI, %r1\n`; + ` ble R\`$$divI(4, %r1)\n` + end; + fill_delay_slot dslot + | Lop(Iintop Imod) -> + (* Arguments are assumed to be in %r26 and %r25, result in %r29 *) + if hpux then + ` bl $$remI, %r31\n` + else begin + ` ldil L\`$$remI, %r1\n`; + ` ble R\`$$remI(4, %r1)\n` + end; + fill_delay_slot dslot + | Lop(Iintop Ilsl) -> + ` subi 31, {emit_reg i.arg.(1)}, %r1\n`; + ` mtsar %r1\n`; + ` zvdep {emit_reg i.arg.(0)}, 32, {emit_reg i.res.(0)}\n` + | Lop(Iintop Ilsr) -> + ` mtsar {emit_reg i.arg.(1)}\n`; + ` vshd %r0, {emit_reg i.arg.(0)}, {emit_reg i.res.(0)}\n` + | Lop(Iintop Iasr) -> + ` subi 31, {emit_reg i.arg.(1)}, %r1\n`; + ` mtsar %r1\n`; + ` vextrs {emit_reg i.arg.(0)}, 32, {emit_reg i.res.(0)}\n` + | Lop(Iintop(Icomp cmp)) -> + let comp = name_for_int_comparison(negate_int_comparison cmp) in + ` comclr,{emit_string comp} {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.res.(0)}\n`; + ` ldi 1, {emit_reg i.res.(0)}\n` + | Lop(Iintop Icheckbound) -> + if !range_check_trap = 0 then range_check_trap := new_label(); + ` comclr,>> {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, %r0\n`; + ` b,n {emit_label !range_check_trap}\n` + | Lop(Iintop op) -> + let instr = name_for_int_operation op in + ` {emit_string instr} {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.res.(0)}\n` + | Lop(Iintop_imm(Iadd, n)) -> + ` addi {emit_int n}, {emit_reg i.arg.(0)}, {emit_reg i.res.(0)}\n` + | Lop(Iintop_imm(Isub, n)) -> + ` addi {emit_int(-n)}, {emit_reg i.arg.(0)}, {emit_reg i.res.(0)}\n` + | Lop(Iintop_imm(Idiv, n)) -> + let l = Misc.log2 n in + ` comclr,>= {emit_reg i.arg.(0)}, %r0, %r1\n`; + ` zdepi -1, 31, {emit_int l}, %r1\n`; + ` add {emit_reg i.arg.(0)}, %r1, %r1\n`; + ` extrs %r1, {emit_int(31-l)}, {emit_int(32-l)}, {emit_reg i.res.(0)}\n` + | Lop(Iintop_imm(Imod, n)) -> + let l = Misc.log2 n in + ` comclr,>= {emit_reg i.arg.(0)}, %r0, %r1\n`; + ` zdepi -1, 31, {emit_int l}, %r1\n`; + ` add {emit_reg i.arg.(0)}, %r1, %r1\n`; + ` depi 0, 31, {emit_int l}, %r1\n`; + ` sub {emit_reg i.arg.(0)}, %r1, {emit_reg i.res.(0)}\n` + | Lop(Iintop_imm(Ilsl, n)) -> + let n = n land 31 in + ` zdep {emit_reg i.arg.(0)}, {emit_int(31-n)}, {emit_int(32-n)}, {emit_reg i.res.(0)}\n` + | Lop(Iintop_imm(Ilsr, n)) -> + let n = n land 31 in + ` extru {emit_reg i.arg.(0)}, {emit_int(31-n)}, {emit_int(32-n)}, {emit_reg i.res.(0)}\n` + | Lop(Iintop_imm(Iasr, n)) -> + let n = n land 31 in + ` extrs {emit_reg i.arg.(0)}, {emit_int(31-n)}, {emit_int(32-n)}, {emit_reg i.res.(0)}\n` + | Lop(Iintop_imm(Icomp cmp, n)) -> + let comp = name_for_int_comparison(negate_int_comparison(swap_int_comparison cmp)) in + ` comiclr,{emit_string comp} {emit_int n}, {emit_reg i.arg.(0)}, {emit_reg i.res.(0)}\n`; + ` ldi 1, {emit_reg i.res.(0)}\n` + | Lop(Iintop_imm(Icheckbound, n)) -> + if !range_check_trap = 0 then range_check_trap := new_label(); + ` comiclr,<< {emit_int n}, {emit_reg i.arg.(0)}, %r0\n`; + ` b,n {emit_label !range_check_trap}\n` + | Lop(Iintop_imm(op, n)) -> + fatal_error "Emit_hppa: Iintop_imm" + | Lop(Iaddf | Isubf | Imulf | Idivf as op) -> + let instr = name_for_float_operation op in + ` {emit_string instr} {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.res.(0)}\n` + | Lop(Inegf) -> + ` fsub,dbl 0, {emit_reg i.arg.(0)}, {emit_reg i.res.(0)}\n` + | Lop(Iabsf) -> + ` fabs,dbl {emit_reg i.arg.(0)}, {emit_reg i.res.(0)}\n` + | Lop(Ifloatofint) -> + ` stws,ma {emit_reg i.arg.(0)}, 8(%r30)\n`; + ` fldws,mb -8(%r30), %fr31L\n`; + ` fcnvxf,sgl,dbl %fr31L, {emit_reg i.res.(0)}\n` + | Lop(Iintoffloat) -> + ` fcnvfxt,dbl,sgl {emit_reg i.arg.(0)}, %fr31L\n`; + ` fstws,ma %fr31L, 8(%r30)\n`; + ` ldws,mb -8(%r30), {emit_reg i.res.(0)}\n` + | Lop(Ispecific sop) -> + let instr = name_for_specific_operation sop in + ` {emit_string instr} {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.res.(0)}\n` + | Lreloadretaddr -> + let n = frame_size() in + ` ldw {emit_int(-n)}(%r30), %r2\n` + | Lreturn -> + let n = frame_size() in + ` bv 0(%r2)\n`; + ` ldo {emit_int(-n)}(%r30), %r30\n` (* in delay slot *) + | Llabel lbl -> + `{emit_label lbl}:\n` + | Lbranch lbl -> + begin match dslot with + None -> + ` b,n {emit_label lbl}\n` + | Some i -> + ` b {emit_label lbl}\n`; + emit_instr i None + end + | Lcondbranch(tst, lbl) -> + begin match tst with + Itruetest -> + emit_comib "<>" "=" 0 i.arg lbl dslot + | Ifalsetest -> + emit_comib "=" "<>" 0 i.arg lbl dslot + | Iinttest cmp -> + let comp = name_for_int_comparison cmp + and negcomp = + name_for_int_comparison(negate_int_comparison cmp) in + emit_comb comp negcomp i.arg lbl dslot + | Iinttest_imm(cmp, n) -> + let scmp = swap_int_comparison cmp in + let comp = name_for_int_comparison scmp + and negcomp = + name_for_int_comparison(negate_int_comparison scmp) in + emit_comib comp negcomp n i.arg lbl dslot + | Ifloattest(cmp, neg) -> + let comp = name_for_float_comparison cmp neg in + ` fcmp,dbl,{emit_string comp} {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; + ` ftest\n`; + ` b {emit_label lbl}\n`; + fill_delay_slot dslot + | Ioddtest -> + emit_comib "OD" "EV" 0 i.arg lbl dslot + | Ieventest -> + emit_comib "EV" "OD" 0 i.arg lbl dslot + end + | Lcondbranch3(lbl0, lbl1, lbl2) -> + begin match lbl0 with + None -> () + | Some lbl -> emit_comib "=" "<>" 0 i.arg lbl None + end; + begin match lbl1 with + None -> () + | Some lbl -> emit_comib "=" "<>" 1 i.arg lbl None + end; + begin match lbl2 with + None -> () + | Some lbl -> emit_comib "=" "<>" 2 i.arg lbl None + end + | Lswitch jumptbl -> + ` blr {emit_reg i.arg.(0)}, 0\n`; + fill_delay_slot dslot; + for i = 0 to Array.length jumptbl - 1 do + ` b {emit_label jumptbl.(i)}\n`; + ` nop\n` + done + | Lsetuptrap lbl -> + ` bl {emit_label lbl}, %r1\n`; + fill_delay_slot dslot + | Lpushtrap -> + stack_offset := !stack_offset + 8; + ` stws,ma %r5, 8(%r30)\n`; + ` stw %r1, -4(%r30)\n`; + ` copy %r30, %r5\n` + | Lpoptrap -> + ` ldws,mb -8(%r30), %r5\n`; + stack_offset := !stack_offset - 8 + | Lraise -> + ` ldw -4(%r5), %r1\n`; + ` copy %r5, %r30\n`; + ` bv 0(%r1)\n`; + ` ldws,mb -8(%r30), %r5\n` (* in delay slot *) + +and fill_delay_slot = function + None -> ` nop\n` + | Some i -> emit_instr i None + +and emit_delay_slot = function + None -> () + | Some i -> emit_instr i None + +and emit_comb comp negcomp arg lbl dslot = + if lbl >= 0 then begin + ` comb,{emit_string comp} {emit_reg arg.(0)}, {emit_reg arg.(1)}, {emit_label lbl}\n`; + fill_delay_slot dslot + end else begin + emit_delay_slot dslot; + ` comclr,{emit_string negcomp} {emit_reg arg.(0)}, {emit_reg arg.(1)}, %r0\n`; + ` b,n {emit_label (-lbl)}\n` + end + +and emit_comib comp negcomp cst arg lbl dslot = + if lbl >= 0 then begin + ` comib,{emit_string comp} {emit_int cst}, {emit_reg arg.(0)}, {emit_label lbl}\n`; + fill_delay_slot dslot + end else begin + emit_delay_slot dslot; + ` comiclr,{emit_string negcomp} {emit_int cst}, {emit_reg arg.(0)}, %r0\n`; + ` b,n {emit_label (-lbl)}\n` + end + +(* Checks if a pseudo-instruction expands to exactly one machine instruction + that does not branch. *) + +let is_one_instr i = + match i.desc with + Lop op -> + begin match op with + Imove | Ispill | Ireload -> + begin match (i.arg.(0), i.res.(0)) with + ({typ = Float; loc = Stack s}, _) -> is_immediate(slot_offset s 1) + | (_, {typ = Float; loc = Stack s}) -> is_immediate(slot_offset s 1) + | (_, _) -> true + end + | Iconst_int n -> is_offset_native n + | Istackoffset _ -> true + | Iload(_, Iindexed n) -> i.res.(0).typ <> Float & is_offset n + | Istore(_, Iindexed n) -> i.arg.(0).typ <> Float & is_offset n + | Iintop(Iadd | Isub | Iand | Ior | Ixor) -> true + | Iintop_imm((Iadd | Isub | Ilsl | Ilsr | Iasr), _) -> true + | Inegf | Iabsf | Iaddf | Isubf | Imulf | Idivf -> true + | Ispecific _ -> true + | _ -> false + end + | Lreloadretaddr -> true + | _ -> false + +let no_interference res arg = + try + for i = 0 to Array.length arg - 1 do + for j = 0 to Array.length res - 1 do + if arg.(i).loc = res.(j).loc then raise Exit + done + done; + true + with Exit -> + false + +(* Emit a sequence of instructions, trying to fill delay slots for branches *) + +let rec emit_all i = + match i with + {desc = Lend} -> () + | {next = {desc = Lop(Icall_imm _) + | Lop(Iextcall(_, false)) + | Lop(Iintop(Idiv | Imod)) + | Lbranch _ + | Lsetuptrap _ }} + when is_one_instr i -> + emit_instr i.next (Some i); + emit_all i.next.next + | {next = {desc = Lcondbranch(_, _) | Lswitch _}} + when is_one_instr i & no_interference i.res i.next.arg -> + emit_instr i.next (Some i); + emit_all i.next.next + | _ -> + emit_instr i None; + emit_all i.next + +(* Estimate the size of an instruction, in actual HPPA instructions *) + +let is_float_stack r = + match r with {loc = Stack _; typ = Float} -> true | _ -> false + +let sizeof_instr i = + match i.desc with + Lend -> 0 + | Lop op -> + begin match op with + Imove | Ispill | Ireload -> + if is_float_stack i.arg.(0) || is_float_stack i.res.(0) + then 2 (* ldo/fxxx *) else 1 + | Iconst_int n -> + if is_offset_native n then 1 else 2 (* ldi or ldil/ldo *) + | Iconst_float _ -> 3 (* ldil/ldo/fldds *) + | Iconst_symbol _ -> 2 (* addil/ldo *) + | Icall_ind -> 2 (* ble/copy *) + | Icall_imm _ -> 2 (* bl/nop *) + | Itailcall_ind -> 2 (* bv/ldwm *) + | Itailcall_imm _ -> 2 (* bl/ldwm *) + | Iextcall(_, alloc) -> + if alloc then 3 (* ldil/bl/ldo *) else 2 (* bl/nop *) + | Istackoffset _ -> 1 (* ldo *) + | Iload(chunk, addr) -> + if i.res.(0).typ = Float + then 4 (* addil/ldo/fldws/fldws *) + else (match addr with Iindexed ofs when is_offset ofs -> 1 | _ -> 2) + + (match chunk with Byte_signed -> 1 | Sixteen_signed -> 1 | _ -> 0) + | Istore(chunk, addr) -> + if i.arg.(0).typ = Float + then 4 (* addil/ldo/fstws/fstws *) + else (match addr with Iindexed ofs when is_offset ofs -> 1 | _ -> 2) + | Ialloc _ -> if !fastcode_flag then 7 else 3 + | Iintop Imul -> 7 + | Iintop(Idiv | Imod) -> 3 (* ldil/ble/nop *) + | Iintop Ilsl -> 3 (* subi/mtsar/zvdep *) + | Iintop Ilsr -> 2 (* mtsar/vshd *) + | Iintop Iasr -> 3 (* subi/mtsar/vextrs *) + | Iintop(Icomp _) -> 2 (* comclr/ldi *) + | Iintop Icheckbound -> 2 (* comclr/b,n *) + | Iintop _ -> 1 + | Iintop_imm(Idiv, _) -> 4 (* comclr/zdepi/add/extrs *) + | Iintop_imm(Imod, _) -> 5 (* comclr/zdepi/add/extrs/sub *) + | Iintop_imm(Icomp _, _) -> 2 (* comiclr/ldi *) + | Iintop_imm(Icheckbound, _) -> 2 (* comiclr/b,n *) + | Iintop_imm(_, _) -> 1 + | Ifloatofint -> 3 (* stws,ma/fldws,mb/fcnvxf *) + | Iintoffloat -> 3 (* fcnfxt/fstws/ldws *) + | _ (* Inegf|Iabsf|Iaddf|Isubf|Imulf|Idivf|Ispecific _ *) -> 1 + end + | Lreloadretaddr -> 1 + | Lreturn -> 2 + | Llabel _ -> 0 + | Lbranch _ -> 1 (* b,n *) + | Lcondbranch(Ifloattest(_, _), _) -> 4 (* fcmp/ftest/b/nop *) + | Lcondbranch(_, _) -> 2 (* comb/nop or comclr/b,n *) + | Lcondbranch3(_, _, _) -> 6 (* worst case: three comib/nop or comclr/b,n *) + | Lswitch tbl -> 2 + 2 * Array.length tbl (* blr/nop b/nop *) + | Lsetuptrap _ -> 2 (* bl/nop *) + | Lpushtrap -> 3 (* stws,ma/stw/copy *) + | Lpoptrap -> 1 (* ldws,mb *) + | Lraise -> 4 (* ldw/copy/bv/ldws,mb *) + +(* Estimate the position of all labels in function body + and rewrite long conditional branches with a negative label. *) + +let fixup_cond_branches funbody = + let label_position = + (Hashtbl.create 87 : (label, int) Hashtbl.t) in + let rec estimate_labels pos i = + match i.desc with + Lend -> () + | Llabel lbl -> + Hashtbl.add label_position lbl pos; estimate_labels pos i.next + | _ -> estimate_labels (pos + sizeof_instr i) i.next in + let long_branch currpos lbl = + try + let displ = Hashtbl.find label_position lbl - currpos in + (* Branch offset is stored in 12 bits, giving a range of + -2048 to +2047. Here, we allow 10% error in estimating + the code positions. *) + displ < -1843 || displ > 1842 + with Not_found -> + fatal_error "Emit_hppa.long_branch" in + let rec fix_branches pos i = + match i.desc with + Lend -> () + | Lcondbranch(tst, lbl) -> + if long_branch pos lbl then i.desc <- Lcondbranch(tst, -lbl); + fix_branches (pos + sizeof_instr i) i.next + | Lcondbranch3(opt1, opt2, opt3) -> + let fix_opt = function + None -> None + | Some lbl -> Some(if long_branch pos lbl then -lbl else lbl) in + i.desc <- Lcondbranch3(fix_opt opt1, fix_opt opt2, fix_opt opt3); + fix_branches (pos + sizeof_instr i) i.next + | _ -> + fix_branches (pos + sizeof_instr i) i.next in + estimate_labels 0 funbody; + fix_branches 0 funbody + +(* Emission of a function declaration *) + +let fundecl fundecl = + fixup_cond_branches fundecl.fun_body; + function_name := fundecl.fun_name; + fastcode_flag := fundecl.fun_fast; + tailrec_entry_point := new_label(); + stack_offset := 0; + float_constants := []; + define_symbol fundecl.fun_name; + range_check_trap := 0; + let n = frame_size() in + if hpux then begin + ` .code\n`; + ` .align 4\n`; + ` .export {emit_symbol fundecl.fun_name}, entry, priv_lev=3\n`; + `{emit_symbol fundecl.fun_name}:\n`; + ` .proc\n`; + if !contains_calls then + ` .callinfo frame={emit_int n}, calls, save_rp\n` + else + ` .callinfo frame={emit_int n}, no_calls\n`; + ` .entry\n` + end else begin + ` .text\n`; + ` .align 2\n`; + ` .globl {emit_symbol fundecl.fun_name}\n`; + `{emit_symbol fundecl.fun_name}:\n` + end; + if !contains_calls then + ` stwm %r2, {emit_int n}(%r30)\n` + else if n > 0 then + ` ldo {emit_int n}(%r30), %r30\n`; + `{emit_label !tailrec_entry_point}:\n`; + emit_all fundecl.fun_body; + if !range_check_trap > 0 then begin + `{emit_label !range_check_trap}:\n`; + if hpux then begin + emit_call "caml_array_bound_error" "%r31"; + ` nop\n` + end else begin + ` ldil L\`{emit_symbol "caml_array_bound_error"}, %r1\n`; + ` ble,n {emit_symbol_low "caml_array_bound_error"}(4, %r1)\n` + end + end; + if hpux then begin + ` .exit\n`; + ` .procend\n` + end; + List.iter emit_float_constant !float_constants + +(* Emission of data *) + +let declare_global s = + define_symbol s; + if hpux + then ` .export {emit_symbol s}, data\n` + else ` .globl {emit_symbol s}\n` + +let emit_item = function + Cglobal_symbol s -> + declare_global s + | Cdefine_symbol s -> + define_symbol s; + `{emit_symbol s}:\n` + | Cdefine_label lbl -> + `{emit_label (lbl + 100000)}:\n` + | Cint8 n -> + ` .byte {emit_int n}\n` + | Cint16 n -> + ` .short {emit_int n}\n` + | Cint32 n -> + ` .long {emit_nativeint n}\n` + | Cint n -> + ` .long {emit_nativeint n}\n` + | Csingle f -> + ` .float {emit_string f}\n` + | Cdouble f -> + ` .double {emit_string f}\n` + | Csymbol_address s -> + if hpux && String.length s >= 5 && String.sub s 0 5 = "caml_" then + ` .import {emit_symbol s}, code\n`; + ` .long {emit_symbol s}\n` + | Clabel_address lbl -> + ` .long {emit_label(lbl + 100000)}\n` + | Cstring s -> + emit_string_directive " .ascii " s + | Cskip n -> + if n > 0 then + if hpux then ` .block {emit_int n}\n` + else ` .space {emit_int n}\n` + | Calign n -> + emit_align n + +let data l = + ` .data\n`; + List.iter emit_item l + +(* Beginning / end of an assembly file *) + +let begin_assembly() = + if hpux then begin + ` .space $PRIVATE$\n`; + ` .subspa $DATA$,quad=1,align=8,access=31\n`; + ` .subspa $BSS$,quad=1,align=8,access=31,zero,sort=82\n`; + ` .space $TEXT$\n`; + ` .subspa $LIT$,quad=0,align=8,access=44\n`; + ` .subspa $CODE$,quad=0,align=8,access=44,code_only\n`; + ` .import $global$, data\n`; + ` .import $$divI, millicode\n`; + ` .import $$remI, millicode\n` + end; + used_symbols := StringSet.empty; + defined_symbols := StringSet.empty; + called_symbols := StringSet.empty; + Hashtbl.clear stub_label_table; + let lbl_begin = Compilenv.current_unit_name() ^ "__data_begin" in + ` .data\n`; + emit_global lbl_begin; + `{emit_symbol lbl_begin}:\n`; + let lbl_begin = Compilenv.current_unit_name() ^ "__code_begin" in + ` .code\n`; + emit_global lbl_begin; + `{emit_symbol lbl_begin}:\n` + + +let end_assembly() = + if not hpux then emit_stubs(); + ` .code\n`; + let lbl_end = Compilenv.current_unit_name() ^ "__code_end" in + emit_global lbl_end; + `{emit_symbol lbl_end}:\n`; + ` .data\n`; + let lbl_end = Compilenv.current_unit_name() ^ "__data_end" in + emit_global lbl_end; + `{emit_symbol lbl_end}:\n`; + ` .long 0\n`; + let lbl = Compilenv.current_unit_name() ^ "__frametable" in + emit_global lbl; + `{emit_symbol lbl}:\n`; + ` .long {emit_int (List.length !frame_descriptors)}\n`; + List.iter emit_frame !frame_descriptors; + frame_descriptors := []; + if hpux then emit_imports() diff --git a/asmcomp/hppa/proc.ml b/asmcomp/hppa/proc.ml new file mode 100644 index 00000000..e53643a3 --- /dev/null +++ b/asmcomp/hppa/proc.ml @@ -0,0 +1,223 @@ +(***********************************************************************) +(* *) +(* 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: proc.ml,v 1.6 2002/07/22 16:37:49 doligez Exp $ *) + +(* Description of the HP PA-RISC processor *) + +open Misc +open Cmm +open Reg +open Arch +open Mach + +(* Registers available for register allocation *) + +(* Register map: + %r0 always zero + %r1 temporary, target of ADDIL + %r2 return address + %r3 allocation pointer + %r4 allocation limit + %r5 trap pointer + %r6 - %r26 general purpose + %r27 global pointer + %r28 - %r29 general purpose, C function results + %r30 stack pointer + %r31 temporary, used by BLE + + %fr0 - %fr3 float status info + %fr4 - %fr30 general purpose + %fr31 temporary *) + +let int_reg_name = [| + (* 0-4 *) "%r6"; "%r7"; "%r8"; "%r9"; "%r10"; + (* 5-10 *) "%r11"; "%r12"; "%r13"; "%r14"; "%r15"; "%r16"; + (* 11-16 *) "%r17"; "%r18"; "%r19"; "%r20"; "%r21"; "%r22"; + (* 17-20 *) "%r23"; "%r24"; "%r25"; "%r26"; + (* 21-22 *) "%r28"; "%r29" +|] + +let float_reg_name = [| + (* 100-105 *) "%fr4"; "%fr5"; "%fr6"; "%fr7"; "%fr8"; "%fr9"; + (* 106-111 *) "%fr10"; "%fr11"; "%fr12"; "%fr13"; "%fr14"; "%fr15"; + (* 112-117 *) "%fr16"; "%fr17"; "%fr18"; "%fr19"; "%fr20"; "%fr21"; + (* 118-123 *) "%fr22"; "%fr23"; "%fr24"; "%fr25"; "%fr26"; "%fr27"; + (* 124-127 *) "%fr28"; "%fr29"; "%fr30"; "%fr31" +|] + +let num_register_classes = 2 + +let register_class r = + match r.typ with + Int -> 0 + | Addr -> 0 + | Float -> 1 + +let num_available_registers = [| 23; 27 |] + +let first_available_register = [| 0; 100 |] + +let register_name r = + if r < 100 then int_reg_name.(r) else float_reg_name.(r - 100) + +let rotate_registers = true + +(* Representation of hard registers by pseudo-registers *) + +let hard_int_reg = + let v = Array.create 23 Reg.dummy in + for i = 0 to 22 do v.(i) <- Reg.at_location Int (Reg i) done; + v + +let hard_float_reg = + let v = Array.create 28 Reg.dummy in + for i = 0 to 27 do v.(i) <- Reg.at_location Float (Reg(100 + i)) done; + v + +let all_phys_regs = + Array.append hard_int_reg (Array.sub hard_float_reg 0 27) + (* No need to include the left/right parts of float registers *) + +let phys_reg n = + if n < 100 then hard_int_reg.(n) else hard_float_reg.(n - 100) + +let stack_slot slot ty = + Reg.at_location ty (Stack slot) + +(* Instruction selection *) + +let word_addressed = false + +(* Calling conventions *) + +let calling_conventions first_int last_int first_float last_float make_stack + arg = + let loc = Array.create (Array.length arg) Reg.dummy in + let int = ref first_int in + let float = ref first_float in + let ofs = ref 0 in + for i = 0 to Array.length arg - 1 do + match arg.(i).typ with + Int | Addr as ty -> + if !int >= last_int then begin + loc.(i) <- phys_reg !int; + decr int + end else begin + ofs := !ofs + size_int; + loc.(i) <- stack_slot (make_stack !ofs) ty + end + | Float -> + if !float <= last_float then begin + loc.(i) <- phys_reg !float; + incr float + end else begin + ofs := Misc.align (!ofs + size_float) 8; + loc.(i) <- stack_slot (make_stack !ofs) Float + end + done; + (loc, Misc.align !ofs 8) (* Keep stack 8-aligned *) + +let incoming ofs = Incoming ofs +let outgoing ofs = Outgoing ofs +let not_supported ofs = fatal_error "Proc.loc_results: cannot call" + +(* Arguments and results: %r26-%r19, %fr4-%fr11. *) + +let loc_arguments arg = + calling_conventions 20 13 100 107 outgoing arg +let loc_parameters arg = + let (loc, ofs) = calling_conventions 20 13 100 107 incoming arg in loc +let loc_results res = + let (loc, ofs) = calling_conventions 20 13 100 107 not_supported res in loc + +(* Calling C functions: + when all arguments are integers, use %r26 - %r23, + then -52(%r30), -56(%r30), etc. + When some arguments are floats, we handle a couple of cases by hand + and fail otherwise. *) + +let loc_external_arguments arg = + match List.map register_class (Array.to_list arg) with + [1] -> ([| phys_reg 101 |], 56) (* %fr5 *) + | [1; 1] -> ([| phys_reg 101; phys_reg 103 |], 56) (* %fr5, %fr7 *) + | [1; 0] -> ([| phys_reg 101; phys_reg 18 |], 56) (* %fr5, %r24 *) + | [0; 1] -> ([| phys_reg 20; phys_reg 103 |], 56) (* %r26, %fr7 *) + | _ -> + let loc = Array.create (Array.length arg) Reg.dummy in + let int = ref 20 in + let ofs = ref 48 in + for i = 0 to Array.length arg - 1 do + match arg.(i).typ with + Int | Addr as ty -> + if !int >= 17 then begin + loc.(i) <- phys_reg (!int); + decr int + end else begin + ofs := !ofs + 4; + loc.(i) <- stack_slot (Outgoing !ofs) ty + end + | Float -> + fatal_error "Proc.external_calling_conventions: cannot call" + done; + (loc, Misc.align !ofs 8) + +let loc_external_results res = + let (loc, ofs) = calling_conventions 21 21 100 100 not_supported res in loc + +let loc_exn_bucket = phys_reg 20 (* %r26 *) + +(* Registers destroyed by operations *) + +let destroyed_at_c_call = (* %r3 - %r18, %fr12 - %fr21 preserved *) + Array.of_list(List.map phys_reg + [13;14;15;16;17;18;19;20;21;22; + 100;101;102;103;104;105;106;107;118;119;120;121;122;123;124;125;126]) + +let destroyed_by_millicode = (* %r25, %r26, %r28, %r29 -- more? *) + [| phys_reg 19; phys_reg 20; phys_reg 21; phys_reg 22 |] + +let destroyed_by_alloc = [| phys_reg 22 |] (* %r29 *) + +let destroyed_at_oper = function + Iop(Icall_ind | Icall_imm _ | Iextcall(_, true)) -> all_phys_regs + | Iop(Iextcall(_, false)) -> destroyed_at_c_call + | Iop(Iintop(Idiv | Imod)) -> destroyed_by_millicode + | Iop(Ialloc _) -> destroyed_by_alloc + | _ -> [||] + +let destroyed_at_raise = all_phys_regs + +(* Maximal register pressure *) + +let safe_register_pressure = function + Iextcall(_, _) -> 16 + | Iintop(Idiv | Imod) -> 19 + | _ -> 23 + +let max_register_pressure = function + Iextcall(_, _) -> [| 16; 19 |] + | Iintop(Idiv | Imod) -> [| 19; 27 |] + | _ -> [| 23; 27 |] + +(* Layout of the stack *) + +let num_stack_slots = [| 0; 0 |] +let contains_calls = ref false + +(* Calling the assembler *) + +let assemble_file infile outfile = + Ccomp.command ("gas -o " ^ Filename.quote outfile ^ " " ^ Filename.quote infile) + +open Clflags;; +open Config;; diff --git a/asmcomp/hppa/reload.ml b/asmcomp/hppa/reload.ml new file mode 100644 index 00000000..aa75ee81 --- /dev/null +++ b/asmcomp/hppa/reload.ml @@ -0,0 +1,18 @@ +(***********************************************************************) +(* *) +(* 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: reload.ml,v 1.3 1999/11/17 18:56:42 xleroy Exp $ *) + +(* Reloading for the HPPA *) + +let fundecl f = + (new Reloadgen.reload_generic)#fundecl f diff --git a/asmcomp/hppa/scheduling.ml b/asmcomp/hppa/scheduling.ml new file mode 100644 index 00000000..749fc604 --- /dev/null +++ b/asmcomp/hppa/scheduling.ml @@ -0,0 +1,59 @@ +(***********************************************************************) +(* *) +(* 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: scheduling.ml,v 1.4 1999/11/17 18:56:42 xleroy Exp $ *) + +(* Instruction scheduling for the HPPA *) + +open Arch +open Mach + +class scheduler = object (self) + +inherit Schedgen.scheduler_generic + +(* Latencies (in cycles). Roughly based on the ``Mustang'' chips. *) + +method oper_latency = function + Ireload -> 2 + | Iload(_, _) -> 2 + | Iconst_float _ -> 2 (* turned into a load *) + | Iintop Imul -> 2 (* ends up with a load *) + | Iaddf | Isubf | Imulf -> 3 + | Idivf -> 12 + | _ -> 1 + +(* Issue cycles. Rough approximations. *) + +method oper_issue_cycles = function + Iconst_float _ -> 3 + | Iconst_symbol _ -> 2 + | Iload(_, Ibased(_, _)) -> 2 + | Istore(_, Ibased(_, _)) -> 2 + | Ialloc _ -> 5 + | Iintop Imul -> 10 + | Iintop Ilsl -> 3 + | Iintop Ilsr -> 2 + | Iintop Iasr -> 3 + | Iintop(Icomp _) -> 2 + | Iintop(Icheckbound) -> 2 + | Iintop_imm(Idiv, _) -> 4 + | Iintop_imm(Imod, _) -> 5 + | Iintop_imm(Icomp _, _) -> 2 + | Iintop_imm(Icheckbound, _) -> 2 + | Ifloatofint -> 4 + | Iintoffloat -> 4 + | _ -> 1 + +end + +let fundecl f = (new scheduler)#schedule_fundecl f diff --git a/asmcomp/hppa/selection.ml b/asmcomp/hppa/selection.ml new file mode 100644 index 00000000..49a22797 --- /dev/null +++ b/asmcomp/hppa/selection.ml @@ -0,0 +1,109 @@ +(***********************************************************************) +(* *) +(* 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: selection.ml,v 1.5 1999/11/17 18:56:42 xleroy Exp $ *) + +(* Instruction selection for the HPPA processor *) + +open Misc +open Cmm +open Reg +open Arch +open Proc +open Mach + +let shiftadd = function + 2 -> Ishift1add + | 4 -> Ishift2add + | 8 -> Ishift3add + | _ -> fatal_error "Proc_hppa.shiftadd" + +class selector = object (self) + +inherit Selectgen.selector_generic as super + +method is_immediate n = (n < 16) && (n >= -16) (* 5 bits *) + +method select_addressing = function + Cconst_symbol s -> + (Ibased(s, 0), Ctuple []) + | Cop(Cadda, [Cconst_symbol s; Cconst_int n]) -> + (Ibased(s, n), Ctuple []) + | Cop(Cadda, [arg; Cconst_int n]) -> + (Iindexed n, arg) + | Cop(Cadda, [arg1; Cop(Caddi, [arg2; Cconst_int n])]) -> + (Iindexed n, Cop(Cadda, [arg1; arg2])) + | arg -> + (Iindexed 0, arg) + +method select_operation op args = + match (op, args) with + (* Recognize shift-add operations. *) + ((Caddi|Cadda), + [arg2; Cop(Clsl, [arg1; Cconst_int(1|2|3 as shift)])]) -> + (Ispecific(shiftadd(1 lsl shift)), [arg1; arg2]) + | ((Caddi|Cadda), + [arg2; Cop(Cmuli, [arg1; Cconst_int(2|4|8 as mult)])]) -> + (Ispecific(shiftadd mult), [arg1; arg2]) + | ((Caddi|Cadda), + [arg2; Cop(Cmuli, [Cconst_int(2|4|8 as mult); arg1])]) -> + (Ispecific(shiftadd mult), [arg1; arg2]) + | (Caddi, [Cop(Clsl, [arg1; Cconst_int(1|2|3 as shift)]); arg2]) -> + (Ispecific(shiftadd(1 lsl shift)), [arg1; arg2]) + | (Caddi, [Cop(Cmuli, [arg1; Cconst_int(2|4|8 as mult)]); arg2]) -> + (Ispecific(shiftadd mult), [arg1; arg2]) + | (Caddi, [Cop(Cmuli, [Cconst_int(2|4|8 as mult); arg1]); arg2]) -> + (Ispecific(shiftadd mult), [arg1; arg2]) + (* Prevent the recognition of some immediate arithmetic operations *) + (* Cmuli : -> Ilsl if power of 2 + Cdivi, Cmodi : only if power of 2 + Cand, Cor, Cxor : never *) + | (Cmuli, ([arg1; Cconst_int n] as args)) -> + let l = Misc.log2 n in + if n = 1 lsl l + then (Iintop_imm(Ilsl, l), [arg1]) + else (Iintop Imul, args) + | (Cmuli, ([Cconst_int n; arg1] as args)) -> + let l = Misc.log2 n in + if n = 1 lsl l + then (Iintop_imm(Ilsl, l), [arg1]) + else (Iintop Imul, args) + | (Cmuli, args) -> (Iintop Imul, args) + | (Cdivi, [arg1; Cconst_int n]) when n = 1 lsl (Misc.log2 n) -> + (Iintop_imm(Idiv, n), [arg1]) + | (Cdivi, args) -> (Iintop Idiv, args) + | (Cmodi, [arg1; Cconst_int n]) when n = 1 lsl (Misc.log2 n) -> + (Iintop_imm(Imod, n), [arg1]) + | (Cmodi, args) -> (Iintop Imod, args) + | (Cand, args) -> (Iintop Iand, args) + | (Cor, args) -> (Iintop Ior, args) + | (Cxor, args) -> (Iintop Ixor, args) + | _ -> + super#select_operation op args + +(* Deal with register constraints *) + +method insert_op op rs rd = + match op with + Iintop(Idiv | Imod) -> (* handled via calls to millicode *) + let rs' = [|phys_reg 20; phys_reg 19|] (* %r26, %r25 *) + and rd' = [|phys_reg 22|] (* %r29 *) in + self#insert_moves rs rs'; + self#insert (Iop op) rs' rd'; + self#insert_moves rd' rd; + rd + | _ -> + super#insert_op op rs rd + +end + +let fundecl f = (new selector)#emit_fundecl f diff --git a/asmcomp/i386/arch.ml b/asmcomp/i386/arch.ml new file mode 100644 index 00000000..cbbe1195 --- /dev/null +++ b/asmcomp/i386/arch.ml @@ -0,0 +1,147 @@ +(***********************************************************************) +(* *) +(* 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: arch.ml,v 1.12 2003/02/25 15:50:12 xleroy Exp $ *) + +(* Machine-specific command-line options *) + +let fast_math = ref false + +let command_line_options = + [ "-ffast-math", Arg.Set fast_math, + " Inline trigonometric and exponential functions" ] + +(* Specific operations for the Intel 386 processor *) + +open Misc +open Format + +type addressing_mode = + Ibased of string * int (* symbol + displ *) + | Iindexed of int (* reg + displ *) + | Iindexed2 of int (* reg + reg + displ *) + | Iscaled of int * int (* reg * scale + displ *) + | Iindexed2scaled of int * int (* reg + reg * scale + displ *) + +type specific_operation = + Ilea of addressing_mode (* Lea gives scaled adds *) + | Istore_int of nativeint * addressing_mode (* Store an integer constant *) + | Istore_symbol of string * addressing_mode (* Store a symbol *) + | Ioffset_loc of int * addressing_mode (* Add a constant to a location *) + | Ipush (* Push regs on stack *) + | Ipush_int of nativeint (* Push an integer constant *) + | Ipush_symbol of string (* Push a symbol *) + | Ipush_load of addressing_mode (* Load a scalar and push *) + | Ipush_load_float of addressing_mode (* Load a float and push *) + | Isubfrev | Idivfrev (* Reversed float sub and div *) + | Ifloatarithmem of bool * float_operation * addressing_mode + (* Float arith operation with memory *) + (* bool: true=64 bits, false=32 *) + | Ifloatspecial of string + +and float_operation = + Ifloatadd | Ifloatsub | Ifloatsubrev | Ifloatmul | Ifloatdiv | Ifloatdivrev + +(* Sizes, endianness *) + +let big_endian = false + +let size_addr = 4 +let size_int = 4 +let size_float = 8 + +(* Operations on addressing modes *) + +let identity_addressing = Iindexed 0 + +let offset_addressing addr delta = + match addr with + Ibased(s, n) -> Ibased(s, n + delta) + | Iindexed n -> Iindexed(n + delta) + | Iindexed2 n -> Iindexed2(n + delta) + | Iscaled(scale, n) -> Iscaled(scale, n + delta) + | Iindexed2scaled(scale, n) -> Iindexed2scaled(scale, n + delta) + +let num_args_addressing = function + Ibased(s, n) -> 0 + | Iindexed n -> 1 + | Iindexed2 n -> 2 + | Iscaled(scale, n) -> 1 + | Iindexed2scaled(scale, n) -> 2 + +(* Printing operations and addressing modes *) + +let print_addressing printreg addr ppf arg = + match addr with + | Ibased(s, 0) -> + fprintf ppf "\"%s\"" s + | Ibased(s, n) -> + fprintf ppf "\"%s\" + %i" s n + | Iindexed n -> + let idx = if n <> 0 then Printf.sprintf " + %i" n else "" in + fprintf ppf "%a%s" printreg arg.(0) idx + | Iindexed2 n -> + let idx = if n <> 0 then Printf.sprintf " + %i" n else "" in + fprintf ppf "%a + %a%s" printreg arg.(0) printreg arg.(1) idx + | Iscaled(scale, n) -> + let idx = if n <> 0 then Printf.sprintf " + %i" n else "" in + fprintf ppf "%a * %i%s" printreg arg.(0) scale idx + | Iindexed2scaled(scale, n) -> + let idx = if n <> 0 then Printf.sprintf " + %i" n else "" in + fprintf ppf "%a + %a * %i%s" printreg arg.(0) printreg arg.(1) scale idx + +let print_specific_operation printreg op ppf arg = + match op with + | Ilea addr -> print_addressing printreg addr ppf arg + | Istore_int(n, addr) -> + fprintf ppf "[%a] := %s" (print_addressing printreg addr) arg + (Nativeint.to_string n) + | Istore_symbol(lbl, addr) -> + fprintf ppf "[%a] := \"%s\"" (print_addressing printreg addr) arg lbl + | Ioffset_loc(n, addr) -> + fprintf ppf "[%a] +:= %i" (print_addressing printreg addr) arg n + | Ipush -> + fprintf ppf "push "; + for i = 0 to Array.length arg - 1 do + if i > 0 then fprintf ppf ", "; + printreg ppf arg.(i) + done + | Ipush_int n -> + fprintf ppf "push %s" (Nativeint.to_string n) + | Ipush_symbol s -> + fprintf ppf "push \"%s\"" s + | Ipush_load addr -> + fprintf ppf "push [%a]" (print_addressing printreg addr) arg + | Ipush_load_float addr -> + fprintf ppf "pushfloat [%a]" (print_addressing printreg addr) arg + | Isubfrev -> + fprintf ppf "%a -f(rev) %a" printreg arg.(0) printreg arg.(1) + | Idivfrev -> + fprintf ppf "%a /f(rev) %a" printreg arg.(0) printreg arg.(1) + | Ifloatarithmem(double, op, addr) -> + let op_name = function + | Ifloatadd -> "+f" + | Ifloatsub -> "-f" + | Ifloatsubrev -> "-f(rev)" + | Ifloatmul -> "*f" + | Ifloatdiv -> "/f" + | Ifloatdivrev -> "/f(rev)" in + let long = if double then "float64" else "float32" in + fprintf ppf "%a %s %s[%a]" printreg arg.(0) (op_name op) long + (print_addressing printreg addr) (Array.sub arg 1 (Array.length arg - 1)) + | Ifloatspecial name -> + fprintf ppf "%s " name; + for i = 0 to Array.length arg - 1 do + if i > 0 then fprintf ppf ", "; + printreg ppf arg.(i) + done + diff --git a/asmcomp/i386/emit.mlp b/asmcomp/i386/emit.mlp new file mode 100644 index 00000000..ec6004b9 --- /dev/null +++ b/asmcomp/i386/emit.mlp @@ -0,0 +1,871 @@ +(***********************************************************************) +(* *) +(* 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: emit.mlp,v 1.28 2003/06/30 15:32:45 xleroy Exp $ *) + +(* Emission of Intel 386 assembly code *) + +open Location +open Misc +open Cmm +open Arch +open Proc +open Reg +open Mach +open Linearize +open Emitaux + +(* Tradeoff between code size and code speed *) + +let fastcode_flag = ref true + +let stack_offset = ref 0 + +(* Layout of the stack frame *) + +let frame_size () = (* includes return address *) + !stack_offset + 4 * num_stack_slots.(0) + 8 * num_stack_slots.(1) + 4 + +let slot_offset loc cl = + match loc with + Incoming n -> frame_size() + n + | Local n -> + if cl = 0 + then !stack_offset + n * 4 + else !stack_offset + num_stack_slots.(0) * 4 + n * 8 + | Outgoing n -> n + +(* Prefixing of symbols with "_" *) + +let symbol_prefix = + match Config.system with + "linux_elf" -> "" + | "bsd_elf" -> "" + | "solaris" -> "" + | "beos" -> "" + | _ -> "_" + +let emit_symbol s = + emit_string symbol_prefix; Emitaux.emit_symbol '$' s + +(* Output a label *) + +let label_prefix = + match Config.system with + "linux_elf" -> ".L" + | "bsd_elf" -> ".L" + | "solaris" -> ".L" + | "beos" -> ".L" + | _ -> "L" + +let emit_label lbl = + emit_string label_prefix; emit_int lbl + + +(* Some data directives have different names under Solaris *) + +let word_dir = + match Config.system with + "solaris" -> ".value" + | _ -> ".word" +let skip_dir = + match Config.system with + "solaris" -> ".zero" + | _ -> ".space" +let use_ascii_dir = + match Config.system with + "solaris" -> false + | _ -> true + +(* Output a .align directive. + The numerical argument to .align is log2 of alignment size, except + under ELF, where it is the alignment size... *) + +let emit_align = + match Config.system with + "linux_elf" | "bsd_elf" | "solaris" | "beos" | "cygwin" | "mingw" -> + (fun n -> ` .align {emit_int n}\n`) + | _ -> + (fun n -> ` .align {emit_int(Misc.log2 n)}\n`) + +let emit_Llabel fallthrough lbl = + if not fallthrough && !fastcode_flag then + emit_align 16 ; + emit_label lbl + +(* Output a pseudo-register *) + +let emit_reg = function + { loc = Reg r } -> + emit_string (register_name r) + | { loc = Stack s } as r -> + let ofs = slot_offset s (register_class r) in + `{emit_int ofs}(%esp)` + | { loc = Unknown } -> + fatal_error "Emit_i386.emit_reg" + +(* Output a reference to the lower 8 bits or lower 16 bits of a register *) + +let reg_low_byte_name = [| "%al"; "%bl"; "%cl"; "%dl" |] +let reg_low_half_name = [| "%ax"; "%bx"; "%cx"; "%dx"; "%si"; "%di"; "%bp" |] + +let emit_reg8 r = + match r.loc with + Reg r when r < 4 -> emit_string (reg_low_byte_name.(r)) + | _ -> fatal_error "Emit_i386.emit_reg8" + +let emit_reg16 r = + match r.loc with + Reg r when r < 7 -> emit_string (reg_low_half_name.(r)) + | _ -> fatal_error "Emit_i386.emit_reg16" + +(* Output an addressing mode *) + +let emit_addressing addr r n = + match addr with + Ibased(s, d) -> + `{emit_symbol s}`; + if d <> 0 then ` + {emit_int d}` + | Iindexed d -> + if d <> 0 then emit_int d; + `({emit_reg r.(n)})` + | Iindexed2 d -> + if d <> 0 then emit_int d; + `({emit_reg r.(n)}, {emit_reg r.(n+1)})` + | Iscaled(2, d) -> + if d <> 0 then emit_int d; + `({emit_reg r.(n)}, {emit_reg r.(n)})` + | Iscaled(scale, d) -> + if d <> 0 then emit_int d; + `(, {emit_reg r.(n)}, {emit_int scale})` + | Iindexed2scaled(scale, d) -> + if d <> 0 then emit_int d; + `({emit_reg r.(n)}, {emit_reg r.(n+1)}, {emit_int scale})` + +(* Record live pointers at call points *) + +type frame_descr = + { fd_lbl: int; (* Return address *) + fd_frame_size: int; (* Size of stack frame *) + fd_live_offset: int list } (* Offsets/regs of live addresses *) + +let frame_descriptors = ref([] : frame_descr list) + +let record_frame_label live = + let lbl = new_label() in + let live_offset = ref [] in + Reg.Set.iter + (function + {typ = Addr; loc = Reg r} -> + live_offset := ((r lsl 1) + 1) :: !live_offset + | {typ = Addr; loc = Stack s} as reg -> + live_offset := slot_offset s (register_class reg) :: !live_offset + | _ -> ()) + live; + frame_descriptors := + { fd_lbl = lbl; + fd_frame_size = frame_size(); + fd_live_offset = !live_offset } :: !frame_descriptors; + lbl + +let record_frame live = + let lbl = record_frame_label live in `{emit_label lbl}:\n` + +let emit_frame fd = + ` .long {emit_label fd.fd_lbl}\n`; + ` {emit_string word_dir} {emit_int fd.fd_frame_size}\n`; + ` {emit_string word_dir} {emit_int (List.length fd.fd_live_offset)}\n`; + List.iter + (fun n -> + ` {emit_string word_dir} {emit_int n}\n`) + fd.fd_live_offset; + emit_align 4 + +(* Record calls to the GC -- we've moved them out of the way *) + +type gc_call = + { gc_lbl: label; (* Entry label *) + gc_return_lbl: label; (* Where to branch after GC *) + gc_frame: label } (* Label of frame descriptor *) + +let call_gc_sites = ref ([] : gc_call list) + +let emit_call_gc gc = + `{emit_label gc.gc_lbl}: call {emit_symbol "caml_call_gc"}\n`; + `{emit_label gc.gc_frame}: jmp {emit_label gc.gc_return_lbl}\n` + +(* Names for instructions *) + +let instr_for_intop = function + Iadd -> "addl" + | Isub -> "subl" + | Imul -> "imull" + | Iand -> "andl" + | Ior -> "orl" + | Ixor -> "xorl" + | Ilsl -> "sall" + | Ilsr -> "shrl" + | Iasr -> "sarl" + | _ -> fatal_error "Emit_i386: instr_for_intop" + +let instr_for_floatop = function + Inegf -> "fchs" + | Iabsf -> "fabs" + | Iaddf -> "faddl" + | Isubf -> "fsubl" + | Imulf -> "fmull" + | Idivf -> "fdivl" + | Ispecific Isubfrev -> "fsubrl" + | Ispecific Idivfrev -> "fdivrl" + | _ -> fatal_error "Emit_i386: instr_for_floatop" + +let instr_for_floatop_reversed = function + Iaddf -> "faddl" + | Isubf -> "fsubrl" + | Imulf -> "fmull" + | Idivf -> "fdivrl" + | Ispecific Isubfrev -> "fsubl" + | Ispecific Idivfrev -> "fdivl" + | _ -> fatal_error "Emit_i386: instr_for_floatop_reversed" + +let instr_for_floatop_pop = function + Iaddf -> "faddp" + | Isubf -> "fsubp" + | Imulf -> "fmulp" + | Idivf -> "fdivp" + | Ispecific Isubfrev -> "fsubrp" + | Ispecific Idivfrev -> "fdivrp" + | _ -> fatal_error "Emit_i386: instr_for_floatop_pop" + +let instr_for_floatarithmem double = function + Ifloatadd -> if double then "faddl" else "fadds" + | Ifloatsub -> if double then "fsubl" else "fsubs" + | Ifloatsubrev -> if double then "fsubrl" else "fsubrs" + | Ifloatmul -> if double then "fmull" else "fmuls" + | Ifloatdiv -> if double then "fdivl" else "fdivs" + | Ifloatdivrev -> if double then "fdivrl" else "fdivrs" + +let name_for_cond_branch = function + Isigned Ceq -> "e" | Isigned Cne -> "ne" + | Isigned Cle -> "le" | Isigned Cgt -> "g" + | Isigned Clt -> "l" | Isigned Cge -> "ge" + | Iunsigned Ceq -> "e" | Iunsigned Cne -> "ne" + | Iunsigned Cle -> "be" | Iunsigned Cgt -> "a" + | Iunsigned Clt -> "b" | Iunsigned Cge -> "ae" + +(* Output an = 0 or <> 0 test. *) + +let output_test_zero arg = + match arg.loc with + Reg r -> ` testl {emit_reg arg}, {emit_reg arg}\n` + | _ -> ` cmpl $0, {emit_reg arg}\n` + +(* Deallocate the stack frame before a return or tail call *) + +let output_epilogue () = + let n = frame_size() - 4 in + if n > 0 then ` addl ${emit_int n}, %esp\n` + +(* Determine if the given register is the top of the floating-point stack *) + +let is_tos = function { loc = Reg _; typ = Float } -> true | _ -> false + +(* Emit the code for a floating-point comparison *) + +let emit_float_test cmp neg arg lbl = + let actual_cmp = + match (is_tos arg.(0), is_tos arg.(1)) with + (true, true) -> + (* both args on top of FP stack *) + ` fcompp\n`; + cmp + | (true, false) -> + (* first arg on top of FP stack *) + ` fcompl {emit_reg arg.(1)}\n`; + cmp + | (false, true) -> + (* second arg on top of FP stack *) + ` fcompl {emit_reg arg.(0)}\n`; + Cmm.swap_comparison cmp + | (false, false) -> + ` fldl {emit_reg arg.(0)}\n`; + ` fcompl {emit_reg arg.(1)}\n`; + cmp + in + ` fnstsw %ax\n`; + begin match actual_cmp with + Ceq -> + if neg then begin + ` andb $68, %ah\n`; + ` xorb $64, %ah\n`; + ` jne ` + end else begin + ` andb $69, %ah\n`; + ` cmpb $64, %ah\n`; + ` je ` + end + | Cne -> + if neg then begin + ` andb $69, %ah\n`; + ` cmpb $64, %ah\n`; + ` je ` + end else begin + ` andb $68, %ah\n`; + ` xorb $64, %ah\n`; + ` jne ` + end + | Cle -> + ` andb $69, %ah\n`; + ` decb %ah\n`; + ` cmpb $64, %ah\n`; + if neg + then ` jae ` + else ` jb ` + | Cge -> + ` andb $5, %ah\n`; + if neg + then ` jne ` + else ` je ` + | Clt -> + ` andb $69, %ah\n`; + ` cmpb $1, %ah\n`; + if neg + then ` jne ` + else ` je ` + | Cgt -> + ` andb $69, %ah\n`; + if neg + then ` jne ` + else ` je ` + end; + `{emit_label lbl}\n` + +(* Emit a Ifloatspecial instruction *) + +let emit_floatspecial = function + "atan" -> ` fld1; fpatan\n` + | "atan2" -> ` fpatan\n` + | "cos" -> ` fcos\n` + | "log" -> ` fldln2; fxch; fyl2x\n` + | "log10" -> ` fldlg2; fxch; fyl2x\n` + | "sin" -> ` fsin\n` + | "sqrt" -> ` fsqrt\n` + | "tan" -> ` fptan; fstp %st(0)\n` + | _ -> assert false + +(* Output the assembly code for an instruction *) + +(* Name of current function *) +let function_name = ref "" +(* Entry point for tail recursive calls *) +let tailrec_entry_point = ref 0 +(* Label of trap for out-of-range accesses *) +let range_check_trap = ref 0 +(* Record float literals to be emitted later *) +let float_constants = ref ([] : (int * string) list) + +let emit_instr fallthrough i = + match i.desc with + Lend -> () + | Lop(Imove | Ispill | Ireload) -> + let src = i.arg.(0) and dst = i.res.(0) in + if src.loc <> dst.loc then begin + if src.typ = Float then + if is_tos src then + ` fstpl {emit_reg dst}\n` + else if is_tos dst then + ` fldl {emit_reg src}\n` + else begin + ` fldl {emit_reg src}\n`; + ` fstpl {emit_reg dst}\n` + end + else + ` movl {emit_reg src}, {emit_reg dst}\n` + end + | Lop(Iconst_int n) -> + if n = 0n then begin + match i.res.(0).loc with + Reg n -> ` xorl {emit_reg i.res.(0)}, {emit_reg i.res.(0)}\n` + | _ -> ` movl $0, {emit_reg i.res.(0)}\n` + end else + ` movl ${emit_nativeint n}, {emit_reg i.res.(0)}\n` + | Lop(Iconst_float s) -> + let f = float_of_string s in + if f = 0.0 then + ` fldz\n` + else if f = 1.0 then + ` fld1\n` + else begin + let lbl = new_label() in + float_constants := (lbl, s) :: !float_constants; + ` fldl {emit_label lbl}\n` + end + | Lop(Iconst_symbol s) -> + ` movl ${emit_symbol s}, {emit_reg i.res.(0)}\n` + | Lop(Icall_ind) -> + ` call *{emit_reg i.arg.(0)}\n`; + record_frame i.live + | Lop(Icall_imm s) -> + ` call {emit_symbol s}\n`; + record_frame i.live + | Lop(Itailcall_ind) -> + output_epilogue(); + ` jmp *{emit_reg i.arg.(0)}\n` + | Lop(Itailcall_imm s) -> + if s = !function_name then + ` jmp {emit_label !tailrec_entry_point}\n` + else begin + output_epilogue(); + ` jmp {emit_symbol s}\n` + end + | Lop(Iextcall(s, alloc)) -> + if alloc then begin + ` movl ${emit_symbol s}, %eax\n`; + ` call {emit_symbol "caml_c_call"}\n`; + record_frame i.live + end else begin + ` call {emit_symbol s}\n` + end + | Lop(Istackoffset n) -> + if n < 0 + then ` addl ${emit_int(-n)}, %esp\n` + else ` subl ${emit_int(n)}, %esp\n`; + stack_offset := !stack_offset + n + | Lop(Iload(chunk, addr)) -> + let dest = i.res.(0) in + begin match chunk with + | Word | Thirtytwo_signed | Thirtytwo_unsigned -> + ` movl {emit_addressing addr i.arg 0}, {emit_reg dest}\n` + | Byte_unsigned -> + ` movzbl {emit_addressing addr i.arg 0}, {emit_reg dest}\n` + | Byte_signed -> + ` movsbl {emit_addressing addr i.arg 0}, {emit_reg dest}\n` + | Sixteen_unsigned -> + ` movzwl {emit_addressing addr i.arg 0}, {emit_reg dest}\n` + | Sixteen_signed -> + ` movswl {emit_addressing addr i.arg 0}, {emit_reg dest}\n` + | Single -> + ` flds {emit_addressing addr i.arg 0}\n` + | Double | Double_u -> + ` fldl {emit_addressing addr i.arg 0}\n` + end + | Lop(Istore(chunk, addr)) -> + begin match chunk with + | Word | Thirtytwo_signed | Thirtytwo_unsigned -> + ` movl {emit_reg i.arg.(0)}, {emit_addressing addr i.arg 1}\n` + | Byte_unsigned | Byte_signed -> + ` movb {emit_reg8 i.arg.(0)}, {emit_addressing addr i.arg 1}\n` + | Sixteen_unsigned | Sixteen_signed -> + ` movw {emit_reg16 i.arg.(0)}, {emit_addressing addr i.arg 1}\n` + | Single -> + if is_tos i.arg.(0) then + ` fstps {emit_addressing addr i.arg 1}\n` + else begin + ` fldl {emit_reg i.arg.(0)}\n`; + ` fstps {emit_addressing addr i.arg 1}\n` + end + | Double | Double_u -> + if is_tos i.arg.(0) then + ` fstpl {emit_addressing addr i.arg 1}\n` + else begin + ` fldl {emit_reg i.arg.(0)}\n`; + ` fstpl {emit_addressing addr i.arg 1}\n` + end + end + | Lop(Ialloc n) -> + if !fastcode_flag then begin + let lbl_redo = new_label() in + `{emit_label lbl_redo}: movl {emit_symbol "young_ptr"}, %eax\n`; + ` subl ${emit_int n}, %eax\n`; + ` movl %eax, {emit_symbol "young_ptr"}\n`; + ` cmpl {emit_symbol "young_limit"}, %eax\n`; + let lbl_call_gc = new_label() in + let lbl_frame = record_frame_label i.live in + ` jb {emit_label lbl_call_gc}\n`; + ` leal 4(%eax), {emit_reg i.res.(0)}\n`; + call_gc_sites := + { gc_lbl = lbl_call_gc; + gc_return_lbl = lbl_redo; + gc_frame = lbl_frame } :: !call_gc_sites + end else begin + begin match n with + 8 -> ` call {emit_symbol "caml_alloc1"}\n` + | 12 -> ` call {emit_symbol "caml_alloc2"}\n` + | 16 -> ` call {emit_symbol "caml_alloc3"}\n` + | _ -> ` movl ${emit_int n}, %eax\n`; + ` call {emit_symbol "caml_alloc"}\n` + end; + `{record_frame i.live} leal 4(%eax), {emit_reg i.res.(0)}\n` + end + | Lop(Iintop(Icomp cmp)) -> + ` cmpl {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}\n`; + let b = name_for_cond_branch cmp in + ` set{emit_string b} %al\n`; + ` movzbl %al, {emit_reg i.res.(0)}\n` + | Lop(Iintop_imm(Icomp cmp, n)) -> + ` cmpl ${emit_int n}, {emit_reg i.arg.(0)}\n`; + let b = name_for_cond_branch cmp in + ` set{emit_string b} %al\n`; + ` movzbl %al, {emit_reg i.res.(0)}\n` + | Lop(Iintop Icheckbound) -> + if !range_check_trap = 0 then range_check_trap := new_label(); + ` cmpl {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}\n`; + ` jbe {emit_label !range_check_trap}\n` + | Lop(Iintop_imm(Icheckbound, n)) -> + if !range_check_trap = 0 then range_check_trap := new_label(); + ` cmpl ${emit_int n}, {emit_reg i.arg.(0)}\n`; + ` jbe {emit_label !range_check_trap}\n` + | Lop(Iintop(Idiv | Imod)) -> + ` cltd\n`; + ` idivl {emit_reg i.arg.(1)}\n` + | Lop(Iintop(Ilsl | Ilsr | Iasr as op)) -> + (* We have i.arg.(0) = i.res.(0) and i.arg.(1) = %ecx *) + ` {emit_string(instr_for_intop op)} %cl, {emit_reg i.res.(0)}\n` + | Lop(Iintop op) -> + (* We have i.arg.(0) = i.res.(0) *) + ` {emit_string(instr_for_intop op)} {emit_reg i.arg.(1)}, {emit_reg i.res.(0)}\n` + | Lop(Iintop_imm(Iadd, n)) when i.arg.(0).loc <> i.res.(0).loc -> + ` leal {emit_int n}({emit_reg i.arg.(0)}), {emit_reg i.res.(0)}\n` + | Lop(Iintop_imm(Iadd, 1) | Iintop_imm(Isub, -1)) -> + ` incl {emit_reg i.res.(0)}\n` + | Lop(Iintop_imm(Iadd, -1) | Iintop_imm(Isub, 1)) -> + ` decl {emit_reg i.res.(0)}\n` + | Lop(Iintop_imm(Idiv, n)) -> + let l = Misc.log2 n in + let lbl = new_label() in + output_test_zero i.arg.(0); + ` jge {emit_label lbl}\n`; + ` addl ${emit_int(n-1)}, {emit_reg i.arg.(0)}\n`; + `{emit_label lbl}: sarl ${emit_int l}, {emit_reg i.arg.(0)}\n` + | Lop(Iintop_imm(Imod, n)) -> + let l = Misc.log2 n in + let lbl = new_label() in + ` movl {emit_reg i.arg.(0)}, %eax\n`; + ` testl %eax, %eax\n`; + ` jge {emit_label lbl}\n`; + ` addl ${emit_int(n-1)}, %eax\n`; + `{emit_label lbl}: andl ${emit_int(-n)}, %eax\n`; + ` subl %eax, {emit_reg i.arg.(0)}\n` + | Lop(Iintop_imm(op, n)) -> + (* We have i.arg.(0) = i.res.(0) *) + ` {emit_string(instr_for_intop op)} ${emit_int n}, {emit_reg i.res.(0)}\n` + | Lop(Inegf | Iabsf as floatop) -> + if not (is_tos i.arg.(0)) then + ` fldl {emit_reg i.arg.(0)}\n`; + ` {emit_string(instr_for_floatop floatop)}\n` + | Lop(Iaddf | Isubf | Imulf | Idivf | Ispecific(Isubfrev | Idivfrev) + as floatop) -> + begin match (is_tos i.arg.(0), is_tos i.arg.(1)) with + (true, true) -> + (* both operands on top of FP stack *) + ` {emit_string(instr_for_floatop_pop floatop)} %st, %st(1)\n` + | (true, false) -> + (* first operand on stack *) + ` {emit_string(instr_for_floatop floatop)} {emit_reg i.arg.(1)}\n` + | (false, true) -> + (* second operand on stack *) + ` {emit_string(instr_for_floatop_reversed floatop)} {emit_reg i.arg.(0)}\n` + | (false, false) -> + (* both operands in memory *) + ` fldl {emit_reg i.arg.(0)}\n`; + ` {emit_string(instr_for_floatop floatop)} {emit_reg i.arg.(1)}\n` + end + | Lop(Ifloatofint) -> + begin match i.arg.(0).loc with + Stack s -> + ` fildl {emit_reg i.arg.(0)}\n` + | _ -> + ` pushl {emit_reg i.arg.(0)}\n`; + ` fildl (%esp)\n`; + ` addl $4, %esp\n` + end + | Lop(Iintoffloat) -> + if not (is_tos i.arg.(0)) then + ` fldl {emit_reg i.arg.(0)}\n`; + stack_offset := !stack_offset - 8; + ` subl $8, %esp\n`; + ` fnstcw 4(%esp)\n`; + ` movw 4(%esp), %ax\n`; + ` movb $12, %ah\n`; + ` movw %ax, 0(%esp)\n`; + ` fldcw 0(%esp)\n`; + begin match i.res.(0).loc with + Stack s -> + ` fistpl {emit_reg i.res.(0)}\n` + | _ -> + ` fistpl (%esp)\n`; + ` movl (%esp), {emit_reg i.res.(0)}\n` + end; + ` fldcw 4(%esp)\n`; + ` addl $8, %esp\n`; + stack_offset := !stack_offset + 8 + | Lop(Ispecific(Ilea addr)) -> + ` lea {emit_addressing addr i.arg 0}, {emit_reg i.res.(0)}\n` + | Lop(Ispecific(Istore_int(n, addr))) -> + ` movl ${emit_nativeint n}, {emit_addressing addr i.arg 0}\n` + | Lop(Ispecific(Istore_symbol(s, addr))) -> + ` movl ${emit_symbol s}, {emit_addressing addr i.arg 0}\n` + | Lop(Ispecific(Ioffset_loc(n, addr))) -> + ` addl ${emit_int n}, {emit_addressing addr i.arg 0}\n` + | Lop(Ispecific(Ipush)) -> + (* Push arguments in reverse order *) + for n = Array.length i.arg - 1 downto 0 do + let r = i.arg.(n) in + match r with + {loc = Reg _; typ = Float} -> + ` subl $8, %esp\n`; + ` fstpl 0(%esp)\n`; + stack_offset := !stack_offset + 8 + | {loc = Stack sl; typ = Float} -> + let ofs = slot_offset sl 1 in + ` pushl {emit_int(ofs + 4)}(%esp)\n`; + ` pushl {emit_int(ofs + 4)}(%esp)\n`; + stack_offset := !stack_offset + 8 + | _ -> + ` pushl {emit_reg r}\n`; + stack_offset := !stack_offset + 4 + done + | Lop(Ispecific(Ipush_int n)) -> + ` pushl ${emit_nativeint n}\n`; + stack_offset := !stack_offset + 4 + | Lop(Ispecific(Ipush_symbol s)) -> + ` pushl ${emit_symbol s}\n`; + stack_offset := !stack_offset + 4 + | Lop(Ispecific(Ipush_load addr)) -> + ` pushl {emit_addressing addr i.arg 0}\n`; + stack_offset := !stack_offset + 4 + | Lop(Ispecific(Ipush_load_float addr)) -> + ` pushl {emit_addressing (offset_addressing addr 4) i.arg 0}\n`; + ` pushl {emit_addressing addr i.arg 0}\n`; + stack_offset := !stack_offset + 8 + | Lop(Ispecific(Ifloatarithmem(double, op, addr))) -> + if not (is_tos i.arg.(0)) then + ` fldl {emit_reg i.arg.(0)}\n`; + ` {emit_string(instr_for_floatarithmem double op)} {emit_addressing addr i.arg 1}\n` + | Lop(Ispecific(Ifloatspecial s)) -> + (* Push args on float stack if necessary *) + for k = 0 to Array.length i.arg - 1 do + if not (is_tos i.arg.(k)) then ` fldl {emit_reg i.arg.(k)}\n` + done; + (* Fix-up for binary instrs whose args were swapped *) + if Array.length i.arg = 2 && is_tos i.arg.(1) then + ` fxch %st(1)\n`; + emit_floatspecial s + | Lreloadretaddr -> + () + | Lreturn -> + output_epilogue(); + ` ret\n` + | Llabel lbl -> + `{emit_Llabel fallthrough lbl}:\n` + | Lbranch lbl -> + ` jmp {emit_label lbl}\n` + | Lcondbranch(tst, lbl) -> + begin match tst with + Itruetest -> + output_test_zero i.arg.(0); + ` jne {emit_label lbl}\n` + | Ifalsetest -> + output_test_zero i.arg.(0); + ` je {emit_label lbl}\n` + | Iinttest cmp -> + ` cmpl {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}\n`; + let b = name_for_cond_branch cmp in + ` j{emit_string b} {emit_label lbl}\n` + | Iinttest_imm((Isigned Ceq | Isigned Cne | + Iunsigned Ceq | Iunsigned Cne) as cmp, 0) -> + output_test_zero i.arg.(0); + let b = name_for_cond_branch cmp in + ` j{emit_string b} {emit_label lbl}\n` + | Iinttest_imm(cmp, n) -> + ` cmpl ${emit_int n}, {emit_reg i.arg.(0)}\n`; + let b = name_for_cond_branch cmp in + ` j{emit_string b} {emit_label lbl}\n` + | Ifloattest(cmp, neg) -> + emit_float_test cmp neg i.arg lbl + | Ioddtest -> + ` testl $1, {emit_reg i.arg.(0)}\n`; + ` jne {emit_label lbl}\n` + | Ieventest -> + ` testl $1, {emit_reg i.arg.(0)}\n`; + ` je {emit_label lbl}\n` + end + | Lcondbranch3(lbl0, lbl1, lbl2) -> + ` cmpl $1, {emit_reg i.arg.(0)}\n`; + begin match lbl0 with + None -> () + | Some lbl -> ` jb {emit_label lbl}\n` + end; + begin match lbl1 with + None -> () + | Some lbl -> ` je {emit_label lbl}\n` + end; + begin match lbl2 with + None -> () + | Some lbl -> ` jg {emit_label lbl}\n` + end + | Lswitch jumptbl -> + let lbl = new_label() in + ` jmp *{emit_label lbl}(, {emit_reg i.arg.(0)}, 4)\n`; + ` .data\n`; + `{emit_label lbl}:`; + for i = 0 to Array.length jumptbl - 1 do + ` .long {emit_label jumptbl.(i)}\n` + done; + ` .text\n` + | Lsetuptrap lbl -> + ` call {emit_label lbl}\n` + | Lpushtrap -> + ` pushl {emit_symbol "caml_exception_pointer"}\n`; + ` movl %esp, {emit_symbol "caml_exception_pointer"}\n`; + stack_offset := !stack_offset + 8 + | Lpoptrap -> + ` popl {emit_symbol "caml_exception_pointer"}\n`; + ` addl $4, %esp\n`; + stack_offset := !stack_offset - 8 + | Lraise -> + ` movl {emit_symbol "caml_exception_pointer"}, %esp\n`; + ` popl {emit_symbol "caml_exception_pointer"}\n`; + ` ret\n` + +let rec emit_all fallthrough i = + + match i.desc with + | Lend -> () + | _ -> + emit_instr fallthrough i; + emit_all + (Linearize.has_fallthrough i.desc) + i.next + +(* Emission of the floating-point constants *) + +let emit_float_constant (lbl, cst) = + ` .data\n`; + `{emit_label lbl}: .double {emit_string cst}\n` + +(* Emission of the profiling prelude *) + +let emit_profile () = + match Config.system with + "linux_elf" -> + ` pushl %eax\n`; + ` movl %esp, %ebp\n`; + ` pushl %ecx\n`; + ` pushl %edx\n`; + ` call {emit_symbol "mcount"}\n`; + ` popl %edx\n`; + ` popl %ecx\n`; + ` popl %eax\n` + | "bsd_elf" -> + ` pushl %eax\n`; + ` movl %esp, %ebp\n`; + ` pushl %ecx\n`; + ` pushl %edx\n`; + ` call .mcount\n`; + ` popl %edx\n`; + ` popl %ecx\n`; + ` popl %eax\n` + | _ -> () (*unsupported yet*) + +(* Emission of a function declaration *) + +let fundecl fundecl = + function_name := fundecl.fun_name; + fastcode_flag := fundecl.fun_fast; + tailrec_entry_point := new_label(); + stack_offset := 0; + float_constants := []; + call_gc_sites := []; + range_check_trap := 0; + ` .text\n`; + emit_align 16; + ` .globl {emit_symbol fundecl.fun_name}\n`; + `{emit_symbol fundecl.fun_name}:\n`; + if !Clflags.gprofile then emit_profile(); + let n = frame_size() - 4 in + if n > 0 then + ` subl ${emit_int n}, %esp\n`; + `{emit_label !tailrec_entry_point}:\n`; + emit_all true fundecl.fun_body; + List.iter emit_call_gc !call_gc_sites; + if !range_check_trap > 0 then + `{emit_label !range_check_trap}: call {emit_symbol "caml_array_bound_error"}\n`; + (* Never returns, but useful to have retaddr on stack for debugging *) + List.iter emit_float_constant !float_constants + +(* Emission of data *) + +let emit_item = function + Cglobal_symbol s -> + ` .globl {emit_symbol s}\n`; + | Cdefine_symbol s -> + `{emit_symbol s}:\n` + | Cdefine_label lbl -> + `{emit_label (100000 + lbl)}:\n` + | Cint8 n -> + ` .byte {emit_int n}\n` + | Cint16 n -> + ` {emit_string word_dir} {emit_int n}\n` + | Cint32 n -> + ` .long {emit_nativeint n}\n` + | Cint n -> + ` .long {emit_nativeint n}\n` + | Csingle f -> + ` .float {emit_string f}\n` + | Cdouble f -> + ` .double {emit_string f}\n` + | Csymbol_address s -> + ` .long {emit_symbol s}\n` + | Clabel_address lbl -> + ` .long {emit_label (100000 + lbl)}\n` + | Cstring s -> + if use_ascii_dir + then emit_string_directive " .ascii " s + else emit_bytes_directive " .byte " s + | Cskip n -> + if n > 0 then ` {emit_string skip_dir} {emit_int n}\n` + | Calign n -> + emit_align n + +let data l = + ` .data\n`; + List.iter emit_item l + +(* Beginning / end of an assembly file *) + +let begin_assembly() = + let lbl_begin = Compilenv.current_unit_name() ^ "__data_begin" in + ` .data\n`; + ` .globl {emit_symbol lbl_begin}\n`; + `{emit_symbol lbl_begin}:\n`; + let lbl_begin = Compilenv.current_unit_name() ^ "__code_begin" in + ` .text\n`; + ` .globl {emit_symbol lbl_begin}\n`; + `{emit_symbol lbl_begin}:\n` + +let end_assembly() = + let lbl_end = Compilenv.current_unit_name() ^ "__code_end" in + ` .text\n`; + ` .globl {emit_symbol lbl_end}\n`; + `{emit_symbol lbl_end}:\n`; + ` .data\n`; + let lbl_end = Compilenv.current_unit_name() ^ "__data_end" in + ` .globl {emit_symbol lbl_end}\n`; + `{emit_symbol lbl_end}:\n`; + ` .long 0\n`; + let lbl = Compilenv.current_unit_name() ^ "__frametable" in + ` .globl {emit_symbol lbl}\n`; + `{emit_symbol lbl}:\n`; + ` .long {emit_int (List.length !frame_descriptors)}\n`; + List.iter emit_frame !frame_descriptors; + frame_descriptors := [] diff --git a/asmcomp/i386/emit_nt.mlp b/asmcomp/i386/emit_nt.mlp new file mode 100644 index 00000000..79730ca8 --- /dev/null +++ b/asmcomp/i386/emit_nt.mlp @@ -0,0 +1,865 @@ +(***********************************************************************) +(* *) +(* 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: emit_nt.mlp,v 1.21 2003/06/30 15:39:38 xleroy Exp $ *) + +(* Emission of Intel 386 assembly code, MASM syntax. *) + +module StringSet = + Set.Make(struct type t = string let compare = compare end) + +open Misc +open Cmm +open Arch +open Proc +open Reg +open Mach +open Linearize +open Emitaux + +(* Tradeoff between code size and code speed *) + +let fastcode_flag = ref true + +(* Layout of the stack frame *) + +let stack_offset = ref 0 + +let frame_size () = (* includes return address *) + !stack_offset + 4 * num_stack_slots.(0) + 8 * num_stack_slots.(1) + 4 + +let slot_offset loc cl = + match loc with + Incoming n -> frame_size() + n + | Local n -> + if cl = 0 + then !stack_offset + n * 4 + else !stack_offset + num_stack_slots.(0) * 4 + n * 8 + | Outgoing n -> n + +(* Record symbols used and defined - at the end generate extern for those + used but not defined *) + +let symbols_defined = ref StringSet.empty +let symbols_used = ref StringSet.empty + +let add_def_symbol s = + symbols_defined := StringSet.add s !symbols_defined + +let add_used_symbol s = + symbols_used := StringSet.add s !symbols_used + +let emit_symbol s = + emit_string "_"; Emitaux.emit_symbol '$' s + +(* Output a label *) + +let emit_label lbl = + emit_string "L"; emit_int lbl + +(* Output an align directive. *) + +let emit_align n = ` ALIGN {emit_int n}\n` + +(* Output a pseudo-register *) + +let emit_reg = function + { loc = Reg r } -> + emit_string (register_name r) + | { loc = Stack s; typ = Float } as r -> + let ofs = slot_offset s (register_class r) in + `REAL8 PTR {emit_int ofs}[esp]` + | { loc = Stack s } as r -> + let ofs = slot_offset s (register_class r) in + `DWORD PTR {emit_int ofs}[esp]` + | { loc = Unknown } -> + fatal_error "Emit.emit_reg" + +(* Output a reference to the lower 8 bits or lower 16 bits of a register *) + +let reg_low_byte_name = [| "al"; "bl"; "cl"; "dl" |] +let reg_low_half_name = [| "ax"; "bx"; "cx"; "dx"; "si"; "di"; "bp" |] + +let emit_reg8 r = + match r.loc with + Reg r when r < 4 -> emit_string (reg_low_byte_name.(r)) + | _ -> fatal_error "Emit.emit_reg8" + +let emit_reg16 r = + match r.loc with + Reg r when r < 7 -> emit_string (reg_low_half_name.(r)) + | _ -> fatal_error "Emit.emit_reg16" + +(* Check if the given register overlaps (same location) with the given + array of registers *) + +let register_overlap reg arr = + try + for i = 0 to Array.length arr - 1 do + if reg.loc = arr.(i).loc then raise Exit + done; + false + with Exit -> + true + +(* Output an addressing mode *) + +let emit_signed_int d = + if d > 0 then emit_char '+'; + if d <> 0 then emit_int d + +let emit_addressing addr r n = + match addr with + Ibased(s, d) -> + add_used_symbol s; + `{emit_symbol s}{emit_signed_int d}` + | Iindexed d -> + `[{emit_reg r.(n)}{emit_signed_int d}]` + | Iindexed2 d -> + `[{emit_reg r.(n)}+{emit_reg r.(n+1)}{emit_signed_int d}]` + | Iscaled(2, d) -> + `[{emit_reg r.(n)}+{emit_reg r.(n)}{emit_signed_int d}]` + | Iscaled(scale, d) -> + `[{emit_reg r.(n)}*{emit_int scale}{emit_signed_int d}]` + | Iindexed2scaled(scale, d) -> + `[{emit_reg r.(n)}+{emit_reg r.(n+1)}*{emit_int scale}{emit_signed_int d}]` + +(* Record live pointers at call points *) + +type frame_descr = + { fd_lbl: int; (* Return address *) + fd_frame_size: int; (* Size of stack frame *) + fd_live_offset: int list } (* Offsets/regs of live addresses *) + +let frame_descriptors = ref([] : frame_descr list) + +let record_frame_label live = + let lbl = new_label() in + let live_offset = ref [] in + Reg.Set.iter + (function + {typ = Addr; loc = Reg r} -> + live_offset := ((r lsl 1) + 1) :: !live_offset + | {typ = Addr; loc = Stack s} as reg -> + live_offset := slot_offset s (register_class reg) :: !live_offset + | _ -> ()) + live; + frame_descriptors := + { fd_lbl = lbl; + fd_frame_size = frame_size(); + fd_live_offset = !live_offset } :: !frame_descriptors; + lbl + +let record_frame live = + let lbl = record_frame_label live in `{emit_label lbl}:\n` + +let emit_frame fd = + ` DWORD {emit_label fd.fd_lbl}\n`; + ` WORD {emit_int fd.fd_frame_size}\n`; + ` WORD {emit_int (List.length fd.fd_live_offset)}\n`; + List.iter + (fun n -> + ` WORD {emit_int n}\n`) + fd.fd_live_offset; + emit_align 4 + +(* Record calls to the GC -- we've moved them out of the way *) + +type gc_call = + { gc_lbl: label; (* Entry label *) + gc_return_lbl: label; (* Where to branch after GC *) + gc_frame: label } (* Label of frame descriptor *) + +let call_gc_sites = ref ([] : gc_call list) + +let emit_call_gc gc = + `{emit_label gc.gc_lbl}: call _caml_call_gc\n`; + `{emit_label gc.gc_frame}: jmp {emit_label gc.gc_return_lbl}\n` + +(* Names for instructions *) + +let instr_for_intop = function + Iadd -> "add" + | Isub -> "sub" + | Imul -> "imul" + | Iand -> "and" + | Ior -> "or" + | Ixor -> "xor" + | Ilsl -> "sal" + | Ilsr -> "shr" + | Iasr -> "sar" + | _ -> fatal_error "Emit: instr_for_intop" + +let instr_for_floatop = function + Inegf -> "fchs" + | Iabsf -> "fabs" + | Iaddf -> "fadd" + | Isubf -> "fsub" + | Imulf -> "fmul" + | Idivf -> "fdiv" + | Ispecific Isubfrev -> "fsubr" + | Ispecific Idivfrev -> "fdivr" + | _ -> fatal_error "Emit: instr_for_floatop" + +let instr_for_floatop_reversed = function + Iaddf -> "fadd" + | Isubf -> "fsubr" + | Imulf -> "fmul" + | Idivf -> "fdivr" + | Ispecific Isubfrev -> "fsub" + | Ispecific Idivfrev -> "fdiv" + | _ -> fatal_error "Emit: instr_for_floatop_reversed" + +let instr_for_floatarithmem = function + Ifloatadd -> "fadd" + | Ifloatsub -> "fsub" + | Ifloatsubrev -> "fsubr" + | Ifloatmul -> "fmul" + | Ifloatdiv -> "fdiv" + | Ifloatdivrev -> "fdivr" + +let name_for_cond_branch = function + Isigned Ceq -> "e" | Isigned Cne -> "ne" + | Isigned Cle -> "le" | Isigned Cgt -> "g" + | Isigned Clt -> "l" | Isigned Cge -> "ge" + | Iunsigned Ceq -> "e" | Iunsigned Cne -> "ne" + | Iunsigned Cle -> "be" | Iunsigned Cgt -> "a" + | Iunsigned Clt -> "b" | Iunsigned Cge -> "ae" + +(* Output an = 0 or <> 0 test. *) + +let output_test_zero arg = + match arg.loc with + Reg r -> ` test {emit_reg arg}, {emit_reg arg}\n` + | _ -> ` cmp {emit_reg arg}, 0\n` + +(* Deallocate the stack frame before a return or tail call *) + +let output_epilogue () = + let n = frame_size() - 4 in + if n > 0 then ` add esp, {emit_int n}\n` + +(* Determine if the given register is the top of the floating-point stack *) + +let is_tos = function { loc = Reg _; typ = Float } -> true | _ -> false + +(* Emit the code for a floating-point comparison *) + +let emit_float_test cmp neg arg lbl = + let actual_cmp = + match (is_tos arg.(0), is_tos arg.(1)) with + (true, true) -> + (* both args on top of FP stack *) + ` fcompp\n`; + cmp + | (true, false) -> + (* first arg on top of FP stack *) + ` fcomp {emit_reg arg.(1)}\n`; + cmp + | (false, true) -> + (* second arg on top of FP stack *) + ` fcomp {emit_reg arg.(0)}\n`; + Cmm.swap_comparison cmp + | (false, false) -> + ` fld {emit_reg arg.(0)}\n`; + ` fcomp {emit_reg arg.(1)}\n`; + cmp + in + ` fnstsw ax\n`; + begin match actual_cmp with + Ceq -> + if neg then begin + ` and ah, 68\n`; + ` xor ah, 64\n`; + ` jne ` + end else begin + ` and ah, 69\n`; + ` cmp ah, 64\n`; + ` je ` + end + | Cne -> + if neg then begin + ` and ah, 69\n`; + ` cmp ah, 64\n`; + ` je ` + end else begin + ` and ah, 68\n`; + ` xor ah, 64\n`; + ` jne ` + end + | Cle -> + ` and ah, 69\n`; + ` dec ah\n`; + ` cmp ah, 64\n`; + if neg + then ` jae ` + else ` jb ` + | Cge -> + ` and ah, 5\n`; + if neg + then ` jne ` + else ` je ` + | Clt -> + ` and ah, 69\n`; + ` cmp ah, 1\n`; + if neg + then ` jne ` + else ` je ` + | Cgt -> + ` and ah, 69\n`; + if neg + then ` jne ` + else ` je ` + end; + `{emit_label lbl}\n` + +(* Emit a Ifloatspecial instruction *) + +let emit_floatspecial = function + "atan" -> ` fld1\n\tfpatan\n` + | "atan2" -> ` fpatan\n` + | "cos" -> ` fcos\n` + | "log" -> ` fldln2\n\tfxch\n\tfyl2x\n` + | "log10" -> ` fldlg2\n\tfxch\n\tfyl2x\n` + | "sin" -> ` fsin\n` + | "sqrt" -> ` fsqrt\n` + | "tan" -> ` fptan\n\tfstp st(0)\n` + | _ -> assert false + +(* Output the assembly code for an instruction *) + +(* Name of current function *) +let function_name = ref "" +(* Entry point for tail recursive calls *) +let tailrec_entry_point = ref 0 +(* Label of trap for out-of-range accesses *) +let range_check_trap = ref 0 + +let float_constants = ref ([] : (int * string) list) + +let emit_instr i = + match i.desc with + Lend -> () + | Lop(Imove | Ispill | Ireload) -> + let src = i.arg.(0) and dst = i.res.(0) in + if src.loc <> dst.loc then begin + if src.typ = Float then + if is_tos src then + ` fstp {emit_reg dst}\n` + else if is_tos dst then + ` fld {emit_reg dst}\n` + else begin + ` fld {emit_reg src}\n`; + ` fstp {emit_reg dst}\n` + end + else + ` mov {emit_reg dst}, {emit_reg src}\n` + end + | Lop(Iconst_int n) -> + if n = 0n then begin + match i.res.(0).loc with + Reg n -> ` xor {emit_reg i.res.(0)}, {emit_reg i.res.(0)}\n` + | _ -> ` mov {emit_reg i.res.(0)}, 0\n` + end else + ` mov {emit_reg i.res.(0)}, {emit_nativeint n}\n` + | Lop(Iconst_float s) -> + let f = float_of_string s in + if f = 0.0 then + ` fldz\n` + else if f = 1.0 then + ` fld1\n` + else begin + let lbl = new_label() in + float_constants := (lbl, s) :: !float_constants; + ` fld {emit_label lbl}\n` + end + | Lop(Iconst_symbol s) -> + add_used_symbol s; + ` mov {emit_reg i.res.(0)}, OFFSET {emit_symbol s}\n` + | Lop(Icall_ind) -> + ` call {emit_reg i.arg.(0)}\n`; + record_frame i.live + | Lop(Icall_imm s) -> + add_used_symbol s; + ` call {emit_symbol s}\n`; + record_frame i.live + | Lop(Itailcall_ind) -> + output_epilogue(); + ` jmp {emit_reg i.arg.(0)}\n` + | Lop(Itailcall_imm s) -> + if s = !function_name then + ` jmp {emit_label !tailrec_entry_point}\n` + else begin + output_epilogue(); + add_used_symbol s; + ` jmp {emit_symbol s}\n` + end + | Lop(Iextcall(s, alloc)) -> + add_used_symbol s ; + if alloc then begin + ` mov eax, OFFSET {emit_symbol s}\n`; + ` call _caml_c_call\n`; + record_frame i.live + end else begin + ` call {emit_symbol s}\n` + end + | Lop(Istackoffset n) -> + if n >= 0 + then ` sub esp, {emit_int n}\n` + else ` add esp, {emit_int(-n)}\n`; + stack_offset := !stack_offset + n + | Lop(Iload(chunk, addr)) -> + let dest = i.res.(0) in + begin match chunk with + | Word | Thirtytwo_signed | Thirtytwo_unsigned -> + ` mov {emit_reg dest}, DWORD PTR {emit_addressing addr i.arg 0}\n` + | Byte_unsigned -> + ` movzx {emit_reg dest}, BYTE PTR {emit_addressing addr i.arg 0}\n` + | Byte_signed -> + ` movsx {emit_reg dest}, BYTE PTR {emit_addressing addr i.arg 0}\n` + | Sixteen_unsigned -> + ` movzx {emit_reg dest}, WORD PTR {emit_addressing addr i.arg 0}\n` + | Sixteen_signed -> + ` movsx {emit_reg dest}, WORD PTR {emit_addressing addr i.arg 0}\n` + | Single -> + ` fld REAL4 PTR {emit_addressing addr i.arg 0}\n` + | Double | Double_u -> + ` fld REAL8 PTR {emit_addressing addr i.arg 0}\n` + end + | Lop(Istore(chunk, addr)) -> + begin match chunk with + | Word | Thirtytwo_signed | Thirtytwo_unsigned -> + ` mov DWORD PTR {emit_addressing addr i.arg 1}, {emit_reg i.arg.(0)}\n` + | Byte_unsigned | Byte_signed -> + ` mov BYTE PTR {emit_addressing addr i.arg 1}, {emit_reg8 i.arg.(0)}\n` + | Sixteen_unsigned | Sixteen_signed -> + ` mov WORD PTR {emit_addressing addr i.arg 1}, {emit_reg16 i.arg.(0)}\n` + | Single -> + if is_tos i.arg.(0) then + ` fstp REAL4 PTR {emit_addressing addr i.arg 1}\n` + else begin + ` fld {emit_reg i.arg.(0)}\n`; + ` fstp REAL4 PTR {emit_addressing addr i.arg 1}\n` + end + | Double | Double_u -> + if is_tos i.arg.(0) then + ` fstp REAL8 PTR {emit_addressing addr i.arg 1}\n` + else begin + ` fld {emit_reg i.arg.(0)}\n`; + ` fstp REAL8 PTR {emit_addressing addr i.arg 1}\n` + end + end + | Lop(Ialloc n) -> + if !fastcode_flag then begin + let lbl_redo = new_label() in + `{emit_label lbl_redo}: mov eax, _young_ptr\n`; + ` sub eax, {emit_int n}\n`; + ` mov _young_ptr, eax\n`; + ` cmp eax, _young_limit\n`; + let lbl_call_gc = new_label() in + let lbl_frame = record_frame_label i.live in + ` jb {emit_label lbl_call_gc}\n`; + ` lea {emit_reg i.res.(0)}, [eax+4]\n`; + call_gc_sites := + { gc_lbl = lbl_call_gc; + gc_return_lbl = lbl_redo; + gc_frame = lbl_frame } :: !call_gc_sites + end else begin + begin match n with + 8 -> ` call _caml_alloc1\n` + | 12 -> ` call _caml_alloc2\n` + | 16 -> ` call _caml_alloc3\n` + | _ -> ` mov eax, {emit_int n}\n`; + ` call _caml_alloc\n` + end; + `{record_frame i.live} lea {emit_reg i.res.(0)}, [eax+4]\n` + end + | Lop(Iintop(Icomp cmp)) -> + ` cmp {emit_reg i.arg.(0)},{emit_reg i.arg.(1)}\n`; + let b = name_for_cond_branch cmp in + ` set{emit_string b} al\n`; + ` movzx {emit_reg i.res.(0)}, al\n` + | Lop(Iintop_imm(Icomp cmp, n)) -> + ` cmp {emit_reg i.arg.(0)}, {emit_int n}\n`; + let b = name_for_cond_branch cmp in + ` set{emit_string b} al\n`; + ` movzx {emit_reg i.res.(0)}, al\n` + | Lop(Iintop Icheckbound) -> + if !range_check_trap = 0 then range_check_trap := new_label(); + ` cmp {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; + ` jbe {emit_label !range_check_trap}\n` + | Lop(Iintop_imm(Icheckbound, n)) -> + if !range_check_trap = 0 then range_check_trap := new_label(); + ` cmp {emit_reg i.arg.(0)}, {emit_int n}\n`; + ` jbe {emit_label !range_check_trap}\n` + | Lop(Iintop(Idiv | Imod)) -> + ` cdq\n`; + ` idiv {emit_reg i.arg.(1)}\n` + | Lop(Iintop(Ilsl | Ilsr | Iasr as op)) -> + (* We have i.arg.(0) = i.res.(0) and i.arg.(1) = %ecx *) + ` {emit_string(instr_for_intop op)} {emit_reg i.res.(0)}, cl\n` + | Lop(Iintop op) -> + (* We have i.arg.(0) = i.res.(0) *) + ` {emit_string(instr_for_intop op)} {emit_reg i.res.(0)}, {emit_reg i.arg.(1)}\n` + | Lop(Iintop_imm(Iadd, n)) when i.arg.(0).loc <> i.res.(0).loc -> + ` lea {emit_reg i.res.(0)}, [{emit_reg i.arg.(0)}+{emit_int n}]\n` + | Lop(Iintop_imm(Iadd, 1) | Iintop_imm(Isub, -1)) -> + ` inc {emit_reg i.res.(0)}\n` + | Lop(Iintop_imm(Iadd, -1) | Iintop_imm(Isub, 1)) -> + ` dec {emit_reg i.res.(0)}\n` + | Lop(Iintop_imm(Idiv, n)) -> + let l = Misc.log2 n in + let lbl = new_label() in + output_test_zero i.arg.(0); + ` jge {emit_label lbl}\n`; + ` add {emit_reg i.arg.(0)}, {emit_int(n-1)}\n`; + `{emit_label lbl}: sar {emit_reg i.arg.(0)}, {emit_int l}\n` + | Lop(Iintop_imm(Imod, n)) -> + let l = Misc.log2 n in + let lbl = new_label() in + ` mov eax, {emit_reg i.arg.(0)}\n`; + ` test eax, eax\n`; + ` jge {emit_label lbl}\n`; + ` add eax, {emit_int(n-1)}\n`; + `{emit_label lbl}: and eax, {emit_int(-n)}\n`; + ` sub {emit_reg i.arg.(0)}, eax\n` + | Lop(Iintop_imm(op, n)) -> + (* We have i.arg.(0) = i.res.(0) *) + ` {emit_string(instr_for_intop op)} {emit_reg i.res.(0)}, {emit_int n}\n` + | Lop(Inegf | Iabsf as floatop) -> + if not (is_tos i.arg.(0)) then + ` fld {emit_reg i.arg.(0)}\n`; + ` {emit_string(instr_for_floatop floatop)}\n` + | Lop(Iaddf | Isubf | Imulf | Idivf | Ispecific(Isubfrev | Idivfrev) + as floatop) -> + begin match (is_tos i.arg.(0), is_tos i.arg.(1)) with + (true, true) -> + (* both operands on top of FP stack *) + ` {emit_string(instr_for_floatop_reversed floatop)}\n` + | (true, false) -> + (* first operand on stack *) + ` {emit_string(instr_for_floatop floatop)} {emit_reg i.arg.(1)}\n` + | (false, true) -> + (* second operand on stack *) + ` {emit_string(instr_for_floatop_reversed floatop)} {emit_reg i.arg.(0)}\n` + | (false, false) -> + (* both operands in memory *) + ` fld {emit_reg i.arg.(0)}\n`; + ` {emit_string(instr_for_floatop floatop)} {emit_reg i.arg.(1)}\n` + end + | Lop(Ifloatofint) -> + begin match i.arg.(0).loc with + Stack s -> + ` fild {emit_reg i.arg.(0)}\n` + | _ -> + ` push {emit_reg i.arg.(0)}\n`; + ` fild DWORD PTR [esp]\n`; + ` add esp, 4\n` + end + | Lop(Iintoffloat) -> + if not (is_tos i.arg.(0)) then + ` fld {emit_reg i.arg.(0)}\n`; + stack_offset := !stack_offset - 8; + ` sub esp, 8\n`; + ` fnstcw [esp+4]\n`; + ` mov ax, [esp+4]\n`; + ` mov ah, 12\n`; + ` mov [esp], ax\n`; + ` fldcw [esp]\n`; + begin match i.res.(0).loc with + Stack s -> + ` fistp {emit_reg i.res.(0)}\n` + | _ -> + ` fistp DWORD PTR [esp]\n`; + ` mov {emit_reg i.res.(0)}, [esp]\n` + end; + ` fldcw [esp+4]\n`; + ` add esp, 8\n`; + stack_offset := !stack_offset + 8 + | Lop(Ispecific(Ilea addr)) -> + ` lea {emit_reg i.res.(0)}, DWORD PTR {emit_addressing addr i.arg 0}\n` + | Lop(Ispecific(Istore_int(n, addr))) -> + ` mov DWORD PTR {emit_addressing addr i.arg 0},{emit_nativeint n}\n` + | Lop(Ispecific(Istore_symbol(s, addr))) -> + add_used_symbol s ; + ` mov DWORD PTR {emit_addressing addr i.arg 0},OFFSET {emit_symbol s}\n` + | Lop(Ispecific(Ioffset_loc(n, addr))) -> + ` add DWORD PTR {emit_addressing addr i.arg 0},{emit_int n}\n` + | Lop(Ispecific(Ipush)) -> + (* Push arguments in reverse order *) + for n = Array.length i.arg - 1 downto 0 do + let r = i.arg.(n) in + match r with + {loc = Reg rn; typ = Float} -> + ` sub esp, 8\n`; + ` fstp REAL8 PTR 0[esp]\n`; + stack_offset := !stack_offset + 8 + | {loc = Stack sl; typ = Float} -> + let ofs = slot_offset sl 1 in + ` push DWORD PTR {emit_int (ofs + 4)}[esp]\n`; + ` push DWORD PTR {emit_int (ofs + 4)}[esp]\n`; + stack_offset := !stack_offset + 8 + | _ -> + ` push {emit_reg r}\n`; + stack_offset := !stack_offset + 4 + done + | Lop(Ispecific(Ipush_int n)) -> + ` push {emit_nativeint n}\n`; + stack_offset := !stack_offset + 4 + | Lop(Ispecific(Ipush_symbol s)) -> + add_used_symbol s; + ` push OFFSET {emit_symbol s}\n`; + stack_offset := !stack_offset + 4 + | Lop(Ispecific(Ipush_load addr)) -> + ` push DWORD PTR {emit_addressing addr i.arg 0}\n`; + stack_offset := !stack_offset + 4 + | Lop(Ispecific(Ipush_load_float addr)) -> + ` push DWORD PTR {emit_addressing (offset_addressing addr 4) i.arg 0}\n`; + ` push DWORD PTR {emit_addressing addr i.arg 0}\n`; + stack_offset := !stack_offset + 8 + | Lop(Ispecific(Ifloatarithmem(double, op, addr))) -> + if not (is_tos i.arg.(0)) then + ` fld {emit_reg i.arg.(0)}\n`; + let size = if double then "REAL8" else "REAL4" in + ` {emit_string(instr_for_floatarithmem op)} {emit_string size} PTR {emit_addressing addr i.arg 1}\n` + | Lop(Ispecific(Ifloatspecial s)) -> + (* Push args on float stack if necessary *) + for k = 0 to Array.length i.arg - 1 do + if not (is_tos i.arg.(k)) then ` fld {emit_reg i.arg.(k)}\n` + done; + (* Fix-up for binary instrs whose args were swapped *) + if Array.length i.arg = 2 && is_tos i.arg.(1) then + ` fxch st(1)\n`; + emit_floatspecial s + | Lreloadretaddr -> + () + | Lreturn -> + output_epilogue(); + ` ret\n` + | Llabel lbl -> + `{emit_label lbl}:\n` + | Lbranch lbl -> + ` jmp {emit_label lbl}\n` + | Lcondbranch(tst, lbl) -> + begin match tst with + Itruetest -> + output_test_zero i.arg.(0); + ` jne {emit_label lbl}\n` + | Ifalsetest -> + output_test_zero i.arg.(0); + ` je {emit_label lbl}\n` + | Iinttest cmp -> + ` cmp {emit_reg i.arg.(0)},{emit_reg i.arg.(1)}\n`; + let b = name_for_cond_branch cmp in + ` j{emit_string b} {emit_label lbl}\n` + | Iinttest_imm((Isigned Ceq | Isigned Cne | + Iunsigned Ceq | Iunsigned Cne) as cmp, 0) -> + output_test_zero i.arg.(0); + let b = name_for_cond_branch cmp in + ` j{emit_string b} {emit_label lbl}\n` + | Iinttest_imm(cmp, n) -> + ` cmp {emit_reg i.arg.(0)}, {emit_int n}\n`; + let b = name_for_cond_branch cmp in + ` j{emit_string b} {emit_label lbl}\n` + | Ifloattest(cmp, neg) -> + emit_float_test cmp neg i.arg lbl + | Ioddtest -> + ` test {emit_reg i.arg.(0)}, 1\n`; + ` jne {emit_label lbl}\n` + | Ieventest -> + ` test {emit_reg i.arg.(0)}, 1\n`; + ` je {emit_label lbl}\n` + end + | Lcondbranch3(lbl0, lbl1, lbl2) -> + ` cmp {emit_reg i.arg.(0)}, 1\n`; + begin match lbl0 with + None -> () + | Some lbl -> ` jb {emit_label lbl}\n` + end; + begin match lbl1 with + None -> () + | Some lbl -> ` je {emit_label lbl}\n` + end; + begin match lbl2 with + None -> () + | Some lbl -> ` jg {emit_label lbl}\n` + end + | Lswitch jumptbl -> + let lbl = new_label() in + ` jmp [{emit_reg i.arg.(0)} * 4 + {emit_label lbl}]\n`; + ` .DATA\n`; + `{emit_label lbl}`; + for i = 0 to Array.length jumptbl - 1 do + ` DWORD {emit_label jumptbl.(i)}\n` + done; + ` .CODE\n` + | Lsetuptrap lbl -> + ` call {emit_label lbl}\n` + | Lpushtrap -> + ` push _caml_exception_pointer\n`; + ` mov _caml_exception_pointer, esp\n`; + stack_offset := !stack_offset + 8 + | Lpoptrap -> + ` pop _caml_exception_pointer\n`; + ` add esp, 4\n`; + stack_offset := !stack_offset - 8 + | Lraise -> + ` mov esp, _caml_exception_pointer\n`; + ` pop _caml_exception_pointer\n`; + ` ret\n` + +let rec emit_all i = + match i.desc with Lend -> () | _ -> emit_instr i; emit_all i.next + +(* Emission of the floating-point constants *) + +let emit_float s = + (* MASM doesn't like floating-point constants such as 2e9. + Turn them into 2.0e9. *) + let pos_e = ref (-1) and pos_dot = ref (-1) in + for i = 0 to String.length s - 1 do + match s.[i] with + 'e'|'E' -> pos_e := i + | '.' -> pos_dot := i + | _ -> () + done; + if !pos_dot < 0 && !pos_e >= 0 then begin + emit_string (String.sub s 0 !pos_e); + emit_string ".0"; + emit_string (String.sub s !pos_e (String.length s - !pos_e)) + end else + emit_string s + +let emit_float_constant (lbl, cst) = + `{emit_label lbl} REAL8 {emit_float cst}\n` + +(* Emission of a function declaration *) + +let fundecl fundecl = + function_name := fundecl.fun_name; + fastcode_flag := fundecl.fun_fast; + tailrec_entry_point := new_label(); + stack_offset := 0; + float_constants := []; + call_gc_sites := []; + range_check_trap := 0; + ` .CODE\n`; + add_def_symbol fundecl.fun_name; + emit_align 4; + ` PUBLIC {emit_symbol fundecl.fun_name}\n`; + `{emit_symbol fundecl.fun_name}:\n`; + let n = frame_size() - 4 in + if n > 0 then + ` sub esp, {emit_int n}\n`; + `{emit_label !tailrec_entry_point}:\n`; + emit_all fundecl.fun_body; + List.iter emit_call_gc !call_gc_sites; + if !range_check_trap > 0 then + `{emit_label !range_check_trap}: jmp _caml_array_bound_error\n`; + begin match !float_constants with + [] -> () + | _ -> + ` .DATA\n`; + List.iter emit_float_constant !float_constants; + float_constants := [] + end + +(* Emission of data *) + +let emit_item = function + Cglobal_symbol s -> + ` PUBLIC {emit_symbol s}\n`; + | Cdefine_symbol s -> + add_def_symbol s ; + `{emit_symbol s} LABEL DWORD\n` + | Cdefine_label lbl -> + `{emit_label (100000 + lbl)} ` + | Cint8 n -> + ` BYTE {emit_int n}\n` + | Cint16 n -> + ` WORD {emit_int n}\n` + | Cint n -> + ` DWORD {emit_nativeint n}\n` + | Cint32 n -> + ` DWORD {emit_nativeint n}\n` + | Csingle f -> + ` REAL4 {emit_float f}\n` + | Cdouble f -> + ` REAL8 {emit_float f}\n` + | Csymbol_address s -> + add_used_symbol s ; + ` DWORD {emit_symbol s}\n` + | Clabel_address lbl -> + ` DWORD {emit_label (100000 + lbl)}\n` + | Cstring s -> + emit_bytes_directive " BYTE " s + | Cskip n -> + if n > 0 then ` BYTE {emit_int n} DUP (?)\n` + | Calign n -> + emit_align n + +let data l = + ` .DATA\n`; + List.iter emit_item l + +(* Beginning / end of an assembly file *) + +let begin_assembly() = + `.386\n`; + ` .MODEL FLAT\n\n`; + ` EXTERN _young_ptr: DWORD\n`; + ` EXTERN _young_limit: DWORD\n`; + ` EXTERN _caml_exception_pointer: DWORD\n`; + ` EXTERN _caml_call_gc: PROC\n`; + ` EXTERN _caml_c_call: PROC\n`; + ` EXTERN _caml_alloc: PROC\n`; + ` EXTERN _caml_alloc1: PROC\n`; + ` EXTERN _caml_alloc2: PROC\n`; + ` EXTERN _caml_alloc3: PROC\n`; + ` EXTERN _caml_array_bound_error: PROC\n`; + ` .DATA\n`; + let lbl_begin = Compilenv.current_unit_name() ^ "__data_begin" in + add_def_symbol lbl_begin; + ` PUBLIC {emit_symbol lbl_begin}\n`; + `{emit_symbol lbl_begin} LABEL DWORD\n`; + ` .CODE\n`; + let lbl_begin = Compilenv.current_unit_name() ^ "__code_begin" in + add_def_symbol lbl_begin; + ` PUBLIC {emit_symbol lbl_begin}\n`; + `{emit_symbol lbl_begin} LABEL DWORD\n` + +let end_assembly() = + ` .CODE\n`; + let lbl_end = Compilenv.current_unit_name() ^ "__code_end" in + add_def_symbol lbl_end; + ` PUBLIC {emit_symbol lbl_end}\n`; + `{emit_symbol lbl_end} LABEL DWORD\n`; + ` .DATA\n`; + let lbl_end = Compilenv.current_unit_name() ^ "__data_end" in + add_def_symbol lbl_end; + ` PUBLIC {emit_symbol lbl_end}\n`; + `{emit_symbol lbl_end} LABEL DWORD\n`; + let lbl = Compilenv.current_unit_name() ^ "__frametable" in + add_def_symbol lbl; + ` PUBLIC {emit_symbol lbl}\n`; + `{emit_symbol lbl} DWORD {emit_int (List.length !frame_descriptors)}\n`; + List.iter emit_frame !frame_descriptors; + frame_descriptors := []; + `\n;External functions\n\n`; + StringSet.iter + (fun s -> + if not (StringSet.mem s !symbols_defined) then + ` EXTERN {emit_symbol s}: PROC\n`) + !symbols_used; + symbols_used := StringSet.empty; + symbols_defined := StringSet.empty; + `END\n` diff --git a/asmcomp/i386/proc.ml b/asmcomp/i386/proc.ml new file mode 100644 index 00000000..a4271cf6 --- /dev/null +++ b/asmcomp/i386/proc.ml @@ -0,0 +1,176 @@ +(***********************************************************************) +(* *) +(* 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: proc.ml,v 1.8 2003/06/15 09:58:31 xleroy Exp $ *) + +(* Description of the Intel 386 processor *) + +open Misc +open Arch +open Cmm +open Reg +open Mach + +(* Registers available for register allocation *) + +(* Register map: + eax 0 eax - edi: function arguments and results + ebx 1 eax: C function results + ecx 2 ebx, esi, edi, ebp: preserved by C + edx 3 + esi 4 + edi 5 + ebp 6 + + tos 100 top of floating-point stack. *) + +let int_reg_name = + [| "%eax"; "%ebx"; "%ecx"; "%edx"; "%esi"; "%edi"; "%ebp" |] + +let float_reg_name = + [| "%tos" |] + +let num_register_classes = 2 + +let register_class r = + match r.typ with + Int -> 0 + | Addr -> 0 + | Float -> 1 + +let num_available_registers = [| 7; 0 |] + +let first_available_register = [| 0; 100 |] + +let register_name r = + if r < 100 then int_reg_name.(r) else float_reg_name.(r - 100) + +(* There is little scheduling, and some operations are more compact + when their argument is %eax. *) + +let rotate_registers = false + +(* Representation of hard registers by pseudo-registers *) + +let hard_int_reg = + let v = Array.create 7 Reg.dummy in + for i = 0 to 6 do v.(i) <- Reg.at_location Int (Reg i) done; + v + +let hard_float_reg = [| Reg.at_location Float (Reg 100) |] + +let all_phys_regs = + Array.append hard_int_reg hard_float_reg + +let phys_reg n = + if n < 100 then hard_int_reg.(n) else hard_float_reg.(n - 100) + +let eax = phys_reg 0 +let ecx = phys_reg 2 +let edx = phys_reg 3 +let tos = phys_reg 100 + +let stack_slot slot ty = + Reg.at_location ty (Stack slot) + +(* Instruction selection *) + +let word_addressed = false + +(* Calling conventions *) + +let calling_conventions first_int last_int first_float last_float make_stack + arg = + let loc = Array.create (Array.length arg) Reg.dummy in + let int = ref first_int in + let float = ref first_float in + let ofs = ref 0 in + for i = 0 to Array.length arg - 1 do + match arg.(i).typ with + Int | Addr as ty -> + if !int <= last_int then begin + loc.(i) <- phys_reg !int; + incr int + end else begin + loc.(i) <- stack_slot (make_stack !ofs) ty; + ofs := !ofs + size_int + end + | Float -> + if !float <= last_float then begin + loc.(i) <- phys_reg !float; + incr float + end else begin + loc.(i) <- stack_slot (make_stack !ofs) Float; + ofs := !ofs + size_float + end + done; + (loc, !ofs) + +let incoming ofs = Incoming ofs +let outgoing ofs = Outgoing ofs +let not_supported ofs = fatal_error "Proc.loc_results: cannot call" + +let loc_arguments arg = + calling_conventions 0 5 100 99 outgoing arg +let loc_parameters arg = + let (loc, ofs) = calling_conventions 0 5 100 99 incoming arg in loc +let loc_results res = + let (loc, ofs) = calling_conventions 0 5 100 100 not_supported res in loc +let extcall_use_push = true +let loc_external_arguments arg = + fatal_error "Proc.loc_external_arguments" +let loc_external_results res = + let (loc, ofs) = calling_conventions 0 0 100 100 not_supported res in loc + +let loc_exn_bucket = eax + +(* Registers destroyed by operations *) + +let destroyed_at_c_call = (* ebx, esi, edi, ebp preserved *) + [|eax; ecx; edx|] + +let destroyed_at_oper = function + Iop(Icall_ind | Icall_imm _ | Iextcall(_, true)) -> all_phys_regs + | Iop(Iextcall(_, false)) -> destroyed_at_c_call + | Iop(Iintop(Idiv | Imod)) -> [| eax; edx |] + | Iop(Iintop_imm(Imod, _)) -> [| eax |] + | Iop(Ialloc _) -> [| eax |] + | Iop(Iintop(Icomp _) | Iintop_imm(Icomp _, _)) -> [| eax |] + | Iop(Iintoffloat) -> [| eax |] + | Iifthenelse(Ifloattest(_, _), _, _) -> [| eax |] + | _ -> [||] + +let destroyed_at_raise = all_phys_regs + +(* Maximal register pressure *) + +let safe_register_pressure op = 4 + +let max_register_pressure = function + Iextcall(_, _) -> [| 4; max_int |] + | Iintop(Idiv | Imod) -> [| 5; max_int |] + | Ialloc _ | Iintop(Icomp _) | Iintop_imm(Icomp _, _) | + Iintoffloat -> [| 6; max_int |] + | _ -> [|7; max_int |] + +(* Layout of the stack frame *) + +let num_stack_slots = [| 0; 0 |] +let contains_calls = ref false + +(* Calling the assembler *) + +let assemble_file infile outfile = + Ccomp.command ("as -o " ^ Filename.quote outfile ^ " " ^ Filename.quote infile) + +open Clflags;; +open Config;; diff --git a/asmcomp/i386/proc_nt.ml b/asmcomp/i386/proc_nt.ml new file mode 100644 index 00000000..4f99a99b --- /dev/null +++ b/asmcomp/i386/proc_nt.ml @@ -0,0 +1,178 @@ +(***********************************************************************) +(* *) +(* 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: proc_nt.ml,v 1.5 2002/03/12 16:17:52 xleroy Exp $ *) + +(* Description of the Intel 386 processor, for Windows NT *) + +open Misc +open Arch +open Cmm +open Reg +open Mach + +(* Registers available for register allocation *) + +(* Register map: + eax 0 eax - edi: function arguments and results + ebx 1 eax: C function results + ecx 2 ebx, esi, edi, ebp: preserved by C + edx 3 + esi 4 + edi 5 + ebp 6 + + tos 100 top of floating-point stack. *) + +let int_reg_name = + [| "eax"; "ebx"; "ecx"; "edx"; "esi"; "edi"; "ebp" |] + +let float_reg_name = + [| "tos" |] + +let num_register_classes = 2 + +let register_class r = + match r.typ with + Int -> 0 + | Addr -> 0 + | Float -> 1 + +let num_available_registers = [| 7; 0 |] + +let first_available_register = [| 0; 100 |] + +let register_name r = + if r < 100 then int_reg_name.(r) else float_reg_name.(r - 100) + +(* There is little scheduling, and some operations are more compact + when their argument is %eax. *) + +let rotate_registers = false + +(* Representation of hard registers by pseudo-registers *) + +let hard_int_reg = + let v = Array.create 7 Reg.dummy in + for i = 0 to 6 do v.(i) <- Reg.at_location Int (Reg i) done; + v + +let hard_float_reg = [| Reg.at_location Float (Reg 100) |] + +let all_phys_regs = + Array.append hard_int_reg hard_float_reg + +let phys_reg n = + if n < 100 then hard_int_reg.(n) else hard_float_reg.(n - 100) + +let eax = phys_reg 0 +let ecx = phys_reg 2 +let edx = phys_reg 3 +let tos = phys_reg 100 + +let stack_slot slot ty = + Reg.at_location ty (Stack slot) + +(* Instruction selection *) + +let word_addressed = false + +(* Calling conventions *) + +let calling_conventions first_int last_int first_float last_float make_stack + arg = + let loc = Array.create (Array.length arg) Reg.dummy in + let int = ref first_int in + let float = ref first_float in + let ofs = ref 0 in + for i = 0 to Array.length arg - 1 do + match arg.(i).typ with + Int | Addr as ty -> + if !int <= last_int then begin + loc.(i) <- phys_reg !int; + incr int + end else begin + loc.(i) <- stack_slot (make_stack !ofs) ty; + ofs := !ofs + size_int + end + | Float -> + if !float <= last_float then begin + loc.(i) <- phys_reg !float; + incr float + end else begin + loc.(i) <- stack_slot (make_stack !ofs) Float; + ofs := !ofs + size_float + end + done; + (loc, !ofs) + +let incoming ofs = Incoming ofs +let outgoing ofs = Outgoing ofs +let not_supported ofs = fatal_error "Proc.loc_results: cannot call" + +let loc_arguments arg = + calling_conventions 0 5 100 99 outgoing arg +let loc_parameters arg = + let (loc, ofs) = calling_conventions 0 5 100 99 incoming arg in loc +let loc_results res = + let (loc, ofs) = calling_conventions 0 5 100 100 not_supported res in loc +let extcall_use_push = true +let loc_external_arguments arg = + fatal_error "Proc.loc_external_arguments" +let loc_external_results res = + let (loc, ofs) = calling_conventions 0 0 100 100 not_supported res in loc + +let loc_exn_bucket = eax + +(* Registers destroyed by operations *) + +let destroyed_at_c_call = (* ebx, esi, edi, ebp preserved *) + Array.of_list(List.map phys_reg [0;2;3]) + +let destroyed_at_oper = function + Iop(Icall_ind | Icall_imm _ | Iextcall(_, true)) -> all_phys_regs + | Iop(Iextcall(_, false)) -> destroyed_at_c_call + | Iop(Iintop(Idiv | Imod)) -> [| eax; edx |] + | Iop(Iintop_imm(Imod, _)) -> [| eax |] + | Iop(Ialloc _) -> [| eax |] + | Iop(Iintop(Icomp _) | Iintop_imm(Icomp _, _)) -> [| eax |] + | Iop(Iintoffloat) -> [| eax |] + | Iifthenelse(Ifloattest(_, _), _, _) -> [| eax |] + | _ -> [||] + +let destroyed_at_raise = all_phys_regs + +(* Maximal register pressure *) + +let safe_register_pressure op = 4 + +let max_register_pressure = function + Iextcall(_, _) -> [| 4; max_int |] + | Iintop(Idiv | Imod) -> [| 5; max_int |] + | Ialloc _ | Iintop(Icomp _) | Iintop_imm(Icomp _, _) | + Iintoffloat -> [| 6; max_int |] + | _ -> [|7; max_int |] + +(* Layout of the stack frame *) + +let num_stack_slots = [| 0; 0 |] +let contains_calls = ref false + +(* Calling the assembler *) + +let assemble_file infile outfile = + Ccomp.command ("ml /nologo /coff /Cp /c /Fo" ^ + Filename.quote outfile ^ " " ^ Filename.quote infile ^ ">NUL") + (* /Cp preserve case of all used identifiers + /c assemble only + /Fo output file name *) + diff --git a/asmcomp/i386/reload.ml b/asmcomp/i386/reload.ml new file mode 100644 index 00000000..67f8a61f --- /dev/null +++ b/asmcomp/i386/reload.ml @@ -0,0 +1,83 @@ +(***********************************************************************) +(* *) +(* 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: reload.ml,v 1.5 2002/11/22 15:09:18 xleroy Exp $ *) + +open Cmm +open Arch +open Reg +open Mach + +(* Reloading for the Intel x86 *) + +let stackp r = + match r.loc with + Stack _ -> true + | _ -> false + +class reload = object (self) + +inherit Reloadgen.reload_generic as super + +method makereg r = + match r.typ with + Float -> r + | _ -> super#makereg r + +(* By overriding makereg, we make sure that pseudoregs of type float + will never be reloaded. Hence there is no need to make special cases for + floating-point operations. *) + +method reload_operation op arg res = + match op with + Iintop(Iadd|Isub|Iand|Ior|Ixor|Icomp _|Icheckbound) -> + (* One of the two arguments can reside in the stack *) + if stackp arg.(0) && stackp arg.(1) + then ([|arg.(0); self#makereg arg.(1)|], res) + else (arg, res) + | Iintop(Imul) -> + (* First argument (and destination) must be in register, + second arg can reside in stack *) + if stackp arg.(0) + then let r = self#makereg arg.(0) in ([|r; arg.(1)|], [|r|]) + else (arg, res) + | Iintop_imm(Iadd, _) when arg.(0).loc <> res.(0).loc -> + (* This add will be turned into a lea; args and results must be + in registers *) + super#reload_operation op arg res + | Iintop_imm(Imul, _) -> + (* First argument and destination must be in register *) + if stackp arg.(0) + then let r = self#makereg arg.(0) in ([|r|], [|r|]) + else (arg, res) + | Iintop(Ilsl|Ilsr|Iasr) | Iintop_imm(_, _) | Ifloatofint | Iintoffloat | + Ispecific(Ipush) -> + (* The argument(s) can be either in register or on stack *) + (arg, res) + | _ -> (* Other operations: all args and results in registers *) + super#reload_operation op arg res + +method reload_test tst arg = + match tst with + Iinttest cmp -> + (* One of the two arguments can reside on stack *) + if stackp arg.(0) && stackp arg.(1) + then [| self#makereg arg.(0); arg.(1) |] + else arg + | _ -> + (* The argument(s) can be either in register or on stack *) + arg + +end + +let fundecl f = + (new reload)#fundecl f diff --git a/asmcomp/i386/scheduling.ml b/asmcomp/i386/scheduling.ml new file mode 100644 index 00000000..bc90f0d2 --- /dev/null +++ b/asmcomp/i386/scheduling.ml @@ -0,0 +1,22 @@ +(***********************************************************************) +(* *) +(* 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: scheduling.ml,v 1.3 2000/02/04 12:43:18 xleroy Exp $ *) + +open Schedgen (* to create a dependency *) + +(* Scheduling is turned off because our model does not fit the 486 + nor the Pentium very well. In particular, it messes up with the + float reg stack. The Pentiums Pro / II / III / etc schedule + at run-time much better than what we could do. *) + +let fundecl f = f diff --git a/asmcomp/i386/selection.ml b/asmcomp/i386/selection.ml new file mode 100644 index 00000000..b40884dd --- /dev/null +++ b/asmcomp/i386/selection.ml @@ -0,0 +1,310 @@ +(***********************************************************************) +(* *) +(* 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: selection.ml,v 1.13 2003/02/25 15:50:13 xleroy Exp $ *) + +(* Instruction selection for the Intel x86 *) + +open Misc +open Arch +open Proc +open Cmm +open Reg +open Mach + +(* Auxiliary for recognizing addressing modes *) + +type addressing_expr = + Asymbol of string + | Alinear of expression + | Aadd of expression * expression + | Ascale of expression * int + | Ascaledadd of expression * expression * int + +let rec select_addr exp = + match exp with + Cconst_symbol s -> + (Asymbol s, 0) + | Cop((Caddi | Cadda), [arg; Cconst_int m]) -> + let (a, n) = select_addr arg in (a, n + m) + | Cop((Csubi | Csuba), [arg; Cconst_int m]) -> + let (a, n) = select_addr arg in (a, n - m) + | Cop((Caddi | Cadda), [Cconst_int m; arg]) -> + let (a, n) = select_addr arg in (a, n + m) + | Cop(Clsl, [arg; Cconst_int(1|2|3 as shift)]) -> + begin match select_addr arg with + (Alinear e, n) -> (Ascale(e, 1 lsl shift), n lsl shift) + | _ -> (Alinear exp, 0) + end + | Cop(Cmuli, [arg; Cconst_int(2|4|8 as mult)]) -> + begin match select_addr arg with + (Alinear e, n) -> (Ascale(e, mult), n * mult) + | _ -> (Alinear exp, 0) + end + | Cop(Cmuli, [Cconst_int(2|4|8 as mult); arg]) -> + begin match select_addr arg with + (Alinear e, n) -> (Ascale(e, mult), n * mult) + | _ -> (Alinear exp, 0) + end + | Cop((Caddi | Cadda), [arg1; arg2]) -> + begin match (select_addr arg1, select_addr arg2) with + ((Alinear e1, n1), (Alinear e2, n2)) -> + (Aadd(e1, e2), n1 + n2) + | ((Alinear e1, n1), (Ascale(e2, scale), n2)) -> + (Ascaledadd(e1, e2, scale), n1 + n2) + | ((Ascale(e1, scale), n1), (Alinear e2, n2)) -> + (Ascaledadd(e2, e1, scale), n1 + n2) + | (_, (Ascale(e2, scale), n2)) -> + (Ascaledadd(arg1, e2, scale), n2) + | ((Ascale(e1, scale), n1), _) -> + (Ascaledadd(arg2, e1, scale), n1) + | _ -> + (Aadd(arg1, arg2), 0) + end + | arg -> + (Alinear arg, 0) + +(* C functions to be turned into Ifloatspecial instructions if -ffast-math *) + +let inline_float_ops = + ["atan"; "atan2"; "cos"; "log"; "log10"; "sin"; "sqrt"; "tan"] + +(* Estimate number of float temporaries needed to evaluate expression + (Ershov's algorithm) *) + +let rec float_needs = function + Cop((Cnegf | Cabsf), [arg]) -> + float_needs arg + | Cop((Caddf | Csubf | Cmulf | Cdivf), [arg1; arg2]) -> + let n1 = float_needs arg1 in + let n2 = float_needs arg2 in + if n1 = n2 then 1 + n1 else if n1 > n2 then n1 else n2 + | Cop(Cextcall(fn, ty_res, alloc), args) + when !fast_math && List.mem fn inline_float_ops -> + begin match args with + [arg] -> float_needs arg + | [arg1; arg2] -> max (float_needs arg2 + 1) (float_needs arg1) + | _ -> assert false + end + | _ -> + 1 + +(* Special constraints on operand and result registers *) + +exception Use_default + +let eax = phys_reg 0 +let ecx = phys_reg 2 +let edx = phys_reg 3 +let tos = phys_reg 100 + +let pseudoregs_for_operation op arg res = + match op with + (* Two-address binary operations *) + Iintop(Iadd|Isub|Imul|Iand|Ior|Ixor) -> + ([|res.(0); arg.(1)|], res, false) + (* Two-address unary operations *) + | Iintop_imm((Iadd|Isub|Imul|Idiv|Iand|Ior|Ixor|Ilsl|Ilsr|Iasr), _) -> + (res, res, false) + (* For shifts with variable shift count, second arg must be in ecx *) + | Iintop(Ilsl|Ilsr|Iasr) -> + ([|res.(0); ecx|], res, false) + (* For div and mod, first arg must be in eax, edx is clobbered, + and result is in eax or edx respectively. + Keep it simple, just force second argument in ecx. *) + | Iintop(Idiv) -> + ([| eax; ecx |], [| eax |], true) + | Iintop(Imod) -> + ([| eax; ecx |], [| edx |], true) + (* For mod with immediate operand, arg must not be in eax. + Keep it simple, force it in edx. *) + | Iintop_imm(Imod, _) -> + ([| edx |], [| edx |], true) + (* For floating-point operations and floating-point loads, + the result is always left at the top of the floating-point stack *) + | Iconst_float _ | Inegf | Iabsf | Iaddf | Isubf | Imulf | Idivf + | Ifloatofint | Iload((Single | Double | Double_u), _) + | Ispecific(Isubfrev | Idivfrev | Ifloatarithmem(_, _, _) | Ifloatspecial _) -> + (arg, [| tos |], false) (* don't move it immediately *) + (* For storing a byte, the argument must be in eax...edx. + (But for a short, any reg will do!) + Keep it simple, just force the argument to be in edx. *) + | Istore((Byte_unsigned | Byte_signed), addr) -> + let newarg = Array.copy arg in + newarg.(0) <- edx; + (newarg, res, false) + (* Other instructions are regular *) + | _ -> raise Use_default + +let chunk_double = function + Single -> false + | Double -> true + | Double_u -> true + | _ -> assert false + +(* The selector class *) + +class selector = object (self) + +inherit Selectgen.selector_generic as super + +method is_immediate (n : int) = true + +method select_addressing exp = + match select_addr exp with + (Asymbol s, d) -> + (Ibased(s, d), Ctuple []) + | (Alinear e, d) -> + (Iindexed d, e) + | (Aadd(e1, e2), d) -> + (Iindexed2 d, Ctuple[e1; e2]) + | (Ascale(e, scale), d) -> + (Iscaled(scale, d), e) + | (Ascaledadd(e1, e2, scale), d) -> + (Iindexed2scaled(scale, d), Ctuple[e1; e2]) + +method select_store addr exp = + match exp with + Cconst_int n -> + (Ispecific(Istore_int(Nativeint.of_int n, addr)), Ctuple []) + | Cconst_natint n -> + (Ispecific(Istore_int(n, addr)), Ctuple []) + | Cconst_pointer n -> + (Ispecific(Istore_int(Nativeint.of_int n, addr)), Ctuple []) + | Cconst_natpointer n -> + (Ispecific(Istore_int(n, addr)), Ctuple []) + | Cconst_symbol s -> + (Ispecific(Istore_symbol(s, addr)), Ctuple []) + | _ -> + super#select_store addr exp + +method select_operation op args = + match op with + (* Recognize the LEA instruction *) + Caddi | Cadda | Csubi | Csuba -> + begin match self#select_addressing (Cop(op, args)) with + (Iindexed d, _) -> super#select_operation op args + | (Iindexed2 0, _) -> super#select_operation op args + | (addr, arg) -> (Ispecific(Ilea addr), [arg]) + end + (* Recognize (x / cst) and (x % cst) only if cst is a power of 2. *) + | Cdivi -> + begin match args with + [arg1; Cconst_int n] when n = 1 lsl (Misc.log2 n) -> + (Iintop_imm(Idiv, n), [arg1]) + | _ -> (Iintop Idiv, args) + end + | Cmodi -> + begin match args with + [arg1; Cconst_int n] when n = 1 lsl (Misc.log2 n) -> + (Iintop_imm(Imod, n), [arg1]) + | _ -> (Iintop Imod, args) + end + (* Recognize float arithmetic with memory. + In passing, apply Ershov's algorithm to reduce stack usage *) + | Caddf -> + self#select_floatarith Iaddf Iaddf Ifloatadd Ifloatadd args + | Csubf -> + self#select_floatarith Isubf (Ispecific Isubfrev) Ifloatsub Ifloatsubrev args + | Cmulf -> + self#select_floatarith Imulf Imulf Ifloatmul Ifloatmul args + | Cdivf -> + self#select_floatarith Idivf (Ispecific Idivfrev) Ifloatdiv Ifloatdivrev args + (* Recognize store instructions *) + | Cstore Word -> + begin match args with + [loc; Cop(Caddi, [Cop(Cload _, [loc']); Cconst_int n])] + when loc = loc' -> + let (addr, arg) = self#select_addressing loc in + (Ispecific(Ioffset_loc(n, addr)), [arg]) + | _ -> + super#select_operation op args + end + (* Recognize inlined floating point operations *) + | Cextcall(fn, ty_res, false) + when !fast_math && List.mem fn inline_float_ops -> + (Ispecific(Ifloatspecial fn), args) + (* Default *) + | _ -> super#select_operation op args + +(* Recognize float arithmetic with mem *) + +method select_floatarith regular_op reversed_op mem_op mem_rev_op args = + match args with + [arg1; Cop(Cload chunk, [loc2])] -> + let (addr, arg2) = self#select_addressing loc2 in + (Ispecific(Ifloatarithmem(chunk_double chunk, mem_op, addr)), + [arg1; arg2]) + | [Cop(Cload chunk, [loc1]); arg2] -> + let (addr, arg1) = self#select_addressing loc1 in + (Ispecific(Ifloatarithmem(chunk_double chunk, mem_rev_op, addr)), + [arg2; arg1]) + | [arg1; arg2] -> + (* Evaluate bigger subexpression first to minimize stack usage. + Because of right-to-left evaluation, rightmost arg is evaluated + first *) + if float_needs arg1 <= float_needs arg2 + then (regular_op, [arg1; arg2]) + else (reversed_op, [arg2; arg1]) + | _ -> + fatal_error "Proc_i386: select_floatarith" + +(* Deal with register constraints *) + +method insert_op op rs rd = + try + let (rsrc, rdst, move_res) = pseudoregs_for_operation op rs rd in + self#insert_moves rs rsrc; + self#insert (Iop op) rsrc rdst; + if move_res then begin + self#insert_moves rdst rd; + rd + end else + rdst + with Use_default -> + super#insert_op op rs rd + +(* Selection of push instructions for external calls *) + +method select_push exp = + match exp with + Cconst_int n -> (Ispecific(Ipush_int(Nativeint.of_int n)), Ctuple []) + | Cconst_natint n -> (Ispecific(Ipush_int n), Ctuple []) + | Cconst_pointer n -> (Ispecific(Ipush_int(Nativeint.of_int n)), Ctuple []) + | Cconst_natpointer n -> (Ispecific(Ipush_int n), Ctuple []) + | Cconst_symbol s -> (Ispecific(Ipush_symbol s), Ctuple []) + | Cop(Cload Word, [loc]) -> + let (addr, arg) = self#select_addressing loc in + (Ispecific(Ipush_load addr), arg) + | Cop(Cload Double_u, [loc]) -> + let (addr, arg) = self#select_addressing loc in + (Ispecific(Ipush_load_float addr), arg) + | _ -> (Ispecific(Ipush), exp) + +method emit_extcall_args env args = + let rec emit_pushes = function + [] -> 0 + | e :: el -> + let ofs = emit_pushes el in + let (op, arg) = self#select_push e in + begin match self#emit_expr env arg with + None -> ofs + | Some r -> + self#insert (Iop op) r [||]; + ofs + Selectgen.size_expr env e + end + in ([||], emit_pushes args) + +end + +let fundecl f = (new selector)#emit_fundecl f + diff --git a/asmcomp/ia64/arch.ml b/asmcomp/ia64/arch.ml new file mode 100644 index 00000000..12b686bc --- /dev/null +++ b/asmcomp/ia64/arch.ml @@ -0,0 +1,88 @@ +(***********************************************************************) +(* *) +(* 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 Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: arch.ml,v 1.5 2002/11/29 15:03:36 xleroy Exp $ *) + +(* Specific operations for the IA64 processor *) + +open Misc +open Format + +(* Machine-specific command-line options *) + +let command_line_options = [] + +(* Addressing modes -- only one! (register with no displacement) *) + +type addressing_mode = Iindexed + +(* Specific operations *) + +type specific_operation = + Iadd1 (* x + y + 1 or x + x + 1 *) + | Isub1 (* x - y - 1 *) + | Ishladd of int (* x << N + y *) + | Isignextend of int (* truncate 64-bit int to 8N-bit int *) + | Imultaddf (* x *. y +. z *) + | Imultsubf (* x *. y -. z *) + | Isubmultf (* z -. x *. y *) + | Istoreincr of int (* store y at x; x <- x + N *) + | Iinitbarrier (* end of object initialization *) + +(* Sizes, endianness *) + +let big_endian = false + +let size_addr = 8 +let size_int = 8 +let size_float = 8 + +(* Operations on addressing modes *) + +let identity_addressing = Iindexed + +let offset_addressing addr delta = assert false + +let num_args_addressing = function Iindexed -> 1 + +(* Printing operations and addressing modes *) + +let print_addressing printreg addr ppf arg = + printreg ppf arg.(0) + +let print_specific_operation printreg op ppf arg = + match op with + | Iadd1 -> + if Array.length arg >= 2 then + fprintf ppf "%a + %a + 1 " printreg arg.(0) printreg arg.(1) + else + fprintf ppf "%a << 1 + 1 " printreg arg.(0) + | Isub1 -> + fprintf ppf "%a - %a - 1 " printreg arg.(0) printreg arg.(1) + | Ishladd n -> + fprintf ppf "%a << %d + %a" printreg arg.(0) n printreg arg.(1) + | Isignextend n -> + fprintf ppf "truncate%d %a" (n * 8) printreg arg.(0) + | Imultaddf -> + fprintf ppf "%a * %a + %a" + printreg arg.(0) printreg arg.(1) printreg arg.(2) + | Imultsubf -> + fprintf ppf "%a * %a - %a" + printreg arg.(0) printreg arg.(1) printreg arg.(2) + | Isubmultf -> + fprintf ppf "%a - %a * %a" + printreg arg.(2) printreg arg.(0) printreg arg.(1) + | Istoreincr n -> + fprintf ppf "[%a] := %a; %a += %d" + printreg arg.(0) printreg arg.(1) printreg arg.(0) n + | Iinitbarrier -> + fprintf ppf "initbarrier" diff --git a/asmcomp/ia64/emit.mlp b/asmcomp/ia64/emit.mlp new file mode 100644 index 00000000..53b4af4a --- /dev/null +++ b/asmcomp/ia64/emit.mlp @@ -0,0 +1,1326 @@ +(***********************************************************************) +(* *) +(* 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 Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: emit.mlp,v 1.13 2002/11/24 15:55:25 xleroy Exp $ *) + +(* Emission of IA64 assembly code *) + +open Location +open Printf +open Misc +open Cmm +open Arch +open Proc +open Reg +open Mach +open Linearize +open Emitaux + +(************** Part 1: assembly-level scheduler *******************) + +(* Representation of resources accessed or produced by instructions *) + +type resource = string + (* A resource is either: + - a register name + - "stkN" for a stack location + - "heap" for the Caml heap + - "chkN" for the result of a checkbound instruction *) + +let is_memory_resource rsrc = + String.length rsrc >= 4 && + begin match String.sub rsrc 0 3 with + "stk" -> true + | "hea" -> true + | "chk" -> true + | _ -> false + end + +let is_mutable_resource rsrc = + rsrc <> "r0" && rsrc <> "p0" + +(* Description of instructions *) + +type instruction_kind = + KA (* A type instruction (int or mem unit) *) + | KB (* B type instruction (branch unit) *) + | KI (* I type instruction (int unit *) + | KF (* F type instruction (FP unit) *) + | KM (* M type instruction (mem unit) *) + | KB_exc (* B type instruction, exceptional condition, + can be moved around *) + +type instruction_format = + F_i (* op imm *) + | F_i_pred (* (pred) op imm *) + | F_ir_rr (* op p1,p2 = imm, r *) + | F_ir_r (* op r = imm, r *) + | F_ir_r_pred (* (pred) op r = imm, r *) + | F_ld (* op r = [r] *) + | F_ld_post (* op r = [r], imm *) + | F_r (* op r *) + | F_i_r (* op r = imm *) + | F_i_r_pred (* (pred) op r = imm *) + | F_ri_rr (* op p1,p2 = imm, r *) + | F_ri_r (* op r = imm, r *) + | F_r_r (* op r = r *) + | F_r_r_pred (* (pred) op r = r *) + | F_rr_rr (* op p1,p2 = r1, r2 *) + | F_r_rir (* op r = r1, imm, r2 *) + | F_rr_r (* op r = r1, r2 *) + | F_rr_r_pred (* (pred) op r = r1, r2 *) + | F_rri_r (* op r = r1, r2, imm *) + | F_rrr_r (* op r = r1, r2, r3 *) + | F_rrr_r_pred (* (pred) op r = r1, r2, r3 *) + | F_st (* op [r] = r *) + | F_st_post (* op [r] = r, imm *) + +type instruction_descr = + { opcode: string; (* actual opcode *) + latency: int; (* latency in cycles *) + kind: instruction_kind; (* kind of instruction *) + format: instruction_format } (* how to generate asm for it *) + +let instruction_table = create_hashtable 73 [ + "add", {opcode = "add"; latency = 1; kind = KA; format = F_rr_r}; + "add1", {opcode = "add"; latency = 1; kind = KA; format = F_rri_r}; + "addcond", {opcode = "add"; latency = 1; kind = KA; format = F_rr_r_pred}; + "addi", {opcode = "add"; latency = 1; kind = KA; format = F_ir_r}; + "addicond", {opcode = "add"; latency = 1; kind = KA; format = F_ir_r_pred}; + "and", {opcode = "and"; latency = 1; kind = KA; format = F_rr_r}; + "andi", {opcode = "and"; latency = 1; kind = KA; format = F_ir_r}; + "br", {opcode = "br.sptk.many"; latency = 1; kind = KB; format = F_i}; + "brret", {opcode = "br.ret.sptk"; latency = 1; kind = KB; format = F_r}; + "brcall", {opcode = "br.call.sptk.many"; latency = 1; kind = KB; format = F_i_r}; + "brcallcond", {opcode = "br.call.spnt.many"; latency = 1; kind = KB; format = F_i_r_pred}; + "brcallcondexc", {opcode = "br.call.spnt.many"; latency = 1; kind = KB_exc; format = F_i_r_pred}; + "brcallind", {opcode = "br.call.sptk.many"; latency = 1; kind = KB; format = F_r_r}; + "brcond", {opcode = "br.dpnt.many"; latency = 1; kind = KB; format = F_i_pred}; + "brind", {opcode = "br.sptk.many"; latency = 1; kind = KB; format = F_r}; + "cmp.eq", {opcode = "cmp.eq"; latency = 0; kind = KA; format = F_rr_rr}; + "cmp.ge", {opcode = "cmp.ge"; latency = 0; kind = KA; format = F_rr_rr}; + "cmp.geu", {opcode = "cmp.geu"; latency = 0; kind = KA; format = F_rr_rr}; + "cmp.gt", {opcode = "cmp.gt"; latency = 0; kind = KA; format = F_rr_rr}; + "cmp.gtu", {opcode = "cmp.gtu"; latency = 0; kind = KA; format = F_rr_rr}; + "cmp.le", {opcode = "cmp.le"; latency = 0; kind = KA; format = F_rr_rr}; + "cmp.leu", {opcode = "cmp.leu"; latency = 0; kind = KA; format = F_rr_rr}; + "cmp.lt", {opcode = "cmp.lt"; latency = 0; kind = KA; format = F_rr_rr}; + "cmp.ltu", {opcode = "cmp.ltu"; latency = 0; kind = KA; format = F_rr_rr}; + "cmp.ne", {opcode = "cmp.ne"; latency = 0; kind = KA; format = F_rr_rr}; + "cmpi.eq", {opcode = "cmp.eq"; latency = 0; kind = KA; format = F_ir_rr}; + "cmpi.ge", {opcode = "cmp.ge"; latency = 0; kind = KA; format = F_ir_rr}; + "cmpi.geu", {opcode = "cmp.geu"; latency = 0; kind = KA; format = F_ir_rr}; + "cmpi.gt", {opcode = "cmp.gt"; latency = 0; kind = KA; format = F_ir_rr}; + "cmpi.gtu", {opcode = "cmp.gtu"; latency = 0; kind = KA; format = F_ir_rr}; + "cmpi.le", {opcode = "cmp.le"; latency = 0; kind = KA; format = F_ir_rr}; + "cmpi.leu", {opcode = "cmp.leu"; latency = 0; kind = KA; format = F_ir_rr}; + "cmpi.lt", {opcode = "cmp.lt"; latency = 0; kind = KA; format = F_ir_rr}; + "cmpi.ltu", {opcode = "cmp.ltu"; latency = 0; kind = KA; format = F_ir_rr}; + "cmpi.ne", {opcode = "cmp.ne"; latency = 0; kind = KA; format = F_ir_rr}; + "cmpp.eq", {opcode = "cmp.eq"; latency = 1; kind = KA; format = F_rr_rr}; + "cmpp.ge", {opcode = "cmp.ge"; latency = 1; kind = KA; format = F_rr_rr}; + "cmpp.geu", {opcode = "cmp.geu"; latency = 1; kind = KA; format = F_rr_rr}; + "cmpp.gt", {opcode = "cmp.gt"; latency = 1; kind = KA; format = F_rr_rr}; + "cmpp.gtu", {opcode = "cmp.gtu"; latency = 1; kind = KA; format = F_rr_rr}; + "cmpp.le", {opcode = "cmp.le"; latency = 1; kind = KA; format = F_rr_rr}; + "cmpp.leu", {opcode = "cmp.leu"; latency = 1; kind = KA; format = F_rr_rr}; + "cmpp.lt", {opcode = "cmp.lt"; latency = 1; kind = KA; format = F_rr_rr}; + "cmpp.ltu", {opcode = "cmp.ltu"; latency = 1; kind = KA; format = F_rr_rr}; + "cmpp.ne", {opcode = "cmp.ne"; latency = 1; kind = KA; format = F_rr_rr}; + "cmpp.ne.and", {opcode = "cmp.ne.and"; latency = 1; kind = KA; format = F_rr_rr}; + "cmppi.eq", {opcode = "cmp.eq"; latency = 1; kind = KA; format = F_ir_rr}; + "cmppi.ge", {opcode = "cmp.ge"; latency = 1; kind = KA; format = F_ir_rr}; + "cmppi.geu", {opcode = "cmp.geu"; latency = 1; kind = KA; format = F_ir_rr}; + "cmppi.gt", {opcode = "cmp.gt"; latency = 1; kind = KA; format = F_ir_rr}; + "cmppi.gtu", {opcode = "cmp.gtu"; latency = 1; kind = KA; format = F_ir_rr}; + "cmppi.le", {opcode = "cmp.le"; latency = 1; kind = KA; format = F_ir_rr}; + "cmppi.leu", {opcode = "cmp.leu"; latency = 1; kind = KA; format = F_ir_rr}; + "cmppi.lt", {opcode = "cmp.lt"; latency = 1; kind = KA; format = F_ir_rr}; + "cmppi.ltu", {opcode = "cmp.ltu"; latency = 1; kind = KA; format = F_ir_rr}; + "cmppi.ne", {opcode = "cmp.ne"; latency = 1; kind = KA; format = F_ir_rr}; + "extr.u", {opcode = "extr.u"; latency = 1; kind = KI; format = F_ri_r}; + "fabs", {opcode = "fabs"; latency = 1; kind = KF; format = F_r_r}; + "fadd.d", {opcode = "fadd.d"; latency = 5; kind = KF; format = F_rr_r}; + "fcmp.eq", {opcode = "fcmp.eq"; latency = 1; kind = KF; format = F_rr_rr}; + "fcmp.ge", {opcode = "fcmp.ge"; latency = 1; kind = KF; format = F_rr_rr}; + "fcmp.gt", {opcode = "fcmp.gt"; latency = 1; kind = KF; format = F_rr_rr}; + "fcmp.le", {opcode = "fcmp.le"; latency = 1; kind = KF; format = F_rr_rr}; + "fcmp.lt", {opcode = "fcmp.lt"; latency = 1; kind = KF; format = F_rr_rr}; + "fcmp.neq", {opcode = "fcmp.neq"; latency = 1; kind = KF; format = F_rr_rr}; + "fcvt.fx.trunc", {opcode = "fcvt.fx.trunc"; latency = 7; kind = KF; format = F_r_r}; + "fcvt.xf", {opcode = "fcvt.xf"; latency = 5; kind = KF; format = F_r_r}; + "fma.d", {opcode = "fma.d"; latency = 5; kind = KF; format = F_rrr_r}; + "fmacond", {opcode = "fma.d.s0"; latency = 5; kind = KF; format = F_rrr_r_pred}; + "fmas1cond", {opcode = "fma.s1"; latency = 5; kind = KF; format = F_rrr_r_pred}; + "fmads1cond", {opcode = "fma.d.s1"; latency = 5; kind = KF; format = F_rrr_r_pred}; + "fmpy.d", {opcode = "fmpy.d"; latency = 5; kind = KF; format = F_rr_r}; + "fms.d", {opcode = "fms.d"; latency = 5; kind = KF; format = F_rrr_r}; + "fneg", {opcode = "fneg"; latency = 1; kind = KF; format = F_r_r}; + "fnma.d", {opcode = "fnma.d"; latency = 5; kind = KF; format = F_rrr_r}; + "fnmas1cond", {opcode = "fnma.s1"; latency = 5; kind = KF; format = F_rrr_r_pred}; + "fnmads1cond", {opcode = "fnma.d.s1"; latency = 5; kind = KF; format = F_rrr_r_pred}; + "fnorm.d", {opcode = "fnorm.d"; latency = 5; kind = KF; format = F_r_r}; + "frcpa", {opcode = "frcpa.s0"; latency = 5; kind = KF; format = F_rr_rr}; + "fsub.d", {opcode = "fsub.d"; latency = 5; kind = KF; format = F_rr_r}; + "getf.sig", {opcode = "getf.sig"; latency = 2; kind = KM; format = F_r_r}; + "ld1", {opcode = "ld1"; latency = 2; kind = KM; format = F_ld}; + "ld2", {opcode = "ld2"; latency = 2; kind = KM; format = F_ld}; + "ld4", {opcode = "ld4"; latency = 2; kind = KM; format = F_ld}; + "ld8", {opcode = "ld8"; latency = 2; kind = KM; format = F_ld}; + "ld8+", {opcode = "ld8"; latency = 2; kind = KM; format = F_ld_post}; + "ldfd", {opcode = "ldfd"; latency = 9; kind = KM; format = F_ld}; + "ldfd+", {opcode = "ldfd"; latency = 9; kind = KM; format = F_ld_post}; + "ldfs", {opcode = "ldfs"; latency = 9; kind = KM; format = F_ld}; + "mov", {opcode = "mov"; latency = 1; kind = KA; format = F_r_r}; + "movcond", {opcode = "mov"; latency = 1; kind = KA; format = F_r_r_pred}; + "movtb", {opcode = "mov"; latency = 9; kind = KI; format = F_r_r}; + "movfb", {opcode = "mov"; latency = 2; kind = KI; format = F_r_r}; + "movi", {opcode = "mov"; latency = 1; kind = KA; format = F_i_r}; + "movicond", {opcode = "mov"; latency = 1; kind = KA; format = F_i_r_pred}; + "movil", {opcode = "movl"; latency = 1; kind = KI; format = F_i_r}; + "movpr", {opcode = "mov"; latency = 1; kind = KI; format = F_ri_r}; + "or", {opcode = "or"; latency = 1; kind = KA; format = F_rr_r}; + "ori", {opcode = "or"; latency = 1; kind = KA; format = F_ir_r}; + "setf.d", {opcode = "setf.d"; latency = 8; kind = KM; format = F_r_r}; + "setf.sig", {opcode = "setf.sig"; latency = 8; kind = KM; format = F_r_r}; + "shl", {opcode = "shl"; latency = 2; kind = KI; format = F_rr_r}; + "shladd", {opcode = "shladd"; latency = 1; kind = KA; format = F_r_rir}; + "shli", {opcode = "shl"; latency = 1; kind = KI; format = F_ri_r}; + "shr", {opcode = "shr"; latency = 2; kind = KI; format = F_rr_r}; + "shri", {opcode = "shr"; latency = 1; kind = KI; format = F_ri_r}; + "shru", {opcode = "shr.u"; latency = 2; kind = KI; format = F_rr_r}; + "shrui", {opcode = "shr.u"; latency = 1; kind = KI; format = F_ri_r}; + "st1", {opcode = "st1"; latency = 0; kind = KM; format = F_st}; + "st2", {opcode = "st2"; latency = 0; kind = KM; format = F_st}; + "st4", {opcode = "st4"; latency = 0; kind = KM; format = F_st}; + "st8", {opcode = "st8"; latency = 0; kind = KM; format = F_st}; + "st8+", {opcode = "st8"; latency = 1; kind = KM; format = F_st_post}; + "stfd", {opcode = "stfd"; latency = 0; kind = KM; format = F_st}; + "stfd+", {opcode = "stfd"; latency = 1; kind = KM; format = F_st_post}; + "stfs", {opcode = "stfs"; latency = 0; kind = KM; format = F_st}; + "sub", {opcode = "sub"; latency = 1; kind = KA; format = F_rr_r}; + "sub1", {opcode = "sub"; latency = 1; kind = KA; format = F_rri_r}; + "subi", {opcode = "sub"; latency = 1; kind = KA; format = F_ir_r}; + "sxt1", {opcode = "sxt1"; latency = 1; kind = KI; format = F_r_r}; + "sxt2", {opcode = "sxt2"; latency = 1; kind = KI; format = F_r_r}; + "sxt4", {opcode = "sxt4"; latency = 1; kind = KI; format = F_r_r}; + "tbit.nz", {opcode = "tbit.nz"; latency = 0; kind = KI; format = F_ri_rr}; + "tbit.z", {opcode = "tbit.z"; latency = 0; kind = KI; format = F_ri_rr}; + "xmpy.l", {opcode = "xmpy.l"; latency = 7; kind = KF; format = F_rr_r}; + "xor", {opcode = "xor"; latency = 1; kind = KA; format = F_rr_r}; + "xori", {opcode = "xor"; latency = 1; kind = KA; format = F_ir_r}; + "#initbarrier", {opcode = "# init barrier"; latency = 0; kind = KI; format = F_i}; +] + +(* Nodes of the code DAG. Each node represents one instruction to be + emitted. *) + +type code_dag_node = + { instr: instruction_descr; (* the instruction *) + imm: string; (* its immediate argument, if any *) + iarg: resource array; (* arguments *) + ires: resource array; (* results *) + delay: int; (* how many cycles before result is available *) + mutable sons: (code_dag_node * int) list; + (* nodes that depend on this node *) + mutable date: int; (* start date *) + mutable length: int; (* length of longest path to result *) + mutable ancestors: int; (* number of ancestors *) + mutable emitted_ancestors: int } (* number of emitted ancestors *) + +(* The code dag itself is represented by two tables from resources to nodes: + - "results" maps resources to the instructions that produced them; + - "uses" maps resources to the instructions that use them. *) + +let code_results = (Hashtbl.create 31 : (resource, code_dag_node) Hashtbl.t) +let code_uses = (Hashtbl.create 31 : (resource, code_dag_node) Hashtbl.t) + +let clear_code_dag () = + Hashtbl.clear code_results; + Hashtbl.clear code_uses + +(* The ready queue: a list of nodes that can be computed immediately + (all arguments are available), kept sorted by decreasing length to results. + + The in progress queue: a list of nodes whose arguments are being computed, + and thus can be computed at a later date, kept sorted by increasing + availability date + + The branch list: a list of all branch instructions (to be emitted last) *) + +let ready_queue = ref ([] : code_dag_node list) +let in_progress_queue = ref ([] : code_dag_node list) +let branch_list = ref ([] : code_dag_node list) (* built in reverse order *) + +let clear_queues () = + ready_queue := []; in_progress_queue := []; branch_list := [] + +let rec insert_queue prio node = function + [] -> [node] + | hd :: tl as queue -> + if prio node hd then node :: queue else hd :: insert_queue prio node tl + +let length_prio n1 n2 = n1.length > n2.length +let date_prio n1 n2 = n1.date < n2.date + +let add_ready node = + ready_queue := insert_queue length_prio node !ready_queue +let add_in_progress node = + in_progress_queue := insert_queue date_prio node !in_progress_queue +let add_branch node = + branch_list := node :: !branch_list + +(* Add an edge to the code DAG *) + +let add_edge ancestor son delay = + ancestor.sons <- (son, delay) :: ancestor.sons; + son.ancestors <- son.ancestors + 1 + +let add_edge_after son ancestor = add_edge ancestor son 0 + +(* Add an instruction to the code DAG *) + +let insimm opc arg imm res = + let instr = + try + Hashtbl.find instruction_table opc + with Not_found -> + fatal_error ("Unknown instruction " ^ opc) in + let node = + { instr = instr; + imm = imm; + iarg = arg; + ires = res; + delay = instr.latency; + sons = []; (* to be filled later *) + date = 0; (* to be adjusted later *) + length = -1; (* to be computed later *) + ancestors = 0; (* ditto *) + emitted_ancestors = 0 } in (* ditto *) + (* RAW dependencies: add edges from all instrs that define one of the + resources used *) + for i = 0 to Array.length arg - 1 do + try + let rsrc = arg.(i) in + if is_mutable_resource rsrc then begin + let anc = Hashtbl.find code_results rsrc in + let delay = if is_memory_resource rsrc then 0 else anc.delay in + (* Memory accesses are ordered by the hardware, so we can emit + a memop 1, then a dependent memop 2 in the same cycle *) + add_edge anc node delay + end + with Not_found -> + () + done; + (* WAR dependencies: add edges from all instrs that use one of the + resources defined by this instruction + WAW dependencies: add edges from all instrs that define one of the + resources defined by this instruction *) + for i = 0 to Array.length res - 1 do + let rsrc = res.(i) in + if is_mutable_resource rsrc then begin + (* WAR *) + let anc = Hashtbl.find_all code_uses res.(i) in + List.iter (add_edge_after node) anc; + (* WAW *) + try + let anc = Hashtbl.find code_results rsrc in + let delay = if is_memory_resource rsrc then 0 else 1 in + add_edge anc node delay + with Not_found -> + () + end + done; + (* Remember the results and uses of this instruction *) + for i = 0 to Array.length res - 1 do + Hashtbl.add code_results res.(i) node + done; + for i = 0 to Array.length arg - 1 do + Hashtbl.add code_uses arg.(i) node + done; + (* Insert in appropriate queue *) + if node.instr.kind = KB + then add_branch node + else if node.ancestors = 0 then add_ready node + +let insert opc arg res = + insimm opc arg "" res + +(* Compute length of longest path to a result. *) + +let rec longest_path node = + if node.length < 0 then begin + node.length <- + List.fold_left + (fun len (son, delay) -> max len (longest_path son + delay)) + 0 node.sons + end; + node.length + +(* Emit the assembly code for a node *) + +let emit_r = emit_string + +let emit_instr node = + let opc = node.instr.opcode + and a = node.iarg + and r = node.ires + and imm = node.imm in + match node.instr.format with + F_i -> + ` {emit_string opc} {emit_string imm}\n` + | F_i_pred -> + ` ({emit_r a.(0)}) {emit_string opc} {emit_string imm}\n` + | F_ir_rr -> + ` {emit_string opc} {emit_r r.(0)}, {emit_r r.(1)} = {emit_string imm}, {emit_r a.(0)}\n` + | F_ir_r -> + ` {emit_string opc} {emit_r r.(0)} = {emit_string imm}, {emit_r a.(0)}\n` + | F_ir_r_pred -> + ` ({emit_r a.(0)}) {emit_string opc} {emit_r r.(0)} = {emit_string imm}, {emit_r a.(1)}\n` + | F_ld -> + ` {emit_string opc} {emit_r r.(0)} = [{emit_r a.(0)}]\n` + | F_ld_post -> + ` {emit_string opc} {emit_r r.(0)} = [{emit_r a.(0)}], {emit_string imm}\n` + | F_r -> + ` {emit_string opc} {emit_r a.(0)}\n` + | F_i_r -> + ` {emit_string opc} {emit_r r.(0)} = {emit_string imm}\n` + | F_i_r_pred -> + ` ({emit_r a.(0)}) {emit_string opc} {emit_r r.(0)} = {emit_string imm}\n` + | F_ri_rr -> + ` {emit_string opc} {emit_r r.(0)}, {emit_r r.(1)} = {emit_r a.(0)}, {emit_string imm}\n` + | F_ri_r -> + ` {emit_string opc} {emit_r r.(0)} = {emit_r a.(0)}, {emit_string imm}\n` + | F_r_r -> + ` {emit_string opc} {emit_r r.(0)} = {emit_r a.(0)}\n` + | F_r_r_pred -> + ` ({emit_r a.(0)}) {emit_string opc} {emit_r r.(0)} = {emit_r a.(1)}\n` + | F_rr_rr -> + ` {emit_string opc} {emit_r r.(0)}, {emit_r r.(1)} = {emit_r a.(0)}, {emit_r a.(1)}\n` + | F_r_rir -> + ` {emit_string opc} {emit_r r.(0)} = {emit_r a.(0)}, {emit_string imm}, {emit_r a.(1)}\n` + | F_rr_r -> + ` {emit_string opc} {emit_r r.(0)} = {emit_r a.(0)}, {emit_r a.(1)}\n` + | F_rr_r_pred -> + ` ({emit_r a.(0)}) {emit_string opc} {emit_r r.(0)} = {emit_r a.(1)}, {emit_r a.(2)}\n` + | F_rri_r -> + ` {emit_string opc} {emit_r r.(0)} = {emit_r a.(0)}, {emit_r a.(1)}, {emit_string imm}\n` + | F_rrr_r -> + ` {emit_string opc} {emit_r r.(0)} = {emit_r a.(0)}, {emit_r a.(1)}, {emit_r a.(2)}\n` + | F_rrr_r_pred -> + ` ({emit_r a.(0)}) {emit_string opc} {emit_r r.(0)} = {emit_r a.(1)}, {emit_r a.(2)}, {emit_r a.(3)}\n` + | F_st -> + ` {emit_string opc} [{emit_r a.(0)}] = {emit_r a.(1)}\n` + | F_st_post -> + ` {emit_string opc} [{emit_r a.(0)}] = {emit_r a.(1)}, {emit_string imm}\n` + +(* Little state machine reflecting how many instructions the chip can + issue in one cycle. We roughly follow the Itanium model: + 2 int units, 2 mem units, 2 FP units, and 3 branch units, + with a maximum of 6 instructions dispatched per clock cycle. *) + +let num_A = ref 0 +let num_I = ref 0 +let num_M = ref 0 +let num_F = ref 0 +let num_B = ref 0 + +let reset_issue () = + num_A := 0; num_I := 0; num_M := 0; num_F := 0; num_B := 0 + +let can_issue instr = + if !num_A + !num_I + !num_M + !num_F + !num_B >= 6 then false else begin + match instr.kind with + KA -> + if !num_A + !num_I + !num_M < 4 + then (incr num_A; true) + else false + | KF -> + if !num_F < 2 then (incr num_F; true) else false + | KI -> + if !num_I < 2 && !num_A + !num_I + !num_M < 4 + then (incr num_I; true) else false + | KM -> + if !num_M < 2 && !num_A + !num_I + !num_M < 4 + then (incr num_M; true) else false + | _ (* KB | KB_exc *) -> + if !num_B < 3 then (incr num_B; true) else false + end + +(* Emit one node, updating the completion date and number of ancestors + emitted for all nodes that depend on this node. Enter the nodes + that are no longer waiting on anything (all ancestors emitted) + in the ready queue or in the in_progress queue, depending on + latency. *) + +let emit_node date node = + begin try + (*`# Date: {emit_int date}; distance: {emit_int node.length}\n`;*) + emit_instr node + with x -> + fatal_error ("Error while emitting " ^ node.instr.opcode) + end; + List.iter + (fun (son, delay) -> + let completion_date = date + delay in + if son.date < completion_date then son.date <- completion_date; + son.emitted_ancestors <- son.emitted_ancestors + 1; + if son.emitted_ancestors = son.ancestors && son.instr.kind <> KB then + begin + (*`# {emit_string son.instr.opcode} will be ready at {emit_int son.date}\n`;*) + if son.date = date then add_ready son else add_in_progress son + end) + node.sons + +(* Emit all ready nodes that we can emit given the architectural + constraints. *) + +let rec emit_ready_nodes filter date = + match !ready_queue with + [] -> [] + | node :: rem -> + ready_queue := rem; + if filter node && can_issue node.instr then begin + emit_node date node; + emit_ready_nodes filter date + end else + node :: emit_ready_nodes filter date + +let filter_MF node = + match node.instr.kind with KM -> true | KF -> true | _ -> false +let filter_non_MF node = + not(filter_MF node) + +(* Add all instructions with date <= d to the ready queue, and remove them *) + +let rec extract_ready d = function + [] -> [] + | node :: rem as queue -> + if node.date <= d then (add_ready node; extract_ready d rem) else queue + +(* Say if a branch is ready to be emitted now *) + +let branch_is_ready date br = + br.emitted_ancestors = br.ancestors && br.date <= date + +(* Schedule the basic block, emitting all of its instructions *) + +let rec reschedule date = + match (!ready_queue, !in_progress_queue) with + ([], []) -> + (* We're done with the regular instructions; finish with the branches *) + begin match !branch_list with + [] -> () + | br -> List.iter emit_instr br; emit_string " ;;\n" + end + | ([], node :: _) -> + (* Advance to the time node.date, extracting from in_progress_queue + all instructions ready at that time and adding them to the + ready queue *) + in_progress_queue := extract_ready node.date !in_progress_queue; + (* Try again *) + reschedule node.date + | (_, _) -> + ` # time {emit_int date}\n`; + (* Emit and remove as many ready instructions as we can *) + (* Give priority to M and F instructions *) + reset_issue(); + ready_queue := emit_ready_nodes filter_MF date; + ready_queue := emit_ready_nodes filter_non_MF date; + (* Special hack: if the only remaining instructions are branches + and they are all ready now, emit them in the current + group of instructions *) + if !ready_queue = [] + && !in_progress_queue = [] + && List.for_all (branch_is_ready date) !branch_list + then begin + List.iter emit_instr !branch_list; + branch_list := [] + end; + (* Emit a stop to pause the processor *) + emit_string " ;;\n"; + (* Advance to the time date + 1, extracting from in_progress_queue + all instructions ready at that time and adding them to the + ready queue *) + in_progress_queue := extract_ready (date + 1) !in_progress_queue; + (* Try again *) + reschedule (date + 1) + +(* Emit the code for the current basic block *) + +let end_basic_block () = + (* Compute critical paths and rebuild ready queue sorted by + decreasing criticality *) + let r = !ready_queue in + ready_queue := []; + let max_length = + List.fold_left (fun len node -> max len (longest_path node)) 0 r in + List.iter add_ready r; + branch_list := List.rev !branch_list; + (* Emit the instructions by traversing the code DAG *) + reschedule 0; + if max_length > 0 then ` # basic block length {emit_int max_length}\n`; + clear_code_dag (); + clear_queues () + +(************** Part 2: the code emitter *******************) + +(* Tradeoff between code size and code speed *) + +let fastcode_flag = ref true + +(* Translate or output a label *) + +let label lbl = sprintf ".L%d" lbl + +let emit_label lbl = emit_string ".L"; emit_int lbl + +(* Translate or output a symbol *) + +let symbol s = + let b = Buffer.create (String.length s + 1) in + for i = 0 to String.length s - 1 do + let c = s.[i] in + match c with + 'A'..'Z' | 'a'..'z' | '0'..'9' | '_' -> + Buffer.add_char b c + | _ -> + Buffer.add_string b (sprintf "$%02x" (Char.code c)) + done; + Buffer.add_char b '#'; + Buffer.contents b + +let emit_symbol s = Emitaux.emit_symbol '$' s + +(* Translate a pseudo-register *) + +let reg r = + match r.loc with Reg r -> register_name r | _ -> assert false + +let regs r = + Array.map reg r + +(* Output a pseudo-register *) + +let emit_reg r = + match r.loc with + Reg r -> emit_string (register_name r) + | _ -> fatal_error "Emit_ia64.emit_reg" + +(* Translate a float as a 64-bit integer *) + +let float_bits f = + let b = Buffer.create 18 in + let bytes = (Obj.magic f : string) in + Buffer.add_string b "0x"; + for i = 7 downto 0 do (* little-endian *) + Buffer.add_string b + (sprintf "%02x" (Char.code (String.unsafe_get bytes i))) + done; + Buffer.contents b + +(* Translate an "ltoffset" reference to a global *) + +let ltoffset s = sprintf "@ltoff(%s)" (symbol s) +let ltoffset_fptr s = sprintf "@ltoff(@fptr(%s))" (symbol s) + +(* Layout of the stack frame. + All stack offsets are shifted by 16 to preserve the scratch area at + bottom of stack. *) + +let stack_offset = ref 0 + +let frame_size () = + let size = + !stack_offset + + 8 * (num_stack_slots.(0) + num_stack_slots.(1)) + + (if !contains_calls then 8 else 0) in + Misc.align size 16 + +let slot_offset loc cl = + match loc with + Incoming n -> frame_size() + n + 16 + | Local n -> + if cl = 0 + then !stack_offset + n * 8 + 16 + else !stack_offset + (num_stack_slots.(0) + n) * 8 + 16 + | Outgoing n -> n + 16 + +let slot_offset_reg r = + match r.loc with + Stack l -> slot_offset l (register_class r) + | _ -> assert false + +(* Record live pointers at call points *) + +type frame_descr = + { fd_lbl: int; (* Return address *) + fd_frame_size: int; (* Size of stack frame *) + fd_live_offset: int list } (* Offsets/regs of live addresses *) + +let frame_descriptors = ref([] : frame_descr list) + +let record_frame_label live = + let lbl = new_label() in + let live_offset = ref [] in + Reg.Set.iter + (function + {typ = Addr; loc = Reg r} -> + live_offset := ((r lsl 1) + 1) :: !live_offset + | {typ = Addr; loc = Stack s} as reg -> + live_offset := slot_offset s (register_class reg) :: !live_offset + | _ -> ()) + live; + frame_descriptors := + { fd_lbl = lbl; + fd_frame_size = frame_size(); + fd_live_offset = !live_offset } :: !frame_descriptors; + lbl + +let record_frame live = + let lbl = record_frame_label live in `{emit_label lbl}:` + +let emit_frame fd = + ` data8 {emit_label fd.fd_lbl}\n`; + ` data2 {emit_int fd.fd_frame_size}\n`; + ` data2 {emit_int (List.length fd.fd_live_offset)}\n`; + List.iter + (fun n -> + ` data2 {emit_int n}\n`) + fd.fd_live_offset; + ` .align 8\n` + +(* Names of various instructions *) + +let name_for_int_operation = function + Iadd -> "add" + | Isub -> "sub" + | Iand -> "and" + | Ior -> "or" + | Ixor -> "xor" + | Ilsl -> "shl" + | Ilsr -> "shru" + | Iasr -> "shr" + | _ -> Misc.fatal_error "Emit.name_for_int_operation" + +let name_for_float_operation = function + Inegf -> "fneg" + | Iabsf -> "fabs" + | Iaddf -> "fadd.d" + | Isubf -> "fsub.d" + | Imulf -> "fmpy.d" + | _ -> Misc.fatal_error "Emit.name_for_float_operation" + +let name_for_specific_operation = function + Imultaddf -> "fma.d" + | Imultsubf -> "fms.d" + | Isubmultf -> "fnma.d" + | _ -> Misc.fatal_error "Emit.name_for_specific_operation" + +let name_for_int_comparison = function + Isigned Ceq -> "eq" | Isigned Cne -> "ne" + | Isigned Cle -> "le" | Isigned Cgt -> "gt" + | Isigned Clt -> "lt" | Isigned Cge -> "ge" + | Iunsigned Ceq -> "eq" | Iunsigned Cne -> "ne" + | Iunsigned Cle -> "leu" | Iunsigned Cgt -> "gtu" + | Iunsigned Clt -> "ltu" | Iunsigned Cge -> "geu" + +let name_for_swapped_int_comparison = function + Isigned Ceq -> "eq" | Isigned Cne -> "ne" + | Isigned Cle -> "ge" | Isigned Cgt -> "lt" + | Isigned Clt -> "gt" | Isigned Cge -> "le" + | Iunsigned Ceq -> "eq" | Iunsigned Cne -> "ne" + | Iunsigned Cle -> "geu" | Iunsigned Cgt -> "ltu" + | Iunsigned Clt -> "gtu" | Iunsigned Cge -> "leu" + +let name_for_float_comparison cmp = + match cmp with + Ceq -> "eq" | Cne -> "neq" + | Cle -> "le" | Cgt -> "gt" + | Clt -> "lt" | Cge -> "ge" + +(* Immediate range for addl (move) and adds (general add) instructions *) + +let is_immediate_addl n = n >= -0x200000 && n < 0x200000 +let is_immediate_addl_nat n = + n >= Nativeint.of_int (-0x200000) && n < Nativeint.of_int 0x200000 +let is_immediate_adds n = n >= -0x2000 && n < 0x2000 + +(* Return the positions of all "1" bits in the given integer, + most significant bits first *) + +let ones_pos n = + let rec ones p accu = + if p >= 63 + then accu + else ones (p+1) (if n land (1 lsl p) = 0 then accu else p :: accu) in + ones 0 [] + +(* Generate temporary registers *) + +let temp_generator temporaries = + let counter = ref 0 in + fun () -> + let r = temporaries.(!counter) in + incr counter; + if !counter >= Array.length temporaries then counter := 0; + r + +let new_temp_reg = + temp_generator [| "r2"; "r3"; "r14"; "r15" |] +let new_temp_float = + temp_generator [| "f64"; "f65"; "f66"; "f67"; + "f68"; "f69"; "f70"; "f71" |] +let new_pred = + temp_generator [| "p2"; "p3"; "p4"; "p5" |] + +(* Output the assembly code for an instruction *) + +(* Name of current function *) +let function_name = ref "" +(* Entry point for tail recursive calls *) +let tailrec_entry_point = ref 0 + +let emit_instr i = + match i.desc with + Lend -> () + | Lop(Imove | Ispill | Ireload) -> + let src = i.arg.(0) and dst = i.res.(0) in + if src.loc <> dst.loc then begin + match (src.loc, dst.loc) with + (Reg _, Reg _) -> + insert "mov" (regs i.arg) (regs i.res) + | (Reg _, Stack _) -> + let offset = string_of_int (slot_offset_reg dst) in + let r = new_temp_reg() in + insimm "addi" [| "sp" |] offset [| r |]; + insert (if i.res.(0).typ = Float then "stfd" else "st8") + [| r; reg src |] [| "stk" ^ offset |] + | (Stack _, Reg _) -> + let offset = string_of_int (slot_offset_reg src) in + let r = new_temp_reg() in + insimm "addi" [| "sp" |] offset [| r |]; + insert (if i.arg.(0).typ = Float then "ldfd" else "ld8") + [| r; "stk" ^ offset |] (regs i.res) + | (_, _) -> + assert false + end + | Lop(Iconst_int n) -> + let instr = + if is_immediate_addl_nat n then "movi" else "movil" in + insimm instr [||] (Nativeint.to_string n) (regs i.res) + | Lop(Iconst_float s) -> + let f = float_of_string s in + if f = 0.0 then + insert "mov" [| "f0" |] (regs i.res) + else if f = 1.0 then + insert "mov" [| "f1" |] (regs i.res) + else begin + let tmp = new_temp_reg() in + insimm "movil" [||] (float_bits f) [| tmp |]; + insert "setf.d" [| tmp |] (regs i.res) + end + | Lop(Iconst_symbol s) -> + insimm "addi" [| "gp" |] (ltoffset s) (regs i.res); + insert "ld8" (regs i.res) (regs i.res) + | Lop(Icall_ind) -> + insert "movtb" (regs i.arg) [| "b0" |]; + insert "brcallind" [| "b0" |] [| "b0" |]; + end_basic_block(); + `{record_frame i.live}\n` + | Lop(Icall_imm s) -> + insimm "brcall" [||] (symbol s) [| "b0" |]; + end_basic_block(); + `{record_frame i.live}\n` + | Lop(Itailcall_ind) -> + let n = frame_size() in + insert "movtb" (regs i.arg) [| "b6" |]; + if !contains_calls then begin + let tmp = new_temp_reg() in + insimm "addi" [| "sp" |] (string_of_int (n + 8)) [| tmp |]; + insert "ld8" [| tmp |] [| tmp |]; + insert "mov" [| tmp |] [| "b0" |] + end; + if n > 0 then + insimm "addi" [| "sp" |] (string_of_int n) [| "sp" |]; + insert "brind" [| "b6" |] [||]; + end_basic_block() + | Lop(Itailcall_imm s) -> + if s = !function_name then begin + insimm "br" [||] (label !tailrec_entry_point) [||] + end else begin + let n = frame_size() in + if !contains_calls then begin + let tmp = new_temp_reg() in + insimm "addi" [| "sp" |] (string_of_int (n + 8)) [| tmp |]; + insert "ld8" [| tmp |] [| tmp |]; + insert "mov" [| tmp |] [| "b0" |] + end; + if n > 0 then + insimm "addi" [| "sp" |] (string_of_int n) [| "sp" |]; + insimm "br" [||] (symbol s) [||] + end; + end_basic_block() + | Lop(Iextcall(s, alloc)) -> + if alloc then begin + let tmp = new_temp_reg() in + insimm "addi" [| "gp" |] (ltoffset_fptr s) [| tmp |]; + insert "ld8" [| tmp |] [| "r2" |]; + insimm "brcall" [||] "caml_c_call#" [| "b0" |]; + end_basic_block(); + `{record_frame i.live}\n` + end else begin + insert "mov" [| "gp" |] [| "r7" |]; + insimm "brcall" [||] (symbol s) [| "b0" |]; + end_basic_block(); + insert "mov" [| "r7" |] [| "gp" |] + end + | Lop(Istackoffset n) -> + end_basic_block(); + insimm "addi" [| "sp" |] (string_of_int (-n)) [| "sp" |]; + stack_offset := !stack_offset + n + | Lop(Iload(chunk, addr)) -> + let load_instr = + match chunk with + | Byte_unsigned -> "ld1" + | Byte_signed -> "ld1" + | Sixteen_unsigned -> "ld2" + | Sixteen_signed -> "ld2" + | Thirtytwo_unsigned -> "ld4" + | Thirtytwo_signed -> "ld4" + | Word -> "ld8" + | Single -> "ldfs" + | Double -> "ldfd" + | Double_u -> "ldfd" in + insert load_instr [| reg i.arg.(0); "heap" |] (regs i.res); + let sext_instr = + match chunk with + Byte_signed -> "sxt1" + | Sixteen_signed -> "sxt2" + | Thirtytwo_signed -> "sxt4" + | _ -> "" in + if sext_instr <> "" then + insert sext_instr (regs i.res) (regs i.res) + | Lop(Istore(chunk, addr)) -> + let store_instr = + match chunk with + | Byte_unsigned -> "st1" + | Byte_signed -> "st1" + | Sixteen_unsigned -> "st2" + | Sixteen_signed -> "st2" + | Thirtytwo_unsigned -> "st4" + | Thirtytwo_signed -> "st4" + | Word -> "st8" + | Single -> "stfs" + | Double -> "stfd" + | Double_u -> "stfd" in + insert store_instr [| reg i.arg.(1); reg i.arg.(0) |] [| "heap" |] + | Lop(Ialloc n) -> + if !fastcode_flag then begin + insimm "addi" [| "r4" |] (string_of_int (-n)) [| "r4" |]; + insert "cmp.ltu" [| "r4"; "r5" |] [| "p6"; "p0" |]; + insimm "movi" [||] (string_of_int n) [| "r2" |]; + insimm "brcallcond" [| "p6" |] "caml_call_gc#" [| "b0" |]; + end_basic_block(); + `{record_frame i.live}\n`; + insimm "addi" [| "r4" |] "8" (regs i.res) + end else begin + insimm "movi" [||] (string_of_int n) [| "r2" |]; + insimm "brcall" [||] "caml_alloc#" [| "b0" |]; + end_basic_block(); + `{record_frame i.live}\n`; + insimm "addi" [| "r4" |] "8" (regs i.res) + end + | Lop(Iintop Imul) -> + let t1 = new_temp_float() and t2 = new_temp_float() in + insert "setf.sig" [|reg i.arg.(0)|] [| t1 |]; + insert "setf.sig" [|reg i.arg.(1)|] [| t2 |]; + insert "xmpy.l" [| t1; t2 |] [| t1 |]; + insert "getf.sig" [| t1 |] (regs i.res) + | Lop(Iintop(Icomp cmp)) -> + let comp = "cmpp." ^ name_for_int_comparison cmp in + let p1 = new_pred() and p2 = new_pred() in + insert comp (regs i.arg) [| p1; p2 |]; + insimm "movicond" [| p1 |] "1" (regs i.res); + insimm "movicond" [| p2 |] "0" (regs i.res) + | Lop(Iintop(Icheckbound)) -> + insert "cmp.leu" (regs i.arg) [| "p6"; "p0" |]; + insimm "brcallcondexc" [| "p6" |] "caml_array_bound_error#" + [| "b0"; "heap" |] + | Lop(Iintop op) -> + let instr = name_for_int_operation op in + insert instr (regs i.arg) (regs i.res) + | Lop(Iintop_imm(Imul, n)) -> + let src = reg i.arg.(0) and dst = reg i.res.(0) in + begin match ones_pos n with + [] -> + insimm "movi" [||] "0" [|dst|] + | [n] -> + insimm "shli" [|src|] (string_of_int n) [|dst|] + | [n; 0] when n <= 4 -> + insimm "shladd" [|src; src|] (string_of_int n) [|dst|] + | n1::n2::lst -> + let acc1 = new_temp_reg() and acc2 = new_temp_reg() + and tmp1 = new_temp_reg() and tmp2 = new_temp_reg() in + insimm "shli" [|src|] (string_of_int n1) [|acc1|]; + insimm "shli" [|src|] (string_of_int n2) [|acc2|]; + let rec add_shifts a1 t1 a2 t2 = function + [] -> + insert "add" [|a1; a2|] [|dst|] + | n::rem -> + if n = 0 then + insert "add" [|src; a1|] [|a1|] + else if n <= 4 then + insimm "shladd" [|src; a1|] (string_of_int n) [|a1|] + else begin + insimm "shli" [|src|] (string_of_int n) [|t1|]; + insert "add" [|t1; a1|] [|a1|] + end; + add_shifts a2 t2 a1 t1 rem in + add_shifts acc1 tmp1 acc2 tmp2 lst + end + | Lop(Iintop_imm(Idiv, n)) -> (* n must be a power of 2 *) + let src = regs i.arg and dst = regs i.res in + let p1 = new_pred() and p2 = new_pred() in + let l = Misc.log2 n in + insert "cmpp.lt" [| src.(0); "r0" |] [| p1; p2 |]; + if is_immediate_adds (n-1) then + insimm "addicond" [| p1; src.(0) |] (string_of_int (n-1)) dst + else begin + let moveop = if is_immediate_addl (n-1) then "movi" else "movil" in + insimm moveop [||] (string_of_int (n-1)) [| "r2" |]; + insert "addcond" [| p1; src.(0); "r2" |] dst + end; + insert "movcond" [| p2; src.(0) |] dst; + insimm "shri" dst (string_of_int l) dst + | Lop(Iintop_imm(Imod, n)) -> (* n must be a power of 2 *) + let src = regs i.arg and dst = regs i.res in + let p = new_pred() in + let l = Misc.log2 n in + insert "cmpp.lt" [| src.(0); "r0" |] [| p; "p0" |]; + insimm "extr.u" src (sprintf "0, %d" l) dst; + insert "cmpp.ne.and" [| dst.(0); "r0"; p |] [| p; "p0" |]; + if is_immediate_adds (-n) then + insimm "addicond" [| p; dst.(0) |] (string_of_int (-n)) dst + else begin + let moveop = if is_immediate_addl (-n) then "movi" else "movil" in + insimm moveop [||] (string_of_int (-n)) [| "r2" |]; + insert "addcond" [| p; dst.(0); "r2" |] dst + end + | Lop(Iintop_imm(Icomp cmp, n)) -> + let comp = "cmppi." ^ name_for_swapped_int_comparison cmp in + let p1 = new_pred() and p2 = new_pred() in + insimm comp (regs i.arg) (string_of_int n) [| p1; p2 |]; + insimm "movicond" [| p1 |] "1" (regs i.res); + insimm "movicond" [| p2 |] "0" (regs i.res) + | Lop(Iintop_imm(Icheckbound, n)) -> + insimm "cmpi.geu" (regs i.arg) (string_of_int n) [| "p6"; "p0" |]; + insimm "brcallcondexc" [| "p6" |] "caml_array_bound_error#" + [| "b0"; "heap" |] + | Lop(Iintop_imm(op, n)) -> + let instr = name_for_int_operation op ^ "i" in + insimm instr (regs i.arg) (string_of_int n) (regs i.res) + | Lop(Inegf | Iabsf | Iaddf | Isubf | Imulf as op) -> + let instr = name_for_float_operation op in + insert instr (regs i.arg) (regs i.res) + | Lop(Idivf) -> + (* Straight from the IA64 application developer's architecture guide, + section 13.3.3.1. Modified so that the destination may be equal + to one of the operands *) + let a = reg i.arg.(0) and b = reg i.arg.(1) and r = reg i.res.(0) + and t1 = new_temp_float() and t2 = new_temp_float() + and t3 = new_temp_float() and t4 = new_temp_float() + and p = new_pred() in + insert "frcpa" [| a; b |] [| t1; p |]; + insert "fmas1cond" [| p; a; t1; "f0" |] [| t2 |]; + insert "fnmas1cond" [| p; b; t1; "f1" |] [| t3 |]; + insert "fmas1cond" [| p; t3; t3; t2 |] [| t2 |]; + insert "fmas1cond" [| p; t3; t3; "f0" |] [| t4 |]; + insert "fmas1cond" [| p; t3; t1; t1 |] [| t1 |]; + insert "fmas1cond" [| p; t4; t2; t2 |] [| t2 |]; + insert "fmas1cond" [| p; t4; t4; "f0" |] [| t3 |]; + insert "fmas1cond" [| p; t4; t1; t1 |] [| t1 |]; + insert "fmads1cond" [| p; t3; t2; t2 |] [| t2 |]; + insert "fmas1cond" [| p; t3; t1; t1 |] [| t1 |]; + insert "fnmads1cond" [| p; b; t2; a |] [| t3 |]; + insert "mov" [| t1 |] [| r |]; + insert "fmacond" [| p; t3; t1; t2 |] [| r |] + | Lop(Ifloatofint) -> + let src = regs i.arg and dst = regs i.res in + insert "setf.sig" src dst; + insert "fcvt.xf" dst dst; + insert "fnorm.d" dst dst + | Lop(Iintoffloat) -> + let src = regs i.arg and dst = regs i.res and tmp = new_temp_float() in + insert "fcvt.fx.trunc" src [| tmp |]; + insert "getf.sig" [| tmp |] dst + | Lop(Ispecific(Iadd1)) -> + let s = if Array.length i.arg >= 2 then 1 else 0 in + insimm "add1" [| reg i.arg.(0); reg i.arg.(s) |] "1" (regs i.res) + | Lop(Ispecific(Isub1)) -> + insimm "sub1" (regs i.arg) "1" (regs i.res) + | Lop(Ispecific(Ishladd n)) -> + insimm "shladd" (regs i.arg) (string_of_int n) (regs i.res) + | Lop(Ispecific(Isignextend n)) -> + let op = "sxt" ^ string_of_int n in + insert op (regs i.arg) (regs i.res) + | Lop(Ispecific (Imultaddf | Imultsubf | Isubmultf as sop)) -> + let name = name_for_specific_operation sop in + insert name (regs i.arg) (regs i.res) + | Lop(Ispecific (Istoreincr n)) -> + let op = if i.arg.(1).typ = Float then "stfd+" else "st8+" in + insimm op [| reg i.arg.(0); reg i.arg.(1) |] + (string_of_int n) + [| reg i.res.(0); "heapinit" |] + | Lop(Ispecific Iinitbarrier) -> + insert "#initbarrier" [| "heapinit" |] [| "heap" |] + | Lreloadretaddr -> + let n = frame_size() + 8 in + let tmp = new_temp_reg() in + insimm "addi" [| "sp" |] (string_of_int n) [| tmp |]; + insert "ld8" [| tmp |] [| tmp |]; + insert "movtb" [| tmp |] [| "b0" |] + | Lreturn -> + let n = frame_size() in + if n > 0 then + insimm "addi" [| "sp" |] (string_of_int n) [| "sp" |]; + insert "brret" [| "b0" |] [||]; + end_basic_block() + | Llabel lbl -> + end_basic_block(); + `{emit_label lbl}:\n` + | Lbranch lbl -> + insimm "br" [||] (label lbl) [||]; + end_basic_block() + | Lcondbranch(tst, lbl) -> + begin match tst with + Itruetest -> + insimm "cmpi.ne" (regs i.arg) "0" [| "p6"; "p0" |] + | Ifalsetest -> + insimm "cmpi.eq" (regs i.arg) "0" [| "p6"; "p0" |] + | Iinttest cmp -> + let comp = "cmp." ^ name_for_int_comparison cmp in + insert comp (regs i.arg) [| "p6"; "p0" |] + | Iinttest_imm(cmp, n) -> + let comp = "cmpi." ^ name_for_swapped_int_comparison cmp in + insimm comp (regs i.arg) (string_of_int n) [| "p6"; "p0" |] + | Ifloattest(cmp, neg) -> + let comp = "fcmp." ^ name_for_float_comparison cmp in + insert comp (regs i.arg) + (if neg then [| "p0"; "p6" |] + else [| "p6"; "p0" |]) + | Ioddtest -> + insimm "tbit.nz" (regs i.arg) "0" [| "p6"; "p0" |] + | Ieventest -> + insimm "tbit.z" (regs i.arg) "0" [| "p6"; "p0" |] + end; + insimm "brcond" [| "p6" |] (label lbl) [||]; + end_basic_block() + | Lcondbranch3(lbl0, lbl1, lbl2) -> + end_basic_block(); + let emit_compare n p = function + None -> () + | Some lbl -> + ` cmp.eq p{emit_int p}, p0 = {emit_int n}, {emit_reg i.arg.(0)}\n` in + let emit_branch p = function + None -> () + | Some lbl -> + ` (p{emit_int p}) br {emit_label lbl}\n` in + emit_compare 0 5 lbl0; emit_compare 1 6 lbl1; emit_compare 2 7 lbl2; + emit_branch 5 lbl0; emit_branch 6 lbl1; emit_branch 7 lbl2; + ` ;;\n` + | Lswitch jumptbl -> + end_basic_block(); + let numcases = Array.length jumptbl in + if numcases <= 9 then begin + for j = 0 to numcases / 3 do + let n = j * 3 in + for k = 0 to 2 do + if n + k < numcases - 1 then + ` cmp.eq p{emit_int(k+5)}, p0 = {emit_int (n+k)}, {emit_reg i.arg.(0)}\n` + done; + for k = 0 to 2 do + if n + k < numcases - 1 then + ` (p{emit_int(k+5)}) br {emit_label jumptbl.(n+k)}\n` + else if n + k = numcases - 1 then + ` br {emit_label jumptbl.(n+k)}\n` + done; + ` ;;\n` + done + end else if numcases <= 47 then begin + ` mov r2 = 1\n`; + ` cmp.eq p6, p0 = 0, {emit_reg i.arg.(0)}\n`; + ` (p6) br {emit_label jumptbl.(0)} ;;\n`; + ` shl r2 = r2, {emit_reg i.arg.(0)}\n`; + ` cmp.eq p7, p0 = 1, {emit_reg i.arg.(0)}\n`; + ` (p7) br {emit_label jumptbl.(1)} ;;\n`; + ` mov pr = r2, -1 ;;\n`; + for i = 2 to numcases - 1 do + ` (p{emit_int i}) br {emit_label jumptbl.(i)}\n` + done; + ` ;;\n` + end else begin + let lbl_jumptbl = new_label() in + let lbl_ip = new_label() in + `{emit_label lbl_ip}: mov r2 = ip ;;\n`; + ` add r2 = {emit_label lbl_jumptbl} - {emit_label lbl_ip}, r2 ;;\n`; + ` shladd r3 = {emit_reg i.arg.(0)}, 2, r2 ;;\n`; + ` ld4 r3 = [r3] ;;\n`; + ` sxt4 r3 = r3 ;;\n`; + ` add r2 = r2, r3 ;;\n`; + ` mov b6 = r2 ;;\n`; + ` br b6 ;;\n`; + ` .align 4\n`; + `{emit_label lbl_jumptbl}:\n`; + for i = 0 to numcases - 1 do + ` data4 {emit_label jumptbl.(i)} - {emit_label lbl_jumptbl}\n` + done; + ` .align 16\n` + end + | Lsetuptrap lbl -> + end_basic_block(); + let lbl_ip = new_label() in + let lbl_next = new_label() in + `{emit_label lbl_ip}: mov r2 = ip ;;\n`; + ` add r2 = {emit_label lbl_next} - {emit_label lbl_ip}, r2\n`; + ` br.sptk {emit_label lbl} ;;\n`; + `{emit_label lbl_next}:\n` + | Lpushtrap -> + end_basic_block(); + stack_offset := !stack_offset + 16; + (* Store trap pointer at sp, handler addr at sp+8, + and decrement sp by 16. Remember, the bottom 16 bytes + of the stack must be left free. *) + ` add r3 = 8, sp\n`; + ` st8 [sp] = r6, -16 ;;\n`; + ` st8 [r3] = r2\n`; + ` add r6 = 16, sp ;;\n` + | Lpoptrap -> + end_basic_block(); + ` add sp = 16, sp ;;\n`; + ` ld8 r6 = [sp] ;;\n`; + stack_offset := !stack_offset - 16 + | Lraise -> + end_basic_block(); + ` mov sp = r6\n`; + ` add r2 = 8, r6\n`; + ` ld8 r6 = [r6] ;;\n`; + ` ld8 r2 = [r2] ;;\n`; + ` mov b6 = r2 ;;\n`; + ` br b6\n` + +let rec emit_all i = + match i.desc with Lend -> () | _ -> emit_instr i; emit_all i.next + +(* Check if a function contains a tail call to itself *) + +let rec is_tailrec i = + match i.desc with + Lend -> false + | Lop(Itailcall_imm s) when s = !function_name -> true + | _ -> is_tailrec i.next + +(* Emission of a function declaration *) + +let fundecl f = + function_name := f.fun_name; + fastcode_flag := f.fun_fast; + stack_offset := 0; + ` .text\n`; + ` .align 4\n`; + ` .global {emit_symbol f.fun_name}#\n`; + ` .proc {emit_symbol f.fun_name}#\n`; + `{emit_symbol f.fun_name}:\n`; + let n = frame_size() in + if !contains_calls then begin + insert "movfb" [| "b0" |] [| "r2" |]; + insimm "addi" [| "sp" |] "8" [| "r3" |]; + insimm "addi" [| "sp" |] (string_of_int (-n)) [| "sp" |]; + insert "st8" [| "r3"; "r2" |] [||] + end + else if n > 0 then + insimm "addi" [| "sp" |] (string_of_int (-n)) [| "sp" |]; + if is_tailrec f.fun_body then begin + tailrec_entry_point := new_label(); + end_basic_block(); + `{emit_label !tailrec_entry_point}:\n` + end; + emit_all f.fun_body; + end_basic_block(); + ` .endp {emit_symbol f.fun_name}#\n` + +(* Emission of data *) + +let emit_global_symbol s = + ` .global {emit_symbol s}#\n`; + ` .type {emit_symbol s}#, @object\n`; + ` .size {emit_symbol s}#, 8\n` + +let emit_define_symbol s = + emit_global_symbol s; + `{emit_symbol s}:\n` + +let emit_item = function + Cglobal_symbol s -> + emit_global_symbol s + | Cdefine_symbol s -> + `{emit_symbol s}:\n` + | Cdefine_label lbl -> + `{emit_label (100000 + lbl)}:\n` + | Cint8 n -> + ` data1 {emit_int n}\n` + | Cint16 n -> + ` data2 {emit_int n}\n` + | Cint32 n -> + let n' = Nativeint.shift_right (Nativeint.shift_left n 32) 32 in + ` data4 {emit_nativeint n'}\n` + | Cint n -> + ` data8 {emit_nativeint n}\n` + | Csingle f -> + ` real4 {emit_string f}\n` + | Cdouble f -> + ` real8 {emit_string f}\n` + | Csymbol_address s -> + ` data8 {emit_symbol s}#\n` + | Clabel_address lbl -> + ` data8 {emit_label (100000 + lbl)}\n` + | Cstring s -> + emit_string_directive " string " s + | Cskip n -> + if n > 0 then ` .skip {emit_int n}\n` + | Calign n -> + ` .align {emit_int n}\n` + +let data l = + ` .data\n`; + ` .align 8\n`; + List.iter emit_item l + +(* Beginning / end of an assembly file *) + +let begin_assembly() = + ` .data\n`; + emit_define_symbol (Compilenv.current_unit_name() ^ "__data_begin"); + ` .text\n`; + emit_define_symbol (Compilenv.current_unit_name() ^ "__code_begin") + +let end_assembly () = + ` .data\n`; + emit_define_symbol (Compilenv.current_unit_name() ^ "__data_end"); + ` .text\n`; + emit_define_symbol (Compilenv.current_unit_name() ^ "__code_end"); + ` .rodata\n`; + ` .align 8\n`; + emit_define_symbol (Compilenv.current_unit_name() ^ "__frametable"); + ` data8 {emit_int (List.length !frame_descriptors)}\n`; + List.iter emit_frame !frame_descriptors; + frame_descriptors := [] diff --git a/asmcomp/ia64/proc.ml b/asmcomp/ia64/proc.ml new file mode 100644 index 00000000..6c0738c2 --- /dev/null +++ b/asmcomp/ia64/proc.ml @@ -0,0 +1,216 @@ +(***********************************************************************) +(* *) +(* 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 Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: proc.ml,v 1.5 2002/07/22 16:37:52 doligez Exp $ *) + +(* Description of the IA64 processor *) + +open Misc +open Cmm +open Reg +open Arch +open Mach + +(* Instruction selection *) + +let word_addressed = false + +(* Registers available for register allocation *) + +(* Register map: + r0 always 0 + r1 global pointer (gp) + r2 - r3 temporaries (for the code generator) + r4 allocation pointer + r5 allocation limit + r6 trap pointer + r7 saved gp during C calls (preserved by C) + r8 - r11 0 - 3 function results + r12 stack pointer + r13 reserved by C (thread-specific data) + r14 - r15 80 - 81 temporaries (for accessing stack variables) + r16 - r31 4 - 19 general purpose + r32 - r63 20 - 51 function arguments + r64 - r91 52 - 79 general purpose + r92 - r95 used by C glue code + + We do not use register windows, but instead allocate 64 "out" registers + (r32-r95) when entering Caml code. + + f0 always 0.0 + f1 always 1.0 + f2 - f5 100 - 103 general purpose (preserved by C) + f6 - f7 104 - 105 general purpose + f8 - f15 106 - 113 function results + f16 - f31 114 - 129 function arguments (preserved by C) + f32 - f63 130 - 161 general purpose + f64 - f66 temporaries + f67 - f127 unused +*) + +let int_reg_name = [| + (* 0-3 *) "r8"; "r9"; "r10"; "r11"; + (* 4-19 *) "r16"; "r17"; "r18"; "r19"; "r20"; "r21"; "r22"; "r23"; + "r24"; "r25"; "r26"; "r27"; "r28"; "r29"; "r30"; "r31"; + (* 20-51 *) "r32"; "r33"; "r34"; "r35"; "r36"; "r37"; "r38"; "r39"; + "r40"; "r41"; "r42"; "r43"; "r44"; "r45"; "r46"; "r47"; + "r48"; "r49"; "r50"; "r51"; "r52"; "r53"; "r54"; "r55"; + "r56"; "r57"; "r58"; "r59"; "r60"; "r61"; "r62"; "r63"; + (* 52-79 *) "r64"; "r65"; "r66"; "r67"; "r68"; "r69"; "r70"; "r71"; + "r72"; "r73"; "r74"; "r75"; "r76"; "r77"; "r78"; "r79"; + "r80"; "r81"; "r82"; "r83"; "r84"; "r85"; "r86"; "r87"; + "r88"; "r89"; "r90"; "r91"; + (* 80-81 *) "r14"; "r15" +|] + +let float_reg_name = [| + (* 0-13 *) "f2"; "f3"; "f4"; "f5"; "f6"; "f7"; + "f8"; "f9"; "f10"; "f11"; "f12"; "f13"; "f14"; "f15"; + (* 14-29 *) "f16"; "f17"; "f18"; "f19"; "f20"; "f21"; "f22"; "f23"; + "f24"; "f25"; "f26"; "f27"; "f28"; "f29"; "f30"; "f31"; + (* 30-61 *) "f32"; "f33"; "f34"; "f35"; "f36"; "f37"; "f38"; "f39"; + "f40"; "f41"; "f42"; "f43"; "f44"; "f45"; "f46"; "f47"; + "f48"; "f49"; "f50"; "f51"; "f52"; "f53"; "f54"; "f55"; + "f56"; "f57"; "f58"; "f59"; "f60"; "f61"; "f62"; "f63" +|] + +let num_register_classes = 2 + +let register_class r = + match r.typ with + Int -> 0 + | Addr -> 0 + | Float -> 1 + +let num_available_registers = [| 80; 62 |] + +let first_available_register = [| 0; 100 |] + +let register_name r = + if r < 100 then int_reg_name.(r) else float_reg_name.(r - 100) + +let rotate_registers = true + +(* Representation of hard registers by pseudo-registers *) + +let hard_int_reg = + let v = Array.create 82 Reg.dummy in + for i = 0 to 81 do v.(i) <- Reg.at_location Int (Reg i) done; + v + +let hard_float_reg = + let v = Array.create 62 Reg.dummy in + for i = 0 to 61 do v.(i) <- Reg.at_location Float (Reg(100 + i)) done; + v + +let all_phys_regs = + Array.append hard_int_reg hard_float_reg + +let phys_reg n = + if n < 100 then hard_int_reg.(n) else hard_float_reg.(n - 100) + +let stack_slot slot ty = + Reg.at_location ty (Stack slot) + +(* Calling conventions *) + +let calling_conventions first_int last_int first_float last_float + lockstep make_stack arg = + let loc = Array.create (Array.length arg) Reg.dummy in + let int = ref first_int in + let float = ref first_float in + let ofs = ref 0 in + for i = 0 to Array.length arg - 1 do + match arg.(i).typ with + Int | Addr as ty -> + if !int <= last_int then begin + loc.(i) <- phys_reg !int; + incr int; + if lockstep then incr float + end else begin + loc.(i) <- stack_slot (make_stack !ofs) ty; + ofs := !ofs + size_int + end + | Float -> + if !float <= last_float then begin + loc.(i) <- phys_reg !float; + incr float; + if lockstep then incr int + end else begin + loc.(i) <- stack_slot (make_stack !ofs) Float; + ofs := !ofs + size_float + end + done; + (loc, Misc.align !ofs 16) (* Keep stack 16-aligned *) + +let incoming ofs = Incoming ofs +let outgoing ofs = Outgoing ofs +let not_supported ofs = fatal_error "Proc.loc_results: cannot call" + +let loc_arguments arg = + calling_conventions 20 51 114 129 false outgoing arg +let loc_parameters arg = + let (loc, ofs) = calling_conventions 20 51 114 129 false incoming arg in loc +let loc_results res = + let (loc, ofs) = calling_conventions 0 3 106 113 false not_supported res + in loc +(* Arguments in r32...r39, f8...f15 + Results in r8...r11, f8...f15 *) +let loc_external_arguments arg = + calling_conventions 20 27 106 113 true outgoing arg +let loc_external_results res = + let (loc, ofs) = calling_conventions 0 3 106 113 false not_supported res + in loc +let extcall_use_push = false + +let loc_exn_bucket = phys_reg 0 (* r8 *) + +(* Registers destroyed by operations *) + +let destroyed_at_c_call = (* f2...f5, f16...f31 preserved by C *) + Array.append + hard_int_reg + (Array.of_list(List.map phys_reg + [100;101;102;103;104;105;106;107;108;109;110;111;112;113; + 130;131;132;133;134;135;136;137;138;139; + 140;141;142;143;144;145;146;147;148;149; + 150;151;152;153;154;155;156;157;158;159; + 160;161])) + +let destroyed_at_oper = function + Iop(Icall_ind | Icall_imm _ | Iextcall(_, true)) -> all_phys_regs + | Iop(Iextcall(_, false)) -> destroyed_at_c_call + | _ -> [||] + +let destroyed_at_raise = all_phys_regs + +(* Maximal register pressure *) + +let safe_register_pressure = function + Iextcall(_, _) -> 0 + | _ -> 62 +let max_register_pressure = function + Iextcall(_, _) -> [| 0; 20 |] + | _ -> num_available_registers + +(* Layout of the stack *) + +let num_stack_slots = [| 0; 0 |] +let contains_calls = ref false + +(* Calling the assembler *) + +let assemble_file infile outfile = + Ccomp.command ("as -xexplicit -o " ^ Filename.quote outfile ^ " " ^ Filename.quote infile) + +open Clflags;; +open Config;; diff --git a/asmcomp/ia64/reload.ml b/asmcomp/ia64/reload.ml new file mode 100644 index 00000000..ca16e672 --- /dev/null +++ b/asmcomp/ia64/reload.ml @@ -0,0 +1,18 @@ +(***********************************************************************) +(* *) +(* 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 Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: reload.ml,v 1.2 2000/07/16 02:57:31 xleroy Exp $ *) + +(* Reloading for the IA64. *) + +let fundecl f = + (new Reloadgen.reload_generic)#fundecl f diff --git a/asmcomp/ia64/scheduling.ml b/asmcomp/ia64/scheduling.ml new file mode 100644 index 00000000..9139c971 --- /dev/null +++ b/asmcomp/ia64/scheduling.ml @@ -0,0 +1,20 @@ +(***********************************************************************) +(* *) +(* 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 Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: scheduling.ml,v 1.3 2000/07/16 02:57:31 xleroy Exp $ *) + +open Schedgen (* to create a dependency *) + +(* We don't schedule here on the linearized code, but instead schedule the + assembly code generated in Emit. *) + +let fundecl f = f diff --git a/asmcomp/ia64/selection.ml b/asmcomp/ia64/selection.ml new file mode 100644 index 00000000..2f18382f --- /dev/null +++ b/asmcomp/ia64/selection.ml @@ -0,0 +1,175 @@ +(***********************************************************************) +(* *) +(* 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 Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: selection.ml,v 1.5 2000/07/16 02:57:31 xleroy Exp $ *) + +(* Instruction selection for the IA64 processor *) + +open Misc +open Cmm +open Reg +open Arch +open Mach + +(* Helper function for add selection *) + +let reassociate_add = function + [Cconst_int n; arg] -> + [arg; Cconst_int n] + | [Cop(Caddi, [arg1; Cconst_int n]); arg3] -> + [Cop(Caddi, [arg1; arg3]); Cconst_int n] + | [Cop(Caddi, [Cconst_int n; arg1]); arg3] -> + [Cop(Caddi, [arg1; arg3]); Cconst_int n] + | [arg1; Cop(Caddi, [Cconst_int n; arg3])] -> + [Cop(Caddi, [arg1; arg3]); Cconst_int n] + | [arg1; Cop(Caddi, [arg2; arg3])] -> + [Cop(Caddi, [arg1; arg2]); arg3] + | args -> args + +(* Helper function for mult-immediate selection *) + +let rec count_one_bits n = + if n = 0 then 0 + else if n land 1 = 0 then count_one_bits (n lsr 1) + else 1 + count_one_bits (n lsr 1) + +class selector = object (self) + +inherit Selectgen.selector_generic as super + +(* Range of immediate arguments: + add 14-bit signed + sub turned into add + sub reversed 8-bit signed + mul at most 16 "one" bits + div, mod powers of 2 + and, or, xor 8-bit signed + lsl, lsr, asr 6-bit unsigned + cmp 8-bit signed + For is_immediate, we put 8-bit signed and treat adds specially + (selectgen already does the right thing for shifts) *) + +method is_immediate n = n >= -128 && n < 128 + +method is_immediate_add n = n >= -8192 && n < 8192 + +method select_addressing arg = (Iindexed, arg) + +method select_operation op args = + let norm_op = + match op with Cadda -> Caddi | Csuba -> Csubi | _ -> op in + let norm_args = + match norm_op with Caddi -> reassociate_add args | _ -> args in + match (norm_op, norm_args) with + (* Recognize x + y + 1 and x - y - 1 *) + | (Caddi, [Cop(Caddi, [arg1; arg2]); Cconst_int 1]) -> + (Ispecific Iadd1, [arg1; arg2]) + | (Caddi, [Cop(Clsl, [arg1; Cconst_int 1]); Cconst_int 1]) -> + (Ispecific Iadd1, [arg1]) + | (Csubi, [Cop(Csubi, [arg1; arg2]); Cconst_int 1]) -> + (Ispecific Isub1, [arg1; arg2]) + | (Csubi, [Cop(Csubi, [arg1; Cconst_int 1]); arg2]) -> + (Ispecific Isub1, [arg1; arg2]) + (* Recognize add immediate *) + | (Caddi, [arg; Cconst_int n]) when self#is_immediate_add n -> + (Iintop_imm(Iadd, n), [arg]) + (* Turn sub immediate into add immediate *) + | (Csubi, [arg; Cconst_int n]) when self#is_immediate_add (-n) -> + (Iintop_imm(Iadd, -n), [arg]) + (* Recognize imm - arg *) + | (Csubi, [Cconst_int n; arg]) when self#is_immediate n -> + (Iintop_imm(Isub, n), [arg]) + (* Recognize shift-add operations *) + | (Caddi, [arg2; Cop(Clsl, [arg1; Cconst_int(1|2|3|4 as shift)])]) -> + (Ispecific(Ishladd shift), [arg1; arg2]) + | (Caddi, [Cop(Clsl, [arg1; Cconst_int(1|2|3|4 as shift)]); arg2]) -> + (Ispecific(Ishladd shift), [arg1; arg2]) + (* Recognize truncation/normalization of 64-bit integers to 32 bits *) + | (Casr, [Cop(Clsl, [arg; Cconst_int 32]); Cconst_int 32]) -> + (Ispecific (Isignextend 4), [arg]) + (* Recognize x * cst and cst * x *) + | (Cmuli, [arg; Cconst_int n]) -> + self#select_imul_imm arg n + | (Cmuli, [Cconst_int n; arg]) -> + self#select_imul_imm arg n + (* Prevent the recognition of (x / cst) and (x % cst) when cst is not + a power of 2, which do not correspond to an instruction. + Turn general division and modulus into calls to C library functions *) + | (Cdivi, [arg; Cconst_int n]) when n = 1 lsl (Misc.log2 n) -> + (Iintop_imm(Idiv, n), [arg]) + | (Cdivi, _) -> + (Iextcall("__divdi3", false), args) + | (Cmodi, [arg; Cconst_int n]) when n = 1 lsl (Misc.log2 n) -> + (Iintop_imm(Imod, n), [arg]) + | (Cmodi, _) -> + (Iextcall("__moddi3", false), args) + (* Recognize mult-add and mult-sub instructions *) + | (Caddf, [Cop(Cmulf, [arg1; arg2]); arg3]) -> + (Ispecific Imultaddf, [arg1; arg2; arg3]) + | (Caddf, [arg3; Cop(Cmulf, [arg1; arg2])]) -> + (Ispecific Imultaddf, [arg1; arg2; arg3]) + | (Csubf, [Cop(Cmulf, [arg1; arg2]); arg3]) -> + (Ispecific Imultsubf, [arg1; arg2; arg3]) + | (Csubf, [arg3; Cop(Cmulf, [arg1; arg2])]) -> + (Ispecific Isubmultf, [arg1; arg2; arg3]) + (* Use default selector otherwise *) + | _ -> + super#select_operation op args + +method private select_imul_imm arg n = + if count_one_bits n <= 16 + then (Iintop_imm(Imul, n), [arg]) + else (Iintop Imul, [arg; Cconst_int n]) + +(* To palliate the lack of addressing with displacement, multiple + stores to the address r are translated as follows + (t1 and t2 are two temp regs) + t1 := r - 8 + t2 := r + compute data1 in reg1 + compute data2 in reg2 + store reg1 at t1 and increment t1 by 16 + store reg2 at t2 and increment t2 by 16 + compute data3 in reg3 + compute data4 in reg4 + store reg3 at t1 and increment t1 by 16 + store reg4 at t2 and increment t2 by 16 + ... + Note: we use two temp regs and perform stores by groups of 2 + in order to expose more instruction-level parallelism. *) +method emit_stores env data regs_addr = + let t1 = Reg.create Addr and t2 = Reg.create Addr in + self#insert (Iop(Iintop_imm(Iadd, -8))) regs_addr [|t1|]; + self#insert (Iop Imove) regs_addr [|t2|]; + (* Store components by batch of 2 *) + let backlog = ref None in + let do_store r = + match !backlog with + None -> (* keep it for later *) + backlog := Some r + | Some r' -> (* store r' at t1 and r at t2 *) + self#insert (Iop(Ispecific(Istoreincr 16))) [| t1; r' |] [| t1 |]; + self#insert (Iop(Ispecific(Istoreincr 16))) [| t2; r |] [| t2 |]; + backlog := None in + List.iter + (fun exp -> Array.iter do_store (self#emit_expr env exp)) + data; + (* Store the backlog if any *) + begin match !backlog with + None -> () + | Some r -> self#insert (Iop(Ispecific(Istoreincr 16))) [| t1; r |] [| t1 |] + end; + (* Insert an init barrier *) + self#insert (Iop(Ispecific Iinitbarrier)) [||] [||] +end + +let fundecl f = (new selector)#emit_fundecl f diff --git a/asmcomp/interf.ml b/asmcomp/interf.ml new file mode 100644 index 00000000..2d84191b --- /dev/null +++ b/asmcomp/interf.ml @@ -0,0 +1,209 @@ +(***********************************************************************) +(* *) +(* 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: interf.ml,v 1.13 2001/09/11 15:30:38 xleroy Exp $ *) + +(* Construction of the interference graph. + Annotate pseudoregs with interference lists and preference lists. *) + +open Misc +open Reg +open Mach + +module BitMatrix = + struct + type bucket = Nil | Cons of int * int * bucket + type t = { + mutable tbl: bucket array; + mutable capacity: int; + mutable numelts: int + } + let create log2_sz = + let sz = 1 lsl log2_sz in + { tbl = Array.create sz Nil; capacity = 4 * sz; numelts = 0 } + + let resize mat = + let len = Array.length mat.tbl in + let newtbl = Array.make (len * 2) mat.tbl.(0) in + Array.blit mat.tbl 0 newtbl 0 len; + Array.blit mat.tbl 0 newtbl len len; + mat.tbl <- newtbl; + mat.capacity <- mat.capacity * 4 + + let rec find_in_bucket i j = function + Nil -> false + | Cons(x, y, rem) -> (x = i && y = j) || find_in_bucket i j rem + + let rec testandset mat i j = + if j > i then testandset mat j i else begin + let hash = (i lxor j) land (Array.length mat.tbl - 1) in + let bucket = mat.tbl.(hash) in + find_in_bucket i j bucket || + begin + mat.tbl.(hash) <- Cons(i, j, bucket); + mat.numelts <- mat.numelts + 1; + if mat.numelts >= mat.capacity then resize mat; + false + end + end + + let rec isset mat i j = + if j > i then + isset mat j i + else + find_in_bucket i j mat.tbl.((i lxor j) land (Array.length mat.tbl - 1)) + end + +let build_graph fundecl = + + (* The interference graph is represented in two ways: + - by adjacency lists for each register + - by a (triangular) bit matrix *) + + let mat = BitMatrix.create 6 in + + (* Record an interference between two registers *) + let add_interf ri rj = + let i = ri.stamp and j = rj.stamp in + if i = j || BitMatrix.testandset mat i j then () else begin + if ri.loc = Unknown then ri.interf <- rj :: ri.interf; + if rj.loc = Unknown then rj.interf <- ri :: rj.interf + end in + + (* Record interferences between a register array and a set of registers *) + let add_interf_set v s = + for i = 0 to Array.length v - 1 do + let r1 = v.(i) in + Reg.Set.iter (add_interf r1) s + done in + + (* Record interferences between elements of an array *) + let add_interf_self v = + for i = 0 to Array.length v - 2 do + let ri = v.(i) in + for j = i+1 to Array.length v - 1 do + add_interf ri v.(j) + done + done in + + (* Record interferences between the destination of a move and a set + of live registers. Since the destination is equal to the source, + do not add an interference between them if the source is still live + afterwards. *) + let add_interf_move src dst s = + Reg.Set.iter (fun r -> if r.stamp <> src.stamp then add_interf dst r) s in + + (* Compute interferences *) + + let rec interf i = + let destroyed = Proc.destroyed_at_oper i.desc in + if Array.length destroyed > 0 then add_interf_set destroyed i.live; + match i.desc with + Iend -> () + | Ireturn -> () + | Iop(Imove | Ispill | Ireload) -> + add_interf_move i.arg.(0) i.res.(0) i.live; + interf i.next + | Iop(Itailcall_ind) -> () + | Iop(Itailcall_imm lbl) -> () + | Iop op -> + add_interf_set i.res i.live; + add_interf_self i.res; + interf i.next + | Iifthenelse(tst, ifso, ifnot) -> + interf ifso; + interf ifnot; + interf i.next + | Iswitch(index, cases) -> + for i = 0 to Array.length cases - 1 do + interf cases.(i) + done; + interf i.next + | Iloop body -> + interf body; interf i.next + | Icatch(_, body, handler) -> + interf body; interf handler; interf i.next + | Iexit _ -> + () + | Itrywith(body, handler) -> + add_interf_set Proc.destroyed_at_raise handler.live; + interf body; interf handler; interf i.next + | Iraise -> () in + + (* Add a preference from one reg to another. + Do not add anything if the two registers conflict, + or if the source register already has a location. *) + + let add_pref weight r1 r2 = + if weight > 0 then begin + let i = r1.stamp and j = r2.stamp in + if i <> j + && r1.loc = Unknown + && not (BitMatrix.isset mat i j) + then r1.prefer <- (r2, weight) :: r1.prefer + end in + + (* Add a mutual preference between two regs *) + let add_mutual_pref weight r1 r2 = + add_pref weight r1 r2; add_pref weight r2 r1 in + + (* Update the spill cost of the registers involved in an operation *) + + let add_spill_cost cost arg = + for i = 0 to Array.length arg - 1 do + let r = arg.(i) in r.spill_cost <- r.spill_cost + cost + done in + + (* Compute preferences and spill costs *) + + let rec prefer weight i = + add_spill_cost weight i.arg; + add_spill_cost weight i.res; + match i.desc with + Iend -> () + | Ireturn -> () + | Iop(Imove) -> + add_mutual_pref weight i.arg.(0) i.res.(0); + prefer weight i.next + | Iop(Ispill) -> + add_pref (weight / 4) i.arg.(0) i.res.(0); + prefer weight i.next + | Iop(Ireload) -> + add_pref (weight / 4) i.res.(0) i.arg.(0); + prefer weight i.next + | Iop(Itailcall_ind) -> () + | Iop(Itailcall_imm lbl) -> () + | Iop op -> + prefer weight i.next + | Iifthenelse(tst, ifso, ifnot) -> + prefer (weight / 2) ifso; + prefer (weight / 2) ifnot; + prefer weight i.next + | Iswitch(index, cases) -> + for i = 0 to Array.length cases - 1 do + prefer (weight / 2) cases.(i) + done; + prefer weight i.next + | Iloop body -> + (* Avoid overflow of weight and spill_cost *) + prefer (if weight < 1000 then 8 * weight else weight) body; + prefer weight i.next + | Icatch(_, body, handler) -> + prefer weight body; prefer weight handler; prefer weight i.next + | Iexit _ -> + () + | Itrywith(body, handler) -> + prefer weight body; prefer weight handler; prefer weight i.next + | Iraise -> () + in + + interf fundecl.fun_body; prefer 8 fundecl.fun_body diff --git a/asmcomp/interf.mli b/asmcomp/interf.mli new file mode 100644 index 00000000..91e805e4 --- /dev/null +++ b/asmcomp/interf.mli @@ -0,0 +1,18 @@ +(***********************************************************************) +(* *) +(* 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: interf.mli,v 1.4 1999/11/17 18:56:33 xleroy Exp $ *) + +(* Construction of the interference graph. + Annotate pseudoregs with interference lists and preference lists. *) + +val build_graph: Mach.fundecl -> unit diff --git a/asmcomp/linearize.ml b/asmcomp/linearize.ml new file mode 100644 index 00000000..73d1bc6d --- /dev/null +++ b/asmcomp/linearize.ml @@ -0,0 +1,262 @@ +(***********************************************************************) +(* *) +(* 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: linearize.ml,v 1.24 2002/01/09 19:40:48 xleroy Exp $ *) + +(* Transformation of Mach code into a list of pseudo-instructions. *) + +open Reg +open Mach + +type label = int + +let label_counter = ref 99 + +let new_label() = incr label_counter; !label_counter + +type instruction = + { mutable desc: instruction_desc; + mutable next: instruction; + arg: Reg.t array; + res: Reg.t array; + live: Reg.Set.t } + +and instruction_desc = + Lend + | Lop of operation + | Lreloadretaddr + | Lreturn + | Llabel of label + | Lbranch of label + | Lcondbranch of test * label + | Lcondbranch3 of label option * label option * label option + | Lswitch of label array + | Lsetuptrap of label + | Lpushtrap + | Lpoptrap + | Lraise + +let has_fallthrough = function + | Lreturn | Lbranch _ | Lswitch _ | Lraise + | Lop Itailcall_ind | Lop (Itailcall_imm _) -> false + | _ -> true + +type fundecl = + { fun_name: string; + fun_body: instruction; + fun_fast: bool } + +(* Invert a test *) + +let invert_integer_test = function + Isigned cmp -> Isigned(Cmm.negate_comparison cmp) + | Iunsigned cmp -> Iunsigned(Cmm.negate_comparison cmp) + +let invert_test = function + Itruetest -> Ifalsetest + | Ifalsetest -> Itruetest + | Iinttest(cmp) -> Iinttest(invert_integer_test cmp) + | Iinttest_imm(cmp, n) -> Iinttest_imm(invert_integer_test cmp, n) + | Ifloattest(cmp, neg) -> Ifloattest(cmp, not neg) + | Ieventest -> Ioddtest + | Ioddtest -> Ieventest + +(* The "end" instruction *) + +let rec end_instr = + { desc = Lend; + next = end_instr; + arg = [||]; + res = [||]; + live = Reg.Set.empty } + +(* Cons an instruction (live empty) *) + +let instr_cons d a r n = + { desc = d; next = n; arg = a; res = r; live = Reg.Set.empty } + +(* Cons a simple instruction (arg, res, live empty) *) + +let cons_instr d n = + { desc = d; next = n; arg = [||]; res = [||]; live = Reg.Set.empty } + +(* Build an instruction with arg, res, live taken from + the given Mach.instruction *) + +let copy_instr d i n = + { desc = d; next = n; + arg = i.Mach.arg; res = i.Mach.res; live = i.Mach.live } + +(* + Label the beginning of the given instruction sequence. + - If the sequence starts with a branch, jump over it. + - If the sequence is the end, (tail call position), just do nothing +*) + +let get_label n = match n.desc with + Lbranch lbl -> (lbl, n) + | Llabel lbl -> (lbl, n) + | Lend -> (-1, n) + | _ -> let lbl = new_label() in (lbl, cons_instr (Llabel lbl) n) + +(* Check the fallthrough label *) +let check_label n = match n.desc with + | Lbranch lbl -> lbl + | Llabel lbl -> lbl + | _ -> -1 + +(* Discard all instructions up to the next label. + This function is to be called before adding a non-terminating + instruction. *) + +let rec discard_dead_code n = + match n.desc with + Lend -> n + | Llabel _ -> n +(* Do not discard Lpoptrap or Istackoffset instructions, + as this may cause a stack imbalance later during assembler generation. *) + | Lpoptrap -> n + | Lop(Istackoffset _) -> n + | _ -> discard_dead_code n.next + +(* + Add a branch in front of a continuation. + Discard dead code in the continuation. + Does not insert anything if we're just falling through + or if we jump to dead code after the end of function (lbl=-1) +*) + +let add_branch lbl n = + if lbl >= 0 then + let n1 = discard_dead_code n in + match n1.desc with + | Llabel lbl1 when lbl1 = lbl -> n1 + | _ -> cons_instr (Lbranch lbl) n1 + else + discard_dead_code n + +(* Current labels for exit handler *) + +let exit_label = ref [] + +let find_exit_label k = + try + List.assoc k !exit_label + with + | Not_found -> Misc.fatal_error "Linearize.find_exit_label" + +let is_next_catch n = match !exit_label with +| (n0,_)::_ when n0=n -> true +| _ -> false + +(* Linearize an instruction [i]: add it in front of the continuation [n] *) + +let rec linear i n = + match i.Mach.desc with + Iend -> n + | Iop(Itailcall_ind | Itailcall_imm _ as op) -> + copy_instr (Lop op) i (discard_dead_code n) + | Iop(Imove | Ireload | Ispill) + when i.Mach.arg.(0).loc = i.Mach.res.(0).loc -> + linear i.Mach.next n + | Iop op -> + copy_instr (Lop op) i (linear i.Mach.next n) + | Ireturn -> + let n1 = copy_instr Lreturn i (discard_dead_code n) in + if !Proc.contains_calls + then cons_instr Lreloadretaddr n1 + else n1 + | Iifthenelse(test, ifso, ifnot) -> + let n1 = linear i.Mach.next n in + begin match (ifso.Mach.desc, ifnot.Mach.desc, n1.desc) with + Iend, _, Lbranch lbl -> + copy_instr (Lcondbranch(test, lbl)) i (linear ifnot n1) + | _, Iend, Lbranch lbl -> + copy_instr (Lcondbranch(invert_test test, lbl)) i (linear ifso n1) + | Iexit nfail1, Iexit nfail2, _ + when is_next_catch nfail1 -> + let lbl2 = find_exit_label nfail2 in + copy_instr + (Lcondbranch (invert_test test, lbl2)) i (linear ifso n1) + | Iexit nfail, _, _ -> + let n2 = linear ifnot n1 + and lbl = find_exit_label nfail in + copy_instr (Lcondbranch(test, lbl)) i n2 + | _, Iexit nfail, _ -> + let n2 = linear ifso n1 in + let lbl = find_exit_label nfail in + copy_instr (Lcondbranch(invert_test test, lbl)) i n2 + | Iend, _, _ -> + let (lbl_end, n2) = get_label n1 in + copy_instr (Lcondbranch(test, lbl_end)) i (linear ifnot n2) + | _, Iend, _ -> + let (lbl_end, n2) = get_label n1 in + copy_instr (Lcondbranch(invert_test test, lbl_end)) i + (linear ifso n2) + | _, _, _ -> + (* Should attempt branch prediction here *) + let (lbl_end, n2) = get_label n1 in + let (lbl_else, nelse) = get_label (linear ifnot n2) in + copy_instr (Lcondbranch(invert_test test, lbl_else)) i + (linear ifso (add_branch lbl_end nelse)) + end + | Iswitch(index, cases) -> + let lbl_cases = Array.create (Array.length cases) 0 in + let (lbl_end, n1) = get_label(linear i.Mach.next n) in + let n2 = ref (discard_dead_code n1) in + for i = Array.length cases - 1 downto 0 do + let (lbl_case, ncase) = + get_label(linear cases.(i) (add_branch lbl_end !n2)) in + lbl_cases.(i) <- lbl_case; + n2 := discard_dead_code ncase + done; + (* Switches with 1 and 2 branches have been eliminated earlier. + Here, we do something for switches with 3 branches. *) + if Array.length index = 3 then begin + let fallthrough_lbl = check_label !n2 in + let find_label n = + let lbl = lbl_cases.(index.(n)) in + if lbl = fallthrough_lbl then None else Some lbl in + copy_instr (Lcondbranch3(find_label 0, find_label 1, find_label 2)) + i !n2 + end else + copy_instr (Lswitch(Array.map (fun n -> lbl_cases.(n)) index)) i !n2 + | Iloop body -> + let lbl_head = new_label() in + let n1 = linear i.Mach.next n in + let n2 = linear body (cons_instr (Lbranch lbl_head) n1) in + cons_instr (Llabel lbl_head) n2 + | Icatch(io, body, handler) -> + let (lbl_end, n1) = get_label(linear i.Mach.next n) in + let (lbl_handler, n2) = get_label(linear handler n1) in + exit_label := (io, lbl_handler) :: !exit_label ; + let n3 = linear body (add_branch lbl_end n2) in + exit_label := List.tl !exit_label; + n3 + | Iexit nfail -> + let n1 = linear i.Mach.next n in + let lbl = find_exit_label nfail in + add_branch lbl n1 + | Itrywith(body, handler) -> + let (lbl_join, n1) = get_label (linear i.Mach.next n) in + let (lbl_body, n2) = + get_label (cons_instr Lpushtrap + (linear body (cons_instr Lpoptrap n1))) in + cons_instr (Lsetuptrap lbl_body) + (linear handler (add_branch lbl_join n2)) + | Iraise -> + copy_instr Lraise i (discard_dead_code n) + +let fundecl f = + { fun_name = f.Mach.fun_name; + fun_body = linear f.Mach.fun_body end_instr; + fun_fast = f.Mach.fun_fast } diff --git a/asmcomp/linearize.mli b/asmcomp/linearize.mli new file mode 100644 index 00000000..8d7d20ce --- /dev/null +++ b/asmcomp/linearize.mli @@ -0,0 +1,54 @@ +(***********************************************************************) +(* *) +(* 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: linearize.mli,v 1.13 2002/01/09 19:40:48 xleroy Exp $ *) + +(* Transformation of Mach code into a list of pseudo-instructions. *) + +type label = int +val new_label: unit -> label + +type instruction = + { mutable desc: instruction_desc; + mutable next: instruction; + arg: Reg.t array; + res: Reg.t array; + live: Reg.Set.t } + +and instruction_desc = + Lend + | Lop of Mach.operation + | Lreloadretaddr + | Lreturn + | Llabel of label + | Lbranch of label + | Lcondbranch of Mach.test * label + | Lcondbranch3 of label option * label option * label option + | Lswitch of label array + | Lsetuptrap of label + | Lpushtrap + | Lpoptrap + | Lraise + +val has_fallthrough : instruction_desc -> bool +val end_instr: instruction +val instr_cons: + instruction_desc -> Reg.t array -> Reg.t array -> instruction -> instruction +val invert_test: Mach.test -> Mach.test + +type fundecl = + { fun_name: string; + fun_body: instruction; + fun_fast: bool } + +val fundecl: Mach.fundecl -> fundecl + diff --git a/asmcomp/liveness.ml b/asmcomp/liveness.ml new file mode 100644 index 00000000..f6bd37c1 --- /dev/null +++ b/asmcomp/liveness.ml @@ -0,0 +1,120 @@ +(***********************************************************************) +(* *) +(* 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: liveness.ml,v 1.14 2000/08/11 19:50:52 maranget Exp $ *) + +(* Liveness analysis. + Annotate mach code with the set of regs live at each point. *) + +open Mach + +let live_at_exit = ref [] +let find_live_at_exit k = + try + List.assoc k !live_at_exit + with + | Not_found -> Misc.fatal_error "Spill.find_live_at_exit" + +let live_at_break = ref Reg.Set.empty +let live_at_raise = ref Reg.Set.empty + +let rec live i finally = + (* finally is the set of registers live after execution of the + instruction sequence. + The result of the function is the set of registers live just + before the instruction sequence. + The instruction i is annotated by the set of registers live across + the instruction. *) + match i.desc with + Iend -> + i.live <- finally; + finally + | Ireturn | Iop(Itailcall_ind) | Iop(Itailcall_imm _) -> + (* i.live remains empty since no regs are live across *) + Reg.set_of_array i.arg + | Iifthenelse(test, ifso, ifnot) -> + let at_join = live i.next finally in + let at_fork = Reg.Set.union (live ifso at_join) (live ifnot at_join) in + i.live <- at_fork; + Reg.add_set_array at_fork i.arg + | Iswitch(index, cases) -> + let at_join = live i.next finally in + let at_fork = ref Reg.Set.empty in + for i = 0 to Array.length cases - 1 do + at_fork := Reg.Set.union !at_fork (live cases.(i) at_join) + done; + i.live <- !at_fork; + Reg.add_set_array !at_fork i.arg + | Iloop(body) -> + let at_top = ref Reg.Set.empty in + (* Yes, there are better algorithms, but we'll just iterate till + reaching a fixpoint. *) + begin try + while true do + let new_at_top = Reg.Set.union !at_top (live body !at_top) in + if Reg.Set.equal !at_top new_at_top then raise Exit; + at_top := new_at_top + done + with Exit -> () + end; + i.live <- !at_top; + !at_top + | Icatch(nfail, body, handler) -> + let at_join = live i.next finally in + let before_handler = live handler at_join in + let before_body = + live_at_exit := (nfail,before_handler) :: !live_at_exit ; + let before_body = live body at_join in + live_at_exit := List.tl !live_at_exit ; + before_body in + i.live <- before_body; + before_body + | Iexit nfail -> + let this_live = find_live_at_exit nfail in + i.live <- this_live ; + this_live + | Itrywith(body, handler) -> + let at_join = live i.next finally in + let before_handler = live handler at_join in + let saved_live_at_raise = !live_at_raise in + live_at_raise := Reg.Set.remove Proc.loc_exn_bucket before_handler; + let before_body = live body at_join in + live_at_raise := saved_live_at_raise; + i.live <- before_body; + before_body + | Iraise -> + (* i.live remains empty since no regs are live across *) + Reg.add_set_array !live_at_raise i.arg + | _ -> + let across_after = Reg.diff_set_array (live i.next finally) i.res in + let across = + match i.desc with + Iop(Icall_ind) | Iop(Icall_imm _) | Iop(Iextcall(_, _)) + | Iop(Iintop Icheckbound) | Iop(Iintop_imm(Icheckbound, _)) -> + (* The function call may raise an exception, branching to the + nearest enclosing try ... with. Similarly for bounds checks. + Hence, everything that must be live at the beginning of + the exception handler must also be live across this instr. *) + Reg.Set.union across_after !live_at_raise + | _ -> + across_after in + i.live <- across; + Reg.add_set_array across i.arg + +let fundecl ppf f = + let initially_live = live f.fun_body Reg.Set.empty in + (* Sanity check: only function parameters can be live at entrypoint *) + let wrong_live = Reg.Set.diff initially_live (Reg.set_of_array f.fun_args) in + if not (Reg.Set.is_empty wrong_live) then begin + Format.fprintf ppf "%a@." Printmach.regset wrong_live; + Misc.fatal_error "Liveness.fundecl" + end diff --git a/asmcomp/liveness.mli b/asmcomp/liveness.mli new file mode 100644 index 00000000..bd791e18 --- /dev/null +++ b/asmcomp/liveness.mli @@ -0,0 +1,20 @@ +(***********************************************************************) +(* *) +(* 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: liveness.mli,v 1.5 2000/04/21 08:10:33 weis Exp $ *) + +(* Liveness analysis. + Annotate mach code with the set of regs live at each point. *) + +open Format + +val fundecl: formatter -> Mach.fundecl -> unit diff --git a/asmcomp/m68k/README b/asmcomp/m68k/README new file mode 100644 index 00000000..fe5479d4 --- /dev/null +++ b/asmcomp/m68k/README @@ -0,0 +1,8 @@ +As of Feb 4th 2000, the native-code compiler for the Motorola 680x0 is +no longer maintained and thus deprecated. + +The only machines on which we could test this port (Sun 3, SunOS 4) +here at INRIA are being retired, and were so slow that the port wasn't +kept up-to-date with the remainder of the system. + +- Xavier Leroy, for the Objective Caml development team. diff --git a/asmcomp/mach.ml b/asmcomp/mach.ml new file mode 100644 index 00000000..70f64993 --- /dev/null +++ b/asmcomp/mach.ml @@ -0,0 +1,128 @@ +(***********************************************************************) +(* *) +(* 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: mach.ml,v 1.17 2000/08/11 19:50:52 maranget Exp $ *) + +(* Representation of machine code by sequences of pseudoinstructions *) + +type integer_comparison = + Isigned of Cmm.comparison + | Iunsigned of Cmm.comparison + +type integer_operation = + Iadd | Isub | Imul | Idiv | Imod + | Iand | Ior | Ixor | Ilsl | Ilsr | Iasr + | Icomp of integer_comparison + | Icheckbound + +type test = + Itruetest + | Ifalsetest + | Iinttest of integer_comparison + | Iinttest_imm of integer_comparison * int + | Ifloattest of Cmm.comparison * bool + | Ioddtest + | Ieventest + +type operation = + Imove + | Ispill + | Ireload + | Iconst_int of nativeint + | Iconst_float of string + | Iconst_symbol of string + | Icall_ind + | Icall_imm of string + | Itailcall_ind + | Itailcall_imm of string + | Iextcall of string * bool + | Istackoffset of int + | Iload of Cmm.memory_chunk * Arch.addressing_mode + | Istore of Cmm.memory_chunk * Arch.addressing_mode + | Ialloc of int + | Iintop of integer_operation + | Iintop_imm of integer_operation * int + | Inegf | Iabsf | Iaddf | Isubf | Imulf | Idivf + | Ifloatofint | Iintoffloat + | Ispecific of Arch.specific_operation + +type instruction = + { desc: instruction_desc; + next: instruction; + arg: Reg.t array; + res: Reg.t array; + mutable live: Reg.Set.t } + +and instruction_desc = + Iend + | Iop of operation + | Ireturn + | Iifthenelse of test * instruction * instruction + | Iswitch of int array * instruction array + | Iloop of instruction + | Icatch of int * instruction * instruction + | Iexit of int + | Itrywith of instruction * instruction + | Iraise + +type fundecl = + { fun_name: string; + fun_args: Reg.t array; + fun_body: instruction; + fun_fast: bool } + +let rec dummy_instr = + { desc = Iend; + next = dummy_instr; + arg = [||]; + res = [||]; + live = Reg.Set.empty } + +let end_instr () = + { desc = Iend; + next = dummy_instr; + arg = [||]; + res = [||]; + live = Reg.Set.empty } + +let instr_cons d a r n = + { desc = d; next = n; arg = a; res = r; live = Reg.Set.empty } + +let instr_cons_live d a r l n = + { desc = d; next = n; arg = a; res = r; live = l } + +let rec instr_iter f i = + match i.desc with + Iend -> () + | _ -> + f i; + match i.desc with + Iend -> () + | Ireturn | Iop(Itailcall_ind) | Iop(Itailcall_imm _) -> () + | Iifthenelse(tst, ifso, ifnot) -> + instr_iter f ifso; instr_iter f ifnot; instr_iter f i.next + | Iswitch(index, cases) -> + for i = 0 to Array.length cases - 1 do + instr_iter f cases.(i) + done; + instr_iter f i.next + | Iloop(body) -> + instr_iter f body; instr_iter f i.next + | Icatch(_, body, handler) -> + instr_iter f body; instr_iter f handler; instr_iter f i.next + | Iexit _ -> () + | Itrywith(body, handler) -> + instr_iter f body; instr_iter f handler; instr_iter f i.next + | Iraise -> () + | _ -> + instr_iter f i.next + diff --git a/asmcomp/mach.mli b/asmcomp/mach.mli new file mode 100644 index 00000000..ee1a3412 --- /dev/null +++ b/asmcomp/mach.mli @@ -0,0 +1,92 @@ +(***********************************************************************) +(* *) +(* 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: mach.mli,v 1.17 2000/08/11 19:50:53 maranget Exp $ *) + +(* Representation of machine code by sequences of pseudoinstructions *) + +type integer_comparison = + Isigned of Cmm.comparison + | Iunsigned of Cmm.comparison + +type integer_operation = + Iadd | Isub | Imul | Idiv | Imod + | Iand | Ior | Ixor | Ilsl | Ilsr | Iasr + | Icomp of integer_comparison + | Icheckbound + +type test = + Itruetest + | Ifalsetest + | Iinttest of integer_comparison + | Iinttest_imm of integer_comparison * int + | Ifloattest of Cmm.comparison * bool + | Ioddtest + | Ieventest + +type operation = + Imove + | Ispill + | Ireload + | Iconst_int of nativeint + | Iconst_float of string + | Iconst_symbol of string + | Icall_ind + | Icall_imm of string + | Itailcall_ind + | Itailcall_imm of string + | Iextcall of string * bool + | Istackoffset of int + | Iload of Cmm.memory_chunk * Arch.addressing_mode + | Istore of Cmm.memory_chunk * Arch.addressing_mode + | Ialloc of int + | Iintop of integer_operation + | Iintop_imm of integer_operation * int + | Inegf | Iabsf | Iaddf | Isubf | Imulf | Idivf + | Ifloatofint | Iintoffloat + | Ispecific of Arch.specific_operation + +type instruction = + { desc: instruction_desc; + next: instruction; + arg: Reg.t array; + res: Reg.t array; + mutable live: Reg.Set.t } + +and instruction_desc = + Iend + | Iop of operation + | Ireturn + | Iifthenelse of test * instruction * instruction + | Iswitch of int array * instruction array + | Iloop of instruction + | Icatch of int * instruction * instruction + | Iexit of int + | Itrywith of instruction * instruction + | Iraise + +type fundecl = + { fun_name: string; + fun_args: Reg.t array; + fun_body: instruction; + fun_fast: bool } + +val dummy_instr: instruction +val end_instr: unit -> instruction +val instr_cons: + instruction_desc -> Reg.t array -> Reg.t array -> instruction -> + instruction +val instr_cons_live: + instruction_desc -> Reg.t array -> Reg.t array -> Reg.Set.t -> + instruction -> instruction +val instr_iter: (instruction -> unit) -> instruction -> unit + diff --git a/asmcomp/mips/arch.ml b/asmcomp/mips/arch.ml new file mode 100644 index 00000000..8027e36c --- /dev/null +++ b/asmcomp/mips/arch.ml @@ -0,0 +1,71 @@ +(***********************************************************************) +(* *) +(* 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: arch.ml,v 1.6 2002/11/29 15:03:36 xleroy Exp $ *) + +(* Specific operations for the Mips processor *) + +open Misc +open Format + +(* Machine-specific command-line options *) + +let command_line_options = [] + +(* Addressing modes *) + +type addressing_mode = + Ibased of string * int (* symbol + displ *) + | Iindexed of int (* reg + displ *) + +(* Specific operations *) + +type specific_operation = unit (* none *) + +(* Sizes, endianness *) + +let big_endian = + match Config.system with + "ultrix" -> false + | "irix" -> true + | _ -> fatal_error "Arch_mips.big_endian" + +let size_addr = 4 +let size_int = 4 +let size_float = 8 + +(* Operations on addressing modes *) + +let identity_addressing = Iindexed 0 + +let offset_addressing addr delta = + match addr with + Ibased(s, n) -> Ibased(s, n + delta) + | Iindexed n -> Iindexed(n + delta) + +let num_args_addressing = function + Ibased(s, n) -> 0 + | Iindexed n -> 1 + +(* Printing operations and addressing modes *) + +let print_addressing printreg addr ppf arg = + match addr with + | Ibased(s, n) -> + let idx = if n <> 0 then Printf.sprintf " + %i" n else "" in + fprintf ppf "\"%s\"%s" s idx + | Iindexed n -> + let idx = if n <> 0 then Printf.sprintf " + %i" n else "" in + fprintf ppf "%a%s" printreg arg.(0) idx + +let print_specific_operation printreg op ppf arg = + fatal_error "Arch_mips.print_specific_operation" diff --git a/asmcomp/mips/emit.mlp b/asmcomp/mips/emit.mlp new file mode 100644 index 00000000..c967ad79 --- /dev/null +++ b/asmcomp/mips/emit.mlp @@ -0,0 +1,594 @@ +(***********************************************************************) +(* *) +(* 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: emit.mlp,v 1.16 2003/04/25 12:26:59 xleroy Exp $ *) + +(* Emission of Mips assembly code *) + +open Location +open Misc +open Cmm +open Arch +open Proc +open Reg +open Mach +open Linearize +open Emitaux + +(* Tradeoff between code size and code speed *) + +let fastcode_flag = ref true + +(* Output a label *) + +let emit_label lbl = + emit_string "$"; emit_int lbl + +(* Output a symbol *) + +let emit_symbol s = + Emitaux.emit_symbol '$' s + +(* Output a pseudo-register *) + +let emit_reg r = + match r.loc with + Reg r -> emit_string (register_name r) + | _ -> fatal_error "Emit_mips.emit_reg" + +(* Record if $gp is needed *) + +let uses_gp = ref false + +(* Layout of the stack frame *) + +let stack_offset = ref 0 + +let frame_size () = + let size = + !stack_offset + + 4 * num_stack_slots.(0) + 8 * num_stack_slots.(1) + + (if !contains_calls then if !uses_gp then 8 else 4 else 0) in + Misc.align size 16 + +let slot_offset loc cl = + match loc with + Incoming n -> frame_size() + n + | Local n -> + if cl = 0 + then !stack_offset + num_stack_slots.(1) * 8 + n * 4 + else !stack_offset + n * 8 + | Outgoing n -> n + +(* Output a stack reference *) + +let emit_stack r = + match r.loc with + Stack s -> + let ofs = slot_offset s (register_class r) in `{emit_int ofs}($sp)` + | _ -> fatal_error "Emit_mips.emit_stack" + +(* Output an addressing mode *) + +let emit_addressing addr r n = + match addr with + Iindexed ofs -> + `{emit_int ofs}({emit_reg r.(n)})` + | Ibased(s, 0) -> + `{emit_symbol s}` + | Ibased(s, ofs) -> + `{emit_symbol s}`; + if ofs > 0 then ` + {emit_int ofs}`; + if ofs < 0 then ` - {emit_int(-ofs)}` + +(* Communicate live registers at call points to the assembler *) + +let int_reg_number = + [| 2; 3; 4; 5; 6; 7; 8; 9; 10; 11; 12; 13; 14; 15; 16; 17; 18; 19; 20; 21 |] + +let float_reg_number = + [| 0; 1; 2; 3; 4; 5; 6; 7; 8; 9; 10; 11; 12; 13; 14; 15; 16; 17; 18; 19; + 20; 21; 22; 23; 24; 25; 26; 27; 28; 29; 30 |] + +let liveregs instr extra_msk = + (* $22, $23, $30 always live *) + let int_mask = ref(0x00000302 lor extra_msk) + and float_mask = ref 0 in + let add_register = function + {loc = Reg r; typ = (Int | Addr)} -> + int_mask := !int_mask lor (1 lsl (31 - int_reg_number.(r))) + | {loc = Reg r; typ = Float} -> + float_mask := !float_mask lor (1 lsl (31 - float_reg_number.(r - 100))) + | _ -> () in + Reg.Set.iter add_register instr.live; + Array.iter add_register instr.arg; + emit_printf " .livereg 0x%08x, 0x%08x\n" !int_mask !float_mask + +let live_25 = 1 lsl (31 - 25) +let live_24 = 1 lsl (31 - 24) + +(* Record live pointers at call points *) + +type frame_descr = + { fd_lbl: int; (* Return address *) + fd_frame_size: int; (* Size of stack frame *) + fd_live_offset: int list } (* Offsets/regs of live addresses *) + +let frame_descriptors = ref([] : frame_descr list) + +let record_frame live = + let lbl = new_label() in + let live_offset = ref [] in + Reg.Set.iter + (function + {typ = Addr; loc = Reg r} -> + live_offset := ((int_reg_number.(r) lsl 1) + 1) :: !live_offset + | {typ = Addr; loc = Stack s} as reg -> + live_offset := slot_offset s (register_class reg) :: !live_offset + | _ -> ()) + live; + frame_descriptors := + { fd_lbl = lbl; + fd_frame_size = frame_size(); + fd_live_offset = !live_offset } :: !frame_descriptors; + `{emit_label lbl}:` + +let emit_frame fd = + ` .word {emit_label fd.fd_lbl}\n`; + ` .half {emit_int fd.fd_frame_size}\n`; + ` .half {emit_int (List.length fd.fd_live_offset)}\n`; + List.iter + (fun n -> + ` .half {emit_int n}\n`) + fd.fd_live_offset; + ` .align 2\n` + +(* Determine if $gp is used in the function *) + +let rec instr_uses_gp i = + match i.desc with + Lend -> false + | Lop(Iconst_symbol s) -> true + | Lop(Icall_imm s) -> true + | Lop(Itailcall_imm s) -> true + | Lop(Iextcall(_, _)) -> true + | Lop(Iload(_, Ibased(_, _))) -> true + | Lop(Istore(_, Ibased(_, _))) -> true + | Lop(Ialloc _) -> true + | Lop(Iintop(Icheckbound)) -> true + | Lop(Iintop_imm(Icheckbound, _)) -> true + | Lswitch jumptbl -> true + | _ -> instr_uses_gp i.next + +(* Names of various instructions *) + +let name_for_comparison = function + Isigned Ceq -> "eq" | Isigned Cne -> "ne" | Isigned Cle -> "le" + | Isigned Cge -> "ge" | Isigned Clt -> "lt" | Isigned Cgt -> "gt" + | Iunsigned Ceq -> "eq" | Iunsigned Cne -> "ne" | Iunsigned Cle -> "leu" + | Iunsigned Cge -> "geu" | Iunsigned Clt -> "ltu" | Iunsigned Cgt -> "gtu" + +let name_for_float_comparison cmp neg = + match cmp with + Ceq -> ("eq", neg) | Cne -> ("eq", not neg) + | Cle -> ("le", neg) | Cge -> ("ult", not neg) + | Clt -> ("lt", neg) | Cgt -> ("ule", not neg) + +let name_for_int_operation = function + Iadd -> "addu" + | Isub -> "subu" + | Imul -> "mul" + | Idiv -> "div" + | Imod -> "rem" + | Iand -> "and" + | Ior -> "or" + | Ixor -> "xor" + | Ilsl -> "sll" + | Ilsr -> "srl" + | Iasr -> "sra" + | Icomp cmp -> "s" ^ name_for_comparison cmp + | _ -> Misc.fatal_error "Emit.name_for_int_operation" + +let name_for_float_operation = function + Inegf -> "neg.d" + | Iabsf -> "abs.d" + | Iaddf -> "add.d" + | Isubf -> "sub.d" + | Imulf -> "mul.d" + | Idivf -> "div.d" + | _ -> Misc.fatal_error "Emit.name_for_float_operation" + +(* Output the assembly code for an instruction *) + +(* Name of current function *) +let function_name = ref "" +(* Entry point for tail recursive calls *) +let tailrec_entry_point = ref 0 +(* Label of jump to caml_call_gc *) +let call_gc_label = ref 0 +(* Label of trap for out-of-range accesses *) +let range_check_trap = ref 0 + +let emit_instr i = + match i.desc with + Lend -> () + | Lop(Imove | Ispill | Ireload) -> + let src = i.arg.(0) and dst = i.res.(0) in + if src.loc <> dst.loc then begin + match (src, dst) with + {loc = Reg rs; typ = Int|Addr}, {loc = Reg rd; typ = Int|Addr} -> + ` move {emit_reg dst}, {emit_reg src}\n` + | {loc = Reg rs; typ = Float}, {loc = Reg rd; typ = Float} -> + ` mov.d {emit_reg dst}, {emit_reg src}\n` + | {loc = Reg rs; typ = Int|Addr}, {loc = Stack sd} -> + ` sw {emit_reg src}, {emit_stack dst}\n` + | {loc = Reg rs; typ = Float}, {loc = Stack sd} -> + ` s.d {emit_reg src}, {emit_stack dst}\n` + | {loc = Stack ss; typ = Int|Addr}, {loc = Reg rd} -> + ` lw {emit_reg dst}, {emit_stack src}\n` + | {loc = Stack ss; typ = Float}, {loc = Reg rd} -> + ` l.d {emit_reg dst}, {emit_stack src}\n` + | _ -> + fatal_error "Emit_mips: Imove" + end + | Lop(Iconst_int n) -> + if n = 0n then + ` move {emit_reg i.res.(0)}, $0\n` + else + ` li {emit_reg i.res.(0)}, {emit_nativeint n}\n` + | Lop(Iconst_float s) -> + ` li.d {emit_reg i.res.(0)}, {emit_string s}\n` + | Lop(Iconst_symbol s) -> + ` la {emit_reg i.res.(0)}, {emit_symbol s}\n` + | Lop(Icall_ind) -> + ` move $25, {emit_reg i.arg.(0)}\n`; + liveregs i live_25; + ` jal {emit_reg i.arg.(0)}\n`; + `{record_frame i.live}\n` + | Lop(Icall_imm s) -> + liveregs i 0; + ` jal {emit_symbol s}\n`; + `{record_frame i.live}\n` + | Lop(Itailcall_ind) -> + let n = frame_size() in + if !contains_calls then + ` lw $31, {emit_int(n - 4)}($sp)\n`; + if !uses_gp then + ` lw $gp, {emit_int(n - 8)}($sp)\n`; + if n > 0 then + ` addu $sp, $sp, {emit_int n}\n`; + liveregs i 0; + ` move $25, {emit_reg i.arg.(0)}\n`; + liveregs i live_25; + ` j {emit_reg i.arg.(0)}\n` + | Lop(Itailcall_imm s) -> + if s = !function_name then begin + ` b {emit_label !tailrec_entry_point}\n` + end else begin + let n = frame_size() in + if !contains_calls then + ` lw $31, {emit_int(n - 4)}($sp)\n`; + if !uses_gp then + ` lw $gp, {emit_int(n - 8)}($sp)\n`; + if n > 0 then + ` addu $sp, $sp, {emit_int n}\n`; + ` la $25, {emit_symbol s}\n`; + liveregs i live_25; + ` j $25\n` + end + | Lop(Iextcall(s, alloc)) -> + if alloc then begin + ` la $24, {emit_symbol s}\n`; + liveregs i live_24; + ` jal caml_c_call\n`; + `{record_frame i.live}\n` + end else begin + ` jal {emit_symbol s}\n` + end + | Lop(Istackoffset n) -> + if n >= 0 then + ` subu $sp, $sp, {emit_int n}\n` + else + ` addu $sp, $sp, {emit_int (-n)}\n`; + stack_offset := !stack_offset + n + | Lop(Iload(chunk, addr)) -> + let dest = i.res.(0) in + begin match chunk with + Double_u -> + (* Destination is not 8-aligned, hence cannot use l.d *) + ` ldl $24, {emit_addressing addr i.arg 0}\n`; + ` ldr $24, {emit_addressing (offset_addressing addr 7) i.arg 0}\n`; + ` dmtc1 $24, {emit_reg dest}\n` + | Single -> + ` l.s {emit_reg dest}, {emit_addressing addr i.arg 0}\n`; + ` cvt.d.s {emit_reg dest}, {emit_reg dest}\n` + | _ -> + let load_instr = + match chunk with + Byte_unsigned -> "lbu" + | Byte_signed -> "lb" + | Sixteen_unsigned -> "lhu" + | Sixteen_signed -> "lh" + | Double -> "l.d" + | _ -> "lw" in + ` {emit_string load_instr} {emit_reg dest}, {emit_addressing addr i.arg 0}\n` + end + | Lop(Istore(chunk, addr)) -> + let src = i.arg.(0) in + begin match chunk with + Double_u -> + (* Destination is not 8-aligned, hence cannot use l.d *) + ` dmfc1 $24, {emit_reg src}\n`; + ` sdl $24, {emit_addressing addr i.arg 1}\n`; + ` sdr $24, {emit_addressing (offset_addressing addr 7) i.arg 1}\n` + | Single -> + ` cvt.s.d $f31, {emit_reg src}\n`; + ` s.s $f31, {emit_addressing addr i.arg 1}\n` + | _ -> + let store_instr = + match chunk with + Byte_unsigned | Byte_signed -> "sb" + | Sixteen_unsigned | Sixteen_signed -> "sh" + | Double -> "s.d" + | _ -> "sw" in + ` {emit_string store_instr} {emit_reg src}, {emit_addressing addr i.arg 1}\n` + end + | Lop(Ialloc n) -> + if !call_gc_label = 0 then call_gc_label := new_label(); + ` .set noreorder\n`; + ` subu $22, $22, {emit_int n}\n`; + ` subu $24, $22, $23\n`; + ` bltzal $24, {emit_label !call_gc_label}\n`; + ` addu {emit_reg i.res.(0)}, $22, 4\n`; + `{record_frame i.live}\n`; + ` .set reorder\n` + | Lop(Iintop(Icheckbound)) -> + if !range_check_trap = 0 then range_check_trap := new_label(); + ` bleu {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_label !range_check_trap}\n` + | Lop(Iintop op) -> + let instr = name_for_int_operation op in + ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n` + | Lop(Iintop_imm(Icheckbound, n)) -> + if !range_check_trap = 0 then range_check_trap := new_label(); + ` bleu {emit_reg i.arg.(0)}, {emit_int n}, {emit_label !range_check_trap}\n` + | Lop(Iintop_imm(op, n)) -> + let instr = name_for_int_operation op in + ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_int n}\n` + | Lop(Inegf | Iabsf as op) -> + let instr = name_for_float_operation op in + ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}\n` + | Lop(Iaddf | Isubf | Imulf | Idivf as op) -> + let instr = name_for_float_operation op in + ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n` + | Lop(Ifloatofint) -> + ` mtc1 {emit_reg i.arg.(0)}, {emit_reg i.res.(0)}\n`; + ` cvt.d.w {emit_reg i.res.(0)}, {emit_reg i.res.(0)}\n` + | Lop(Iintoffloat) -> + ` trunc.w.d $f31, {emit_reg i.arg.(0)}, $24\n`; + ` mfc1 {emit_reg i.res.(0)}, $f31\n` + | Lop(Ispecific sop) -> + fatal_error "Emit_mips: Ispecific" + | Lreloadretaddr -> + let n = frame_size() in + ` lw $31, {emit_int(n - 4)}($sp)\n`; + | Lreturn -> + let n = frame_size() in + if !uses_gp then + ` lw $gp, {emit_int(n - 8)}($sp)\n`; + if n > 0 then + ` addu $sp, $sp, {emit_int n}\n`; + liveregs i 0; + ` j $31\n` + | Llabel lbl -> + `{emit_label lbl}:\n` + | Lbranch lbl -> + ` b {emit_label lbl}\n` + | Lcondbranch(tst, lbl) -> + begin match tst with + Itruetest -> + ` bne {emit_reg i.arg.(0)}, $0, {emit_label lbl}\n` + | Ifalsetest -> + ` beq {emit_reg i.arg.(0)}, $0, {emit_label lbl}\n` + | Iinttest cmp -> + let comp = name_for_comparison cmp in + ` b{emit_string comp} {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_label lbl}\n` + | Iinttest_imm(cmp, n) -> + let comp = name_for_comparison cmp in + ` b{emit_string comp} {emit_reg i.arg.(0)}, {emit_int n}, {emit_label lbl}\n` + | Ifloattest(cmp, neg) -> + let (comp, branch) = name_for_float_comparison cmp neg in + ` c.{emit_string comp}.d {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; + if branch + then ` bc1f {emit_label lbl}\n` + else ` bc1t {emit_label lbl}\n` + | Ioddtest -> + ` and $24, {emit_reg i.arg.(0)}, 1\n`; + ` bne $24, $0, {emit_label lbl}\n` + | Ieventest -> + ` and $24, {emit_reg i.arg.(0)}, 1\n`; + ` beq $24, $0, {emit_label lbl}\n` + end + | Lcondbranch3(lbl0, lbl1, lbl2) -> + ` subu $24, {emit_reg i.arg.(0)}, 1\n`; + begin match lbl0 with + None -> () + | Some lbl -> ` beq {emit_reg i.arg.(0)}, $0, {emit_label lbl}\n` + end; + begin match lbl1 with + None -> () + | Some lbl -> ` beq $24, $0, {emit_label lbl}\n` + end; + begin match lbl2 with + None -> () + | Some lbl -> ` bgtz $24, {emit_label lbl}\n` + end + | Lswitch jumptbl -> + let lbl_jumptbl = new_label() in + ` sll $24, {emit_reg i.arg.(0)}, 2\n`; + ` lw $24, {emit_label lbl_jumptbl}($24)\n`; + liveregs i live_24; + ` j $24\n`; + ` .rdata\n`; + `{emit_label lbl_jumptbl}:\n`; + for i = 0 to Array.length jumptbl - 1 do + ` .word {emit_label jumptbl.(i)}\n` + done; + ` .text\n` + | Lsetuptrap lbl -> + ` subu $sp, $sp, 16\n`; + ` bal {emit_label lbl}\n` + | Lpushtrap -> + stack_offset := !stack_offset + 16; + ` sw $30, 0($sp)\n`; + ` sw $31, 4($sp)\n`; + ` sw $gp, 8($sp)\n`; + ` move $30, $sp\n` + | Lpoptrap -> + ` lw $30, 0($sp)\n`; + ` addu $sp, $sp, 16\n`; + stack_offset := !stack_offset - 16 + | Lraise -> + ` lw $25, 4($30)\n`; + ` move $sp, $30\n`; + ` lw $30, 0($sp)\n`; + ` lw $gp, 8($sp)\n`; + ` addu $sp, $sp, 16\n`; + liveregs i live_25; + ` jal $25\n` (* Keep retaddr in $31 for debugging *) + +let rec emit_all i = + match i.desc with Lend -> () | _ -> emit_instr i; emit_all i.next + +(* Emission of a function declaration *) + +let fundecl fundecl = + function_name := fundecl.fun_name; + fastcode_flag := fundecl.fun_fast; + uses_gp := instr_uses_gp fundecl.fun_body; + if !uses_gp then contains_calls := true; + tailrec_entry_point := new_label(); + stack_offset := 0; + call_gc_label := 0; + range_check_trap := 0; + ` .text\n`; + ` .align 2\n`; + ` .globl {emit_symbol fundecl.fun_name}\n`; + ` .ent {emit_symbol fundecl.fun_name}\n`; + `{emit_symbol fundecl.fun_name}:\n`; + let n = frame_size() in + if n > 0 then + ` subu $sp, $sp, {emit_int n}\n`; + if !contains_calls then + ` sw $31, {emit_int(n - 4)}($sp)\n`; + if !uses_gp then begin + ` sw $gp, {emit_int(n - 8)}($sp)\n`; + ` lui $24, %hi(%neg(%gp_rel({emit_symbol fundecl.fun_name})))\n`; + ` addiu $24, $24, %lo(%neg(%gp_rel({emit_symbol fundecl.fun_name})))\n`; + ` daddu $gp, $25, $24\n` + end; + `{emit_label !tailrec_entry_point}:\n`; + emit_all fundecl.fun_body; + if !call_gc_label > 0 then begin + `{emit_label !call_gc_label}:\n`; + ` la $25, caml_call_gc\n`; + ` j $25\n` + end; + if !range_check_trap > 0 then begin + `{emit_label !range_check_trap}:\n`; + ` la $25, caml_array_bound_error\n`; + ` j $25\n` + end; + ` .end {emit_symbol fundecl.fun_name}\n` + +(* Emission of data *) + +let emit_item = function + Cglobal_symbol s -> + ` .globl {emit_symbol s}\n`; + | Cdefine_symbol s -> + `{emit_symbol s}:\n` + | Cdefine_label lbl -> + `{emit_label (100000 + lbl)}:\n` + | Cint8 n -> + ` .byte {emit_int n}\n` + | Cint16 n -> + ` .half {emit_int n}\n` + | Cint32 n -> + ` .word {emit_nativeint n}\n` + | Cint n -> + ` .word {emit_nativeint n}\n` + | Csingle f -> + ` .float {emit_string f}\n` + | Cdouble f -> + ` .align 0\n`; (* Prevent alignment on 8-byte boundary *) + ` .double {emit_string f}\n` + | Csymbol_address s -> + ` .word {emit_symbol s}\n` + | Clabel_address lbl -> + ` .word {emit_label (100000 + lbl)}\n` + | Cstring s -> + emit_string_directive " .ascii " s + | Cskip n -> + if n > 0 then ` .space {emit_int n}\n` + | Calign n -> + ` .align {emit_int(Misc.log2 n)}\n` + +let data l = + ` .data\n`; + List.iter emit_item l + +(* Beginning / end of an assembly file *) + +let begin_assembly() = + (* There are really two groups of registers: + $sp and $30 always point to stack locations + $2 - $21 never point to stack locations. *) + ` .noalias $2,$sp; .noalias $2,$30; .noalias $3,$sp; .noalias $3,$30\n`; + ` .noalias $4,$sp; .noalias $4,$30; .noalias $5,$sp; .noalias $5,$30\n`; + ` .noalias $6,$sp; .noalias $6,$30; .noalias $7,$sp; .noalias $7,$30\n`; + ` .noalias $8,$sp; .noalias $8,$30; .noalias $9,$sp; .noalias $9,$30\n`; + ` .noalias $10,$sp; .noalias $10,$30; .noalias $11,$sp; .noalias $11,$30\n`; + ` .noalias $12,$sp; .noalias $12,$30; .noalias $13,$sp; .noalias $13,$30\n`; + ` .noalias $14,$sp; .noalias $14,$30; .noalias $15,$sp; .noalias $15,$30\n`; + ` .noalias $16,$sp; .noalias $16,$30; .noalias $17,$sp; .noalias $17,$30\n`; + ` .noalias $18,$sp; .noalias $18,$30; .noalias $19,$sp; .noalias $19,$30\n`; + ` .noalias $20,$sp; .noalias $20,$30; .noalias $21,$sp; .noalias $21,$30\n\n`; + let lbl_begin = Compilenv.current_unit_name() ^ "__data_begin" in + ` .data\n`; + ` .globl {emit_symbol lbl_begin}\n`; + `{emit_symbol lbl_begin}:\n`; + let lbl_begin = Compilenv.current_unit_name() ^ "__code_begin" in + ` .text\n`; + ` .globl {emit_symbol lbl_begin}\n`; + ` .ent {emit_symbol lbl_begin}\n`; + `{emit_symbol lbl_begin}:\n`; + ` .end {emit_symbol lbl_begin}\n` + +let end_assembly () = + let lbl_end = Compilenv.current_unit_name() ^ "__code_end" in + ` .text\n`; + ` .globl {emit_symbol lbl_end}\n`; + ` .ent {emit_symbol lbl_end}\n`; + `{emit_symbol lbl_end}:\n`; + ` .end {emit_symbol lbl_end}\n`; + let lbl_end = Compilenv.current_unit_name() ^ "__data_end" in + ` .data\n`; + ` .globl {emit_symbol lbl_end}\n`; + `{emit_symbol lbl_end}:\n`; + ` .word 0\n`; + let lbl = Compilenv.current_unit_name() ^ "__frametable" in + ` .rdata\n`; + ` .globl {emit_symbol lbl}\n`; + `{emit_symbol lbl}:\n`; + ` .word {emit_int (List.length !frame_descriptors)}\n`; + List.iter emit_frame !frame_descriptors; + frame_descriptors := [] diff --git a/asmcomp/mips/proc.ml b/asmcomp/mips/proc.ml new file mode 100644 index 00000000..16acfc99 --- /dev/null +++ b/asmcomp/mips/proc.ml @@ -0,0 +1,211 @@ +(***********************************************************************) +(* *) +(* 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: proc.ml,v 1.6 2002/07/22 16:37:52 doligez Exp $ *) + +(* Description of the Mips processor *) + +open Misc +open Cmm +open Reg +open Arch +open Mach + +(* Instruction selection *) + +let word_addressed = false + +(* Registers available for register allocation *) + +(* Register map: + $0 always 0 + $1 temporary for the assembler + $2 - $7 0 - 5 function results + $8 - $15 6 - 13 function arguments + $16 - $21 14 - 19 general purpose (preserved by C) + $22 allocation pointer (preserved by C) + $23 allocation limit (preserved by C) + $24 - $25 temporaries + $26 - $29 kernel regs, stack pointer, global pointer + $30 trap pointer (preserved by C) + $31 return address + + $f0 - $f3 100 - 103 function results + $f4 - $f11 104 - 111 general purpose + $f12 - $f19 112 - 119 function arguments + $f20 - $f30 120 - 130 general purpose (even numbered preserved by C) + $f31 temporary *) + +let int_reg_name = [| + (* 0-5 *) "$2"; "$3"; "$4"; "$5"; "$6"; "$7"; + (* 6-13 *) "$8"; "$9"; "$10"; "$11"; "$12"; "$13"; "$14"; "$15"; + (* 14-19 *) "$16"; "$17"; "$18"; "$19"; "$20"; "$21" +|] + +let float_reg_name = [| + "$f0"; "$f1"; "$f2"; "$f3"; "$f4"; + "$f5"; "$f6"; "$f7"; "$f8"; "$f9"; + "$f10"; "$f11"; "$f12"; "$f13"; "$f14"; + "$f15"; "$f16"; "$f17"; "$f18"; "$f19"; + "$f20"; "$f21"; "$f22"; "$f23"; "$f24"; + "$f25"; "$f26"; "$f27"; "$f28"; "$f29"; "$f30" +|] + +let num_register_classes = 2 + +let register_class r = + match r.typ with + Int -> 0 + | Addr -> 0 + | Float -> 1 + +let num_available_registers = [| 20; 31 |] + +let first_available_register = [| 0; 100 |] + +let register_name r = + if r < 100 then int_reg_name.(r) else float_reg_name.(r - 100) + +let rotate_registers = true + +(* Representation of hard registers by pseudo-registers *) + +let hard_int_reg = + let v = Array.create 20 Reg.dummy in + for i = 0 to 19 do v.(i) <- Reg.at_location Int (Reg i) done; + v + +let hard_float_reg = + let v = Array.create 31 Reg.dummy in + for i = 0 to 30 do v.(i) <- Reg.at_location Float (Reg(100 + i)) done; + v + +let all_phys_regs = + Array.append hard_int_reg hard_float_reg + +let phys_reg n = + if n < 100 then hard_int_reg.(n) else hard_float_reg.(n - 100) + +let stack_slot slot ty = + Reg.at_location ty (Stack slot) + +(* Calling conventions *) + +let calling_conventions first_int last_int first_float last_float + make_stack arg = + let loc = Array.create (Array.length arg) Reg.dummy in + let int = ref first_int in + let float = ref first_float in + let ofs = ref 0 in + for i = 0 to Array.length arg - 1 do + match arg.(i).typ with + Int | Addr as ty -> + if !int <= last_int then begin + loc.(i) <- phys_reg !int; + incr int + end else begin + loc.(i) <- stack_slot (make_stack !ofs) ty; + ofs := !ofs + size_int + end + | Float -> + if !float <= last_float then begin + loc.(i) <- phys_reg !float; + incr float + end else begin + loc.(i) <- stack_slot (make_stack !ofs) Float; + ofs := !ofs + size_float + end + done; + (loc, Misc.align !ofs 16) (* Keep stack 16-aligned *) + +let incoming ofs = Incoming ofs +let outgoing ofs = Outgoing ofs +let not_supported ofs = fatal_error "Proc.loc_results: cannot call" + +let loc_arguments arg = + calling_conventions 6 13 112 119 outgoing arg +let loc_parameters arg = + let (loc, ofs) = calling_conventions 6 13 112 119 incoming arg in loc +let loc_results res = + let (loc, ofs) = calling_conventions 0 5 100 103 not_supported res in loc + +(* The C calling conventions are as follows: + the first 8 arguments are passed either in integer regs $4...$11 + or float regs $f12...$f19. Each argument "consumes" both one slot + in the int register file and one slot in the float register file. + Extra arguments are passed on stack, in a 64-bits slot, right-justified + (i.e. at +4 from natural address). *) + +let loc_external_arguments arg = + let loc = Array.create (Array.length arg) Reg.dummy in + let int = ref 2 in + let float = ref 112 in + let ofs = ref 0 in + for i = 0 to Array.length arg - 1 do + if i < 8 then begin + loc.(i) <- phys_reg (if arg.(i).typ = Float then !float else !int); + incr int; + incr float + end else begin + begin match arg.(i).typ with + Float -> loc.(i) <- stack_slot (Outgoing !ofs) Float + | ty -> loc.(i) <- stack_slot (Outgoing (!ofs + 4)) ty + end; + ofs := !ofs + 8 + end + done; + (loc, Misc.align !ofs 16) + +let loc_external_results res = + let (loc, ofs) = calling_conventions 0 0 100 100 not_supported res in loc + +let loc_exn_bucket = phys_reg 0 (* $2 *) + +(* Registers destroyed by operations *) + +let destroyed_at_c_call = + (* $16 - $21, $f20, $f22, $f24, $f26, $f28, $f30 preserved *) + Array.of_list(List.map phys_reg + [0;1;2;3;4;5;6;7;8;9;10;11;12;13; + 100;101;102;103;104;105;106;107;108;109;110;111;112;113;114; + 115;116;117;118;119;121;123;125;127;129]) + +let destroyed_at_oper = function + Iop(Icall_ind | Icall_imm _ | Iextcall(_, true)) -> all_phys_regs + | Iop(Iextcall(_, false)) -> destroyed_at_c_call + | _ -> [||] + +let destroyed_at_raise = all_phys_regs + +(* Maximal register pressure *) + +let safe_register_pressure = function + Iextcall(_, _) -> 6 + | _ -> 20 +let max_register_pressure = function + Iextcall(_, _) -> [| 6; 6 |] + | _ -> [| 20; 31 |] + +(* Layout of the stack *) + +let num_stack_slots = [| 0; 0 |] +let contains_calls = ref false + +(* Calling the assembler *) + +let asm_command = "as -n32 -O2 -nocpp -g0 -o " + +let assemble_file infile outfile = + Ccomp.command (asm_command ^ Filename.quote outfile ^ " " ^ Filename.quote infile) + +open Clflags;; +open Config;; diff --git a/asmcomp/mips/reload.ml b/asmcomp/mips/reload.ml new file mode 100644 index 00000000..de72414c --- /dev/null +++ b/asmcomp/mips/reload.ml @@ -0,0 +1,18 @@ +(***********************************************************************) +(* *) +(* 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: reload.ml,v 1.3 1999/11/17 18:56:45 xleroy Exp $ *) + +(* Reloading for the Mips *) + +let fundecl f = + (new Reloadgen.reload_generic)#fundecl f diff --git a/asmcomp/mips/scheduling.ml b/asmcomp/mips/scheduling.ml new file mode 100644 index 00000000..7061cd39 --- /dev/null +++ b/asmcomp/mips/scheduling.ml @@ -0,0 +1,20 @@ +(***********************************************************************) +(* *) +(* 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: scheduling.ml,v 1.2 1999/11/17 18:56:45 xleroy Exp $ *) + +open Schedgen (* to create a dependency *) + +(* No scheduling is needed for the Mips, the assembler + does it better than us. *) + +let fundecl f = f diff --git a/asmcomp/mips/selection.ml b/asmcomp/mips/selection.ml new file mode 100644 index 00000000..690ef271 --- /dev/null +++ b/asmcomp/mips/selection.ml @@ -0,0 +1,43 @@ +(***********************************************************************) +(* *) +(* 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: selection.ml,v 1.4 1999/11/17 18:56:46 xleroy Exp $ *) + +(* Instruction selection for the Mips processor *) + +open Misc +open Cmm +open Reg +open Arch +open Mach + +class selector = object + +inherit Selectgen.selector_generic + +method is_immediate (n : int) = true + +method select_addressing = function + Cconst_symbol s -> + (Ibased(s, 0), Ctuple []) + | Cop(Cadda, [Cconst_symbol s; Cconst_int n]) -> + (Ibased(s, n), Ctuple []) + | Cop(Cadda, [arg; Cconst_int n]) -> + (Iindexed n, arg) + | Cop(Cadda, [arg1; Cop(Caddi, [arg2; Cconst_int n])]) -> + (Iindexed n, Cop(Cadda, [arg1; arg2])) + | arg -> + (Iindexed 0, arg) + +end + +let fundecl f = (new selector)#emit_fundecl f diff --git a/asmcomp/power/arch.ml b/asmcomp/power/arch.ml new file mode 100644 index 00000000..191fb3ce --- /dev/null +++ b/asmcomp/power/arch.ml @@ -0,0 +1,101 @@ +(***********************************************************************) +(* *) +(* 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: arch.ml,v 1.10 2003/07/17 15:11:02 xleroy Exp $ *) + +(* Specific operations for the PowerPC processor *) + +open Misc +open Format + +(* Machine-specific command-line options *) + +let command_line_options = [] + +(* Specific operations *) + +type specific_operation = + Imultaddf (* multiply and add *) + | Imultsubf (* multiply and subtract *) + | Ialloc_far of int (* allocation in large functions *) + +(* Addressing modes *) + +type addressing_mode = + Ibased of string * int (* symbol + displ *) + | Iindexed of int (* reg + displ *) + | Iindexed2 (* reg + reg *) + +(* Sizes, endianness *) + +let big_endian = true + +let size_addr = 4 +let size_int = 4 +let size_float = 8 + +(* Operations on addressing modes *) + +let identity_addressing = Iindexed 0 + +let offset_addressing addr delta = + match addr with + Ibased(s, n) -> Ibased(s, n + delta) + | Iindexed n -> Iindexed(n + delta) + | Iindexed2 -> Misc.fatal_error "Arch_power.offset_addressing" + +let num_args_addressing = function + Ibased(s, n) -> 0 + | Iindexed n -> 1 + | Iindexed2 -> 2 + +(* Printing operations and addressing modes *) + +let print_addressing printreg addr ppf arg = + match addr with + | Ibased(s, n) -> + let idx = if n <> 0 then Printf.sprintf " + %i" n else "" in + fprintf ppf "\"%s\"%s" s idx + | Iindexed n -> + let idx = if n <> 0 then Printf.sprintf " + %i" n else "" in + fprintf ppf "%a%s" printreg arg.(0) idx + | Iindexed2 -> + fprintf ppf "%a + %a" printreg arg.(0) printreg arg.(1) + +let print_specific_operation printreg op ppf arg = + match op with + | Imultaddf -> + fprintf ppf "%a *f %a +f %a" + printreg arg.(0) printreg arg.(1) printreg arg.(2) + | Imultsubf -> + fprintf ppf "%a *f %a -f %a" + printreg arg.(0) printreg arg.(1) printreg arg.(2) + | Ialloc_far n -> + fprintf ppf "alloc_far %d" n + +(* Distinguish between the PowerPC and the Power/RS6000 submodels *) + +let powerpc = + match Config.model with + | "ppc" -> true + | "rs6000" -> false + | _ -> Misc.fatal_error "wrong $(MODEL)" + +(* Distinguish between the PowerOpen (AIX, MacOS) TOC-based, + relative-addressing model and the SVR4 (Solaris, MkLinux, Rhapsody) + absolute-addressing model. *) + +let toc = + match Config.system with + | "aix" -> true + | "elf" | "rhapsody" | "bsd" -> false + | _ -> Misc.fatal_error "wrong $(SYSTEM)" diff --git a/asmcomp/power/emit.mlp b/asmcomp/power/emit.mlp new file mode 100644 index 00000000..1ec44002 --- /dev/null +++ b/asmcomp/power/emit.mlp @@ -0,0 +1,1099 @@ +(***********************************************************************) +(* *) +(* 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: emit.mlp,v 1.17 2003/07/17 15:11:02 xleroy Exp $ *) + +(* Emission of PowerPC assembly code *) + +module StringSet = Set.Make(struct type t = string let compare = compare end) + +open Location +open Misc +open Cmm +open Arch +open Proc +open Reg +open Mach +open Linearize +open Emitaux + +(* Layout of the stack *) + +(* In the TOC-based model: + The bottom 32 bytes of the stack are reserved at all times + for a standard linkage area. + In this area, the word at offset +20 is used by glue code and others to + save the TOC register. + The bottom two words are used as temporaries and for trap frames. + The stack is kept 16-aligned. + In the absolute-address model: + No reserved space at the bottom of the stack. + The stack is kept 16-aligned. *) + +let stack_linkage_area = if toc then 32 else 0 +let trap_frame_size = if toc then 32 else 16 + +let stack_offset = ref 0 + +let frame_size () = + let size = + stack_linkage_area + (* The bottom linkage area *) + !stack_offset + (* Trap frame, outgoing parameters *) + 4 * num_stack_slots.(0) + 8 * num_stack_slots.(1) + (* Local variables *) + (if !contains_calls then 4 else 0) in (* The return address *) + Misc.align size 16 + +let slot_offset loc cls = + match loc with + Local n -> + if cls = 0 + then stack_linkage_area + !stack_offset + num_stack_slots.(1) * 8 + n * 4 + else stack_linkage_area + !stack_offset + n * 8 + | Incoming n -> frame_size() + n + | Outgoing n -> n + +(* Output a symbol *) + +let emit_symbol = + match Config.system with + "aix" | "elf" | "bsd" -> (fun s -> Emitaux.emit_symbol '.' s) + | "rhapsody" -> (fun s -> emit_char '_'; Emitaux.emit_symbol '$' s) + | _ -> assert false + +let emit_codesymbol s = + if toc then emit_char '.'; + emit_symbol s + +(* Output a label *) + +let label_prefix = + match Config.system with + "aix" -> "L.." + | "elf" | "bsd" -> ".L" + | "rhapsody" -> "L" + | _ -> assert false + +let emit_label lbl = + emit_string label_prefix; emit_int lbl + +(* Section switching *) + +let data_space = + match Config.system with + "aix" -> " .csect .data[RW]\n" + | "elf" | "bsd" -> " .section \".data\"\n" + | "rhapsody" -> " .data\n" + | _ -> assert false + +let code_space = + match Config.system with + "aix" -> " .csect .text[PR]\n" + | "elf" | "bsd" -> " .section \".text\"\n" + | "rhapsody" -> " .text\n" + | _ -> assert false + +let rodata_space = + match Config.system with + "aix" -> " .csect .data[RW]\n" (* ?? *) + | "elf" | "bsd" -> " .section \".rodata\"\n" + | "rhapsody" -> " .const\n" + | _ -> assert false + +(* Output a pseudo-register *) + +let emit_reg r = + match r.loc with + Reg r -> emit_string (register_name r) + | _ -> fatal_error "Emit.emit_reg" + +let use_full_regnames = + Config.system = "rhapsody" + +let emit_gpr r = + if use_full_regnames then emit_char 'r'; + emit_int r + +let emit_fpr r = + if use_full_regnames then emit_char 'f'; + emit_int r + +let emit_ccr r = + if use_full_regnames then emit_string "cr"; + emit_int r + +(* Output a stack reference *) + +let emit_stack r = + match r.loc with + Stack s -> + let ofs = slot_offset s (register_class r) in `{emit_int ofs}({emit_gpr 1})` + | _ -> fatal_error "Emit.emit_stack" + +(* Split a 32-bit integer constants in two 16-bit halves *) + +let low n = n land 0xFFFF +let high n = n asr 16 + +let nativelow n = Nativeint.to_int n land 0xFFFF +let nativehigh n = Nativeint.to_int (Nativeint.shift_right n 16) + +let is_immediate n = + n <= 32767 && n >= -32768 + +let is_native_immediate n = + n <= Nativeint.of_int 32767 && n >= Nativeint.of_int (-32768) + +(* Output a "upper 16 bits" or "lower 16 bits" operator + (for the absolute addressing mode) *) + +let emit_upper emit_fun arg = + match Config.system with + "elf" | "bsd" -> + emit_fun arg; emit_string "@ha" + | "rhapsody" -> + emit_string "ha16("; emit_fun arg; emit_string ")" + | _ -> assert false + +let emit_lower emit_fun arg = + match Config.system with + "elf" | "bsd" -> + emit_fun arg; emit_string "@l" + | "rhapsody" -> + emit_string "lo16("; emit_fun arg; emit_string ")" + | _ -> assert false + +(* Output a load or store operation *) + +let emit_symbol_offset (s, d) = + emit_symbol s; + if d > 0 then `+`; + if d <> 0 then emit_int d + +let emit_load_store instr addressing_mode addr n arg = + match addressing_mode with + Ibased(s, d) -> + (* Only relevant in the absolute model *) + ` addis {emit_gpr 11}, 0, {emit_upper emit_symbol_offset (s,d)}\n`; + ` {emit_string instr} {emit_reg arg}, {emit_lower emit_symbol_offset (s,d)}({emit_gpr 11})\n` + | Iindexed ofs -> + if is_immediate ofs then + ` {emit_string instr} {emit_reg arg}, {emit_int ofs}({emit_reg addr.(n)})\n` + else begin + ` lis {emit_gpr 0}, {emit_int(high ofs)}\n`; + if low ofs <> 0 then + ` ori {emit_gpr 0}, {emit_gpr 0}, {emit_int(low ofs)}\n`; + ` {emit_string instr}x {emit_reg arg}, {emit_reg addr.(n)}, {emit_gpr 0}\n` + end + | Iindexed2 -> + ` {emit_string instr}x {emit_reg arg}, {emit_reg addr.(n)}, {emit_reg addr.(n+1)}\n` + +(* After a comparison, extract the result as 0 or 1 *) + +let emit_set_comp cmp res = + ` mfcr {emit_gpr 0}\n`; + let bitnum = + match cmp with + Ceq | Cne -> 2 + | Cgt | Cle -> 1 + | Clt | Cge -> 0 in +` rlwinm {emit_reg res}, {emit_gpr 0}, {emit_int(bitnum+1)}, 31, 31\n`; + begin match cmp with + Cne | Cle | Cge -> ` xori {emit_reg res}, {emit_reg res}, 1\n` + | _ -> () + end + +(* Record live pointers at call points *) + +type frame_descr = + { fd_lbl: int; (* Return address *) + fd_frame_size: int; (* Size of stack frame *) + fd_live_offset: int list } (* Offsets/regs of live addresses *) + +let frame_descriptors = ref([] : frame_descr list) + +let record_frame live = + let lbl = new_label() in + let live_offset = ref [] in + Reg.Set.iter + (function + {typ = Addr; loc = Reg r} -> + live_offset := (r lsl 1) + 1 :: !live_offset + | {typ = Addr; loc = Stack s} as reg -> + live_offset := slot_offset s (register_class reg) :: !live_offset + | _ -> ()) + live; + frame_descriptors := + { fd_lbl = lbl; + fd_frame_size = frame_size(); + fd_live_offset = !live_offset } :: !frame_descriptors; + `{emit_label lbl}:` + +let emit_frame fd = + ` .long {emit_label fd.fd_lbl} + 4\n`; + ` .short {emit_int fd.fd_frame_size}\n`; + ` .short {emit_int (List.length fd.fd_live_offset)}\n`; + List.iter + (fun n -> + ` .short {emit_int n}\n`) + fd.fd_live_offset; + ` .align 2\n` + +(* Record symbols and floating-point constants (for the TOC model). + These will go in the toc section. *) + +let label_constant table constant = + try + Hashtbl.find table constant + with Not_found -> + let lbl = new_label() in + Hashtbl.add table constant lbl; + lbl + +let symbol_constants = (Hashtbl.create 17 : (string, int) Hashtbl.t) +let float_constants = (Hashtbl.create 11 : (string, int) Hashtbl.t) + +let label_symbol s = label_constant symbol_constants s +let label_float s = label_constant float_constants s + +let emit_symbol_constant symb lbl = + `{emit_label lbl}: .tc {emit_symbol symb}[TC], {emit_symbol symb}\n` + +let emit_float_constant float lbl = + `{emit_label lbl}: .tc FD_`; + for i = 0 to 7 do + emit_printf "%02x" (Char.code (String.unsafe_get float i)) + done; + `[TC], 0x`; + for i = 0 to 3 do + emit_printf "%02x" (Char.code (String.unsafe_get float i)) + done; + `, 0x`; + for i = 4 to 7 do + emit_printf "%02x" (Char.code (String.unsafe_get float i)) + done; + `\n` + +(* Record floating-point literals (for the ELF model) *) + +let float_literals = ref ([] : (string * int) list) + +(* Record external C functions to be called in a position-independent way + (for Rhapsody) *) + +let pic_externals = (Config.system = "rhapsody") + +let external_functions = ref StringSet.empty + +let emit_external s = + ` .non_lazy_symbol_pointer\n`; + `L{emit_symbol s}$non_lazy_ptr:\n`; + ` .indirect_symbol {emit_symbol s}\n`; + ` .long 0\n` + +(* Names for conditional branches after comparisons *) + +let branch_for_comparison = function + Ceq -> "beq" | Cne -> "bne" + | Cle -> "ble" | Cgt -> "bgt" + | Cge -> "bge" | Clt -> "blt" + +let name_for_int_comparison = function + Isigned cmp -> ("cmpw", branch_for_comparison cmp) + | Iunsigned cmp -> ("cmplw", branch_for_comparison cmp) + +(* Names for various instructions *) + +let name_for_intop = function + Iadd -> "add" + | Imul -> "mullw" + | Idiv -> if powerpc then "divw" else "divs" + | Iand -> "and" + | Ior -> "or" + | Ixor -> "xor" + | Ilsl -> "slw" + | Ilsr -> "srw" + | Iasr -> "sraw" + | _ -> Misc.fatal_error "Emit.Intop" + +let name_for_intop_imm = function + Iadd -> "addi" + | Imul -> "mulli" + | Iand -> "andi." + | Ior -> "ori" + | Ixor -> "xori" + | Ilsl -> "slwi" + | Ilsr -> "srwi" + | Iasr -> "srawi" + | _ -> Misc.fatal_error "Emit.Intop_imm" + +let name_for_floatop1 = function + Inegf -> "fneg" + | Iabsf -> "fabs" + | _ -> Misc.fatal_error "Emit.Iopf1" + +let name_for_floatop2 = function + Iaddf -> "fadd" + | Isubf -> "fsub" + | Imulf -> "fmul" + | Idivf -> "fdiv" + | _ -> Misc.fatal_error "Emit.Iopf2" + +let name_for_specific = function + Imultaddf -> "fmadd" + | Imultsubf -> "fmsub" + | _ -> Misc.fatal_error "Emit.Ispecific" + +(* Name of current function *) +let function_name = ref "" +(* Entry point for tail recursive calls *) +let tailrec_entry_point = ref 0 +(* Names of functions defined in the current file *) +let defined_functions = ref StringSet.empty +(* Label of glue code for calling the GC *) +let call_gc_label = ref 0 +(* Label of jump table *) +let lbl_jumptbl = ref 0 +(* List of all labels in jumptable (reverse order) *) +let jumptbl_entries = ref [] +(* Number of jumptable entries *) +let num_jumptbl_entries = ref 0 + +(* Fixup conditional branches that exceed hardware allowed range *) + +let load_store_size = function + Ibased(s, d) -> 2 + | Iindexed ofs -> if is_immediate ofs then 1 else 3 + | Iindexed2 -> 1 + +let instr_size = function + Lend -> 0 + | Lop(Imove | Ispill | Ireload) -> 1 + | Lop(Iconst_int n) -> if is_native_immediate n then 1 else 2 + | Lop(Iconst_float s) -> if toc then 1 else 2 + | Lop(Iconst_symbol s) -> if toc then 1 else 2 + | Lop(Icall_ind) -> if toc then 6 else 2 + | Lop(Icall_imm s) -> + if toc && not (StringSet.mem s !defined_functions) then 2 else 1 + | Lop(Itailcall_ind) -> if toc then 7 else 5 + | Lop(Itailcall_imm s) -> + if s = !function_name then 1 + else if not toc || StringSet.mem s !defined_functions then 4 + else 8 + | Lop(Iextcall(s, true)) -> if toc then 2 else 3 + | Lop(Iextcall(s, false)) -> if pic_externals then 4 else 1 + | Lop(Istackoffset n) -> 1 + | Lop(Iload(chunk, addr)) -> + if chunk = Byte_signed + then load_store_size addr + 1 + else load_store_size addr + | Lop(Istore(chunk, addr)) -> load_store_size addr + | Lop(Ialloc n) -> 4 + | Lop(Ispecific(Ialloc_far n)) -> 5 + | Lop(Iintop Imod) -> if powerpc then 3 else 2 + | Lop(Iintop(Icomp cmp)) -> 4 + | Lop(Iintop op) -> 1 + | Lop(Iintop_imm(Idiv, n)) -> 2 + | Lop(Iintop_imm(Imod, n)) -> 4 + | Lop(Iintop_imm(Icomp cmp, n)) -> 4 + | Lop(Iintop_imm(op, n)) -> 1 + | Lop(Inegf | Iabsf | Iaddf | Isubf | Imulf | Idivf) -> 1 + | Lop(Ifloatofint) -> 9 + | Lop(Iintoffloat) -> 4 + | Lop(Ispecific sop) -> 1 + | Lreloadretaddr -> 2 + | Lreturn -> 2 + | Llabel lbl -> 0 + | Lbranch lbl -> 1 + | Lcondbranch(tst, lbl) -> 2 + | Lcondbranch3(lbl0, lbl1, lbl2) -> + 1 + (if lbl0 = None then 0 else 1) + + (if lbl1 = None then 0 else 1) + + (if lbl2 = None then 0 else 1) + | Lswitch jumptbl -> 8 + | Lsetuptrap lbl -> 1 + | Lpushtrap -> if toc then 5 else 4 + | Lpoptrap -> 2 + | Lraise -> if toc then 7 else 6 + +let label_map code = + let map = Hashtbl.create 37 in + let rec fill_map pc instr = + match instr.desc with + Lend -> (pc, map) + | Llabel lbl -> Hashtbl.add map lbl pc; fill_map pc instr.next + | op -> fill_map (pc + instr_size op) instr.next + in fill_map 0 code + +let max_branch_offset = 8180 +(* 14-bit signed offset in words. Remember to cut some slack + for multi-word instructions where the branch can be anywhere in + the middle. 12 words of slack is plenty. *) + +let branch_overflows map pc_branch lbl_dest = + let pc_dest = Hashtbl.find map lbl_dest in + let delta = pc_dest - (pc_branch + 1) in + delta <= -max_branch_offset || delta >= max_branch_offset + +let opt_branch_overflows map pc_branch opt_lbl_dest = + match opt_lbl_dest with + None -> false + | Some lbl_dest -> branch_overflows map pc_branch lbl_dest + +let fixup_branches codesize map code = + let expand_optbranch lbl n arg next = + match lbl with + None -> next + | Some l -> + instr_cons (Lcondbranch(Iinttest_imm(Isigned Ceq, n), l)) + arg [||] next in + let rec fixup did_fix pc instr = + match instr.desc with + Lend -> did_fix + | Lcondbranch(test, lbl) when branch_overflows map pc lbl -> + let lbl2 = new_label() in + let cont = + instr_cons (Lbranch lbl) [||] [||] + (instr_cons (Llabel lbl2) [||] [||] instr.next) in + instr.desc <- Lcondbranch(invert_test test, lbl2); + instr.next <- cont; + fixup true (pc + 2) instr.next + | Lcondbranch3(lbl0, lbl1, lbl2) + when opt_branch_overflows map pc lbl0 + || opt_branch_overflows map pc lbl1 + || opt_branch_overflows map pc lbl2 -> + let cont = + expand_optbranch lbl0 0 instr.arg + (expand_optbranch lbl1 1 instr.arg + (expand_optbranch lbl2 2 instr.arg instr.next)) in + instr.desc <- cont.desc; + instr.next <- cont.next; + fixup true pc instr + | Lop(Ialloc n) when codesize - pc >= max_branch_offset -> + instr.desc <- Lop(Ispecific(Ialloc_far n)); + fixup true (pc + 4) instr.next + | op -> + fixup did_fix (pc + instr_size op) instr.next + in fixup false 0 code + +(* Iterate branch expansion till all conditional branches are OK *) + +let rec branch_normalization code = + let (codesize, map) = label_map code in + if codesize >= max_branch_offset && fixup_branches codesize map code + then branch_normalization code + else () + + +(* Output the assembly code for an instruction *) + +let rec emit_instr i dslot = + match i.desc with + Lend -> () + | Lop(Imove | Ispill | Ireload) -> + let src = i.arg.(0) and dst = i.res.(0) in + if src.loc <> dst.loc then begin + match (src, dst) with + {loc = Reg rs; typ = (Int | Addr)}, {loc = Reg rd} -> + ` mr {emit_reg dst}, {emit_reg src}\n` + | {loc = Reg rs; typ = Float}, {loc = Reg rd; typ = Float} -> + ` fmr {emit_reg dst}, {emit_reg src}\n` + | {loc = Reg rs; typ = (Int | Addr)}, {loc = Stack sd} -> + ` stw {emit_reg src}, {emit_stack dst}\n` + | {loc = Reg rs; typ = Float}, {loc = Stack sd} -> + ` stfd {emit_reg src}, {emit_stack dst}\n` + | {loc = Stack ss; typ = (Int | Addr)}, {loc = Reg rd} -> + ` lwz {emit_reg dst}, {emit_stack src}\n` + | {loc = Stack ss; typ = Float}, {loc = Reg rd} -> + ` lfd {emit_reg dst}, {emit_stack src}\n` + | (_, _) -> + fatal_error "Emit: Imove" + end + | Lop(Iconst_int n) -> + if is_native_immediate n then + ` li {emit_reg i.res.(0)}, {emit_nativeint n}\n` + else begin + ` lis {emit_reg i.res.(0)}, {emit_int(nativehigh n)}\n`; + if nativelow n <> 0 then + ` ori {emit_reg i.res.(0)}, {emit_reg i.res.(0)}, {emit_int(nativelow n)}\n` + end + | Lop(Iconst_float s) -> + if toc then begin + let repr = (Obj.magic (float_of_string s) : string) in + let lbl = label_float repr in + ` lfd {emit_reg i.res.(0)}, {emit_label lbl}(2) # {emit_string s}\n` + end else begin + let lbl = new_label() in + float_literals := (s, lbl) :: !float_literals; + ` addis {emit_gpr 11}, 0, {emit_upper emit_label lbl}\n`; + ` lfd {emit_reg i.res.(0)}, {emit_lower emit_label lbl}({emit_gpr 11})\n` + end + | Lop(Iconst_symbol s) -> + if toc then begin + let lbl = label_symbol s in + ` lwz {emit_reg i.res.(0)}, {emit_label lbl}(2) # {emit_symbol s}\n` + end else begin + ` addis {emit_reg i.res.(0)}, 0, {emit_upper emit_symbol s}\n`; + ` addi {emit_reg i.res.(0)}, {emit_reg i.res.(0)}, {emit_lower emit_symbol s}\n` + end + | Lop(Icall_ind) -> + if toc then begin + ` lwz 0, 0({emit_reg i.arg.(0)})\n`; + ` stw 2, 20(1)\n`; + ` mtlr 0\n`; + ` lwz 2, 4({emit_reg i.arg.(0)})\n`; + record_frame i.live; + ` blrl\n`; + ` lwz 2, 20(1)\n` + end else begin + ` mtlr {emit_reg i.arg.(0)}\n`; + record_frame i.live; + ` blrl\n` + end + | Lop(Icall_imm s) -> + record_frame i.live; + ` bl {emit_codesymbol s}\n`; + if toc && not (StringSet.mem s !defined_functions) then + ` cror 31, 31, 31\n` (* nop *) + | Lop(Itailcall_ind) -> + let n = frame_size() in + if toc then begin + ` lwz 0, 0({emit_reg i.arg.(0)})\n`; + ` lwz 2, 4({emit_reg i.arg.(0)})\n`; + ` mtctr 0\n` + end else begin + ` mtctr {emit_reg i.arg.(0)}\n` + end; + if !contains_calls then begin + ` lwz {emit_gpr 11}, {emit_int(n - 4)}({emit_gpr 1})\n`; + ` addi {emit_gpr 1}, {emit_gpr 1}, {emit_int n}\n`; + ` mtlr {emit_gpr 11}\n` + end else begin + if n > 0 then + ` addi {emit_gpr 1}, {emit_gpr 1}, {emit_int n}\n` + end; + ` bctr\n` + | Lop(Itailcall_imm s) -> + if s = !function_name then + ` b {emit_label !tailrec_entry_point}\n` + else if not toc || StringSet.mem s !defined_functions then begin + let n = frame_size() in + if !contains_calls then begin + ` lwz {emit_gpr 11}, {emit_int(n - 4)}({emit_gpr 1})\n`; + ` addi {emit_gpr 1}, {emit_gpr 1}, {emit_int n}\n`; + ` mtlr {emit_gpr 11}\n` + end else begin + if n > 0 then + ` addi {emit_gpr 1}, {emit_gpr 1}, {emit_int n}\n` + end; + ` b {emit_codesymbol s}\n` + end else begin + (* Tailcalling a function that has a possibly different TOC + is difficult, because the callee's TOC must be loaded in r2, + but ours must not be stored in 20(r1), which would overwrite + our caller's saved TOC. Hence we can't go through the + standard glue code. Here, we just proceed as in tailcall_ind. *) + let lbl = label_symbol s in + let n = frame_size() in + ` lwz 12, {emit_label lbl}(2) # {emit_symbol s}\n`; + if !contains_calls then begin + ` lwz 11, {emit_int(n - 4)}(1)\n`; + ` lwz 0, 0(12)\n`; + ` lwz 2, 4(12)\n`; + ` mtctr 0\n`; + ` addi 1, 1, {emit_int n}\n`; + ` mtlr 11\n` + end else begin + ` lwz 0, 0(12)\n`; + ` lwz 2, 4(12)\n`; + ` mtctr 0\n`; + if n > 0 then + ` addi 1, 1, {emit_int n}\n` + end; + ` bctr\n` + end + | Lop(Iextcall(s, alloc)) -> + if alloc then begin + if toc then begin + let lbl = label_symbol s in + ` lwz 11, {emit_label lbl}(2) # {emit_symbol s}\n` + end else if pic_externals then begin + external_functions := StringSet.add s !external_functions; + ` addis {emit_gpr 11}, 0, ha16(L{emit_symbol s}$non_lazy_ptr)\n`; + ` lwz {emit_gpr 11}, lo16(L{emit_symbol s}$non_lazy_ptr)({emit_gpr 11})\n` + end else begin + ` addis {emit_gpr 11}, 0, {emit_upper emit_symbol s}\n`; + ` addi {emit_gpr 11}, {emit_gpr 11}, {emit_lower emit_symbol s}\n` + end; + record_frame i.live; + ` bl {emit_codesymbol "caml_c_call"}\n` + end else begin + if pic_externals then begin + external_functions := StringSet.add s !external_functions; + ` addis {emit_gpr 11}, 0, ha16(L{emit_symbol s}$non_lazy_ptr)\n`; + ` lwz {emit_gpr 11}, lo16(L{emit_symbol s}$non_lazy_ptr)({emit_gpr 11})\n`; + ` mtlr {emit_gpr 11}\n`; + ` blrl\n` + end else + ` bl {emit_codesymbol s}\n` + end; + if toc then + ` cror 31, 31, 31\n` (* nop *) + | Lop(Istackoffset n) -> + ` addi {emit_gpr 1}, {emit_gpr 1}, {emit_int (-n)}\n`; + stack_offset := !stack_offset + n + | Lop(Iload(chunk, addr)) -> + let loadinstr = + match chunk with + Byte_unsigned -> "lbz" + | Byte_signed -> "lbz" + | Sixteen_unsigned -> "lhz" + | Sixteen_signed -> "lha" + | Single -> "lfs" + | Double | Double_u -> "lfd" + | _ -> "lwz" in + emit_load_store loadinstr addr i.arg 0 i.res.(0); + if chunk = Byte_signed then + ` extsb {emit_reg i.res.(0)}, {emit_reg i.res.(0)}\n` + | Lop(Istore(chunk, addr)) -> + let storeinstr = + match chunk with + Byte_unsigned | Byte_signed -> "stb" + | Sixteen_unsigned | Sixteen_signed -> "sth" + | Single -> "stfs" + | Double | Double_u -> "stfd" + | _ -> "stw" in + emit_load_store storeinstr addr i.arg 1 i.arg.(0) + | Lop(Ialloc n) -> + if !call_gc_label = 0 then call_gc_label := new_label(); + ` addi {emit_gpr 31}, {emit_gpr 31}, {emit_int(-n)}\n`; + ` cmplw {emit_gpr 31}, {emit_gpr 30}\n`; + ` addi {emit_reg i.res.(0)}, {emit_gpr 31}, 4\n`; + record_frame i.live; + ` bltl {emit_label !call_gc_label}\n` + | Lop(Ispecific(Ialloc_far n)) -> + if !call_gc_label = 0 then call_gc_label := new_label(); + let lbl = new_label() in + ` addi {emit_gpr 31}, {emit_gpr 31}, {emit_int(-n)}\n`; + ` cmplw {emit_gpr 31}, {emit_gpr 30}\n`; + ` bge {emit_label lbl}\n`; + record_frame i.live; + ` bl {emit_label !call_gc_label}\n`; + `{emit_label lbl}: addi {emit_reg i.res.(0)}, {emit_gpr 31}, 4\n` + | Lop(Iintop Isub) -> (* subf has swapped arguments *) + (* Use subfc instead of subf for RS6000 compatibility. *) + ` subfc {emit_reg i.res.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}\n` + | Lop(Iintop Imod) -> + if powerpc then begin + ` divw {emit_gpr 0}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; + ` mullw {emit_gpr 0}, {emit_gpr 0}, {emit_reg i.arg.(1)}\n`; + ` subfc {emit_reg i.res.(0)}, {emit_gpr 0}, {emit_reg i.arg.(0)}\n` + end else begin + ` divs {emit_gpr 0}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; + ` mfmq {emit_reg i.res.(0)}\n` + end + | Lop(Iintop(Icomp cmp)) -> + begin match cmp with + Isigned c -> + ` cmpw {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; + emit_set_comp c i.res.(0) + | Iunsigned c -> + ` cmplw {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; + emit_set_comp c i.res.(0) + end + | Lop(Iintop Icheckbound) -> + ` twlle {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n` + | Lop(Iintop op) -> + let instr = name_for_intop op in + ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n` + | Lop(Iintop_imm(Isub, n)) -> + ` addi {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_int(-n)}\n` + | Lop(Iintop_imm(Idiv, n)) -> (* n is guaranteed to be a power of 2 *) + let l = Misc.log2 n in + ` srawi {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_int l}\n`; + ` addze {emit_reg i.res.(0)}, {emit_reg i.res.(0)}\n` + | Lop(Iintop_imm(Imod, n)) -> (* n is guaranteed to be a power of 2 *) + let l = Misc.log2 n in + ` srawi {emit_gpr 0}, {emit_reg i.arg.(0)}, {emit_int l}\n`; + ` addze {emit_gpr 0}, {emit_gpr 0}\n`; + ` slwi {emit_gpr 0}, {emit_gpr 0}, {emit_int l}\n`; + ` subfc {emit_reg i.res.(0)}, {emit_gpr 0}, {emit_reg i.arg.(0)}\n` + | Lop(Iintop_imm(Icomp cmp, n)) -> + begin match cmp with + Isigned c -> + ` cmpwi {emit_reg i.arg.(0)}, {emit_int n}\n`; + emit_set_comp c i.res.(0) + | Iunsigned c -> + ` cmplwi {emit_reg i.arg.(0)}, {emit_int n}\n`; + emit_set_comp c i.res.(0) + end + | Lop(Iintop_imm(Icheckbound, n)) -> + ` twllei {emit_reg i.arg.(0)}, {emit_int n}\n` + | Lop(Iintop_imm(op, n)) -> + let instr = name_for_intop_imm op in + ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_int n}\n` + | Lop(Inegf | Iabsf as op) -> + let instr = name_for_floatop1 op in + ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}\n` + | Lop(Iaddf | Isubf | Imulf | Idivf as op) -> + let instr = name_for_floatop2 op in + ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n` + | Lop(Ifloatofint) -> + if toc then begin + let lbl = label_float "\067\048\000\000\128\000\000\000" in + (* That string above represents 0x4330000080000000 *) + ` lfd 0, {emit_label lbl}(2)\n` + end else begin + let lbl = new_label() in + float_literals := ("4.503601774854144e15", lbl) :: !float_literals; + (* That float above also represents 0x4330000080000000 *) + ` addis {emit_gpr 11}, 0, {emit_upper emit_label lbl}\n`; + ` lfd {emit_fpr 0}, {emit_lower emit_label lbl}({emit_gpr 11})\n` + end; + ` lis {emit_gpr 0}, 0x4330\n`; + ` stwu {emit_gpr 0}, -8({emit_gpr 1})\n`; + ` xoris {emit_gpr 0}, {emit_reg i.arg.(0)}, 0x8000\n`; + ` stw {emit_gpr 0}, 4({emit_gpr 1})\n`; + ` lfd {emit_reg i.res.(0)}, 0({emit_gpr 1})\n`; + ` addi {emit_gpr 1}, {emit_gpr 1}, 8\n`; + ` fsub {emit_reg i.res.(0)}, {emit_reg i.res.(0)}, {emit_fpr 0}\n` + | Lop(Iintoffloat) -> + ` fctiwz {emit_fpr 0}, {emit_reg i.arg.(0)}\n`; + ` stfdu {emit_fpr 0}, -8({emit_gpr 1})\n`; + ` lwz {emit_reg i.res.(0)}, 4({emit_gpr 1})\n`; + ` addi {emit_gpr 1}, {emit_gpr 1}, 8\n` + | Lop(Ispecific sop) -> + let instr = name_for_specific sop in + ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.arg.(2)}\n` + | Lreloadretaddr -> + let n = frame_size() in + ` lwz {emit_gpr 11}, {emit_int(n - 4)}({emit_gpr 1})\n`; + ` mtlr {emit_gpr 11}\n` + | Lreturn -> + let n = frame_size() in + if n > 0 then + ` addi {emit_gpr 1}, {emit_gpr 1}, {emit_int n}\n`; + ` blr\n` + | Llabel lbl -> + `{emit_label lbl}:\n` + | Lbranch lbl -> + ` b {emit_label lbl}\n` + | Lcondbranch(tst, lbl) -> + begin match tst with + Itruetest -> + ` cmpwi {emit_reg i.arg.(0)}, 0\n`; + emit_delay dslot; + ` bne {emit_label lbl}\n` + | Ifalsetest -> + ` cmpwi {emit_reg i.arg.(0)}, 0\n`; + emit_delay dslot; + ` beq {emit_label lbl}\n` + | Iinttest cmp -> + let (comp, branch) = name_for_int_comparison cmp in + ` {emit_string comp} {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; + emit_delay dslot; + ` {emit_string branch} {emit_label lbl}\n` + | Iinttest_imm(cmp, n) -> + let (comp, branch) = name_for_int_comparison cmp in + ` {emit_string comp}i {emit_reg i.arg.(0)}, {emit_int n}\n`; + emit_delay dslot; + ` {emit_string branch} {emit_label lbl}\n` + | Ifloattest(cmp, neg) -> + ` fcmpu {emit_ccr 0}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; + (* bit 0 = lt, bit 1 = gt, bit 2 = eq *) + let (bitnum, negtst) = + match cmp with + Ceq -> (2, neg) + | Cne -> (2, not neg) + | Cle -> ` cror 3, 0, 2\n`; (* lt or eq *) + (3, neg) + | Cgt -> (1, neg) + | Cge -> ` cror 3, 1, 2\n`; (* gt or eq *) + (3, neg) + | Clt -> (0, neg) in + emit_delay dslot; + if negtst + then ` bf {emit_int bitnum}, {emit_label lbl}\n` + else ` bt {emit_int bitnum}, {emit_label lbl}\n` + | Ioddtest -> + ` andi. {emit_gpr 0}, {emit_reg i.arg.(0)}, 1\n`; + emit_delay dslot; + ` bne {emit_label lbl}\n` + | Ieventest -> + ` andi. {emit_gpr 0}, {emit_reg i.arg.(0)}, 1\n`; + emit_delay dslot; + ` beq {emit_label lbl}\n` + end + | Lcondbranch3(lbl0, lbl1, lbl2) -> + ` cmpwi {emit_reg i.arg.(0)}, 1\n`; + emit_delay dslot; + begin match lbl0 with + None -> () + | Some lbl -> ` blt {emit_label lbl}\n` + end; + begin match lbl1 with + None -> () + | Some lbl -> ` beq {emit_label lbl}\n` + end; + begin match lbl2 with + None -> () + | Some lbl -> ` bgt {emit_label lbl}\n` + end + | Lswitch jumptbl -> + if !lbl_jumptbl = 0 then lbl_jumptbl := new_label(); + if toc then begin + ` lwz 11, {emit_label !lbl_jumptbl}(2)\n` + end else begin + ` addis {emit_gpr 11}, 0, {emit_upper emit_label !lbl_jumptbl}\n`; + ` addi {emit_gpr 11}, {emit_gpr 11}, {emit_lower emit_label !lbl_jumptbl}\n` + end; + ` addi {emit_gpr 0}, {emit_reg i.arg.(0)}, {emit_int !num_jumptbl_entries}\n`; + ` slwi {emit_gpr 0}, {emit_gpr 0}, 2\n`; + ` lwzx {emit_gpr 0}, {emit_gpr 11}, {emit_gpr 0}\n`; + ` add {emit_gpr 0}, {emit_gpr 11}, {emit_gpr 0}\n`; + ` mtctr {emit_gpr 0}\n`; + ` bctr\n`; + for i = 0 to Array.length jumptbl - 1 do + jumptbl_entries := jumptbl.(i) :: !jumptbl_entries; + incr num_jumptbl_entries + done + | Lsetuptrap lbl -> + ` bl {emit_label lbl}\n` + | Lpushtrap -> + stack_offset := !stack_offset + trap_frame_size; + ` mflr {emit_gpr 0}\n`; + ` stwu {emit_gpr 0}, -{emit_int trap_frame_size}({emit_gpr 1})\n`; + ` stw {emit_gpr 29}, 4({emit_gpr 1})\n`; + if toc then + ` stw {emit_gpr 2}, 20({emit_gpr 1})\n`; + ` mr {emit_gpr 29}, {emit_gpr 1}\n` + | Lpoptrap -> + ` lwz {emit_gpr 29}, 4({emit_gpr 1})\n`; + ` addi {emit_gpr 1}, {emit_gpr 1}, {emit_int trap_frame_size}\n`; + stack_offset := !stack_offset - trap_frame_size + | Lraise -> + ` lwz {emit_gpr 0}, 0({emit_gpr 29})\n`; + ` mr {emit_gpr 1}, {emit_gpr 29}\n`; + ` mtlr {emit_gpr 0}\n`; + ` lwz {emit_gpr 29}, 4({emit_gpr 1})\n`; + if toc then + ` lwz {emit_gpr 2}, 20({emit_gpr 1})\n`; + ` addi {emit_gpr 1}, {emit_gpr 1}, {emit_int trap_frame_size}\n`; + ` blr\n` + +and emit_delay = function + None -> () + | Some i -> emit_instr i None + +(* Checks if a pseudo-instruction expands to instructions + that do not branch and do not affect CR0 nor R12. *) + +let is_simple_instr i = + match i.desc with + Lop op -> + begin match op with + Icall_imm _ | Icall_ind | Itailcall_imm _ | Itailcall_ind | + Iextcall(_, _) -> false + | Ialloc(_) -> false + | Iintop(Icomp _) -> false + | Iintop_imm(Iand, _) -> false + | Iintop_imm(Icomp _, _) -> false + | _ -> true + end + | Lreloadretaddr -> true + | _ -> false + +let no_interference res arg = + try + for i = 0 to Array.length arg - 1 do + for j = 0 to Array.length res - 1 do + if arg.(i).loc = res.(j).loc then raise Exit + done + done; + true + with Exit -> + false + +(* Emit a sequence of instructions, trying to fill delay slots for branches *) + +let rec emit_all i = + match i with + {desc = Lend} -> () + | {next = {desc = (Lcondbranch(_, _) | Lcondbranch3(_, _, _))}} + when is_simple_instr i & no_interference i.res i.next.arg -> + emit_instr i.next (Some i); + emit_all i.next.next + | _ -> + emit_instr i None; + emit_all i.next + +(* Emission of a function declaration *) + +let fundecl fundecl = + function_name := fundecl.fun_name; + defined_functions := StringSet.add fundecl.fun_name !defined_functions; + tailrec_entry_point := new_label(); + stack_offset := 0; + call_gc_label := 0; + float_literals := []; + ` .globl {emit_symbol fundecl.fun_name}\n`; + begin match Config.system with + "aix" -> + ` .globl .{emit_symbol fundecl.fun_name}\n`; + ` .csect {emit_symbol fundecl.fun_name}[DS]\n`; + `{emit_symbol fundecl.fun_name}:\n`; + ` .long .{emit_symbol fundecl.fun_name}, TOC[tc0], 0\n` + | "elf" | "bsd" -> + ` .type {emit_symbol fundecl.fun_name}, @function\n` + | _ -> () + end; + emit_string code_space; + ` .align 2\n`; + `{emit_codesymbol fundecl.fun_name}:\n`; + let n = frame_size() in + if !contains_calls then begin + ` mflr {emit_gpr 0}\n`; + ` addi {emit_gpr 1}, {emit_gpr 1}, {emit_int(-n)}\n`; + ` stw {emit_gpr 0}, {emit_int(n - 4)}({emit_gpr 1})\n` + end else begin + if n > 0 then + ` addi {emit_gpr 1}, {emit_gpr 1}, {emit_int(-n)}\n` + end; + `{emit_label !tailrec_entry_point}:\n`; + branch_normalization fundecl.fun_body; + emit_all fundecl.fun_body; + (* Emit the glue code to call the GC *) + if !call_gc_label > 0 then begin + `{emit_label !call_gc_label}:\n`; + if toc then begin + ` mflr 0\n`; (* Save return address in r0 *) + ` bl .caml_call_gc\n`; + ` cror 31, 31, 31\n`; (* nop *) + ` blr\n` (* Will re-execute the allocation *) + end else begin + ` b {emit_symbol "caml_call_gc"}\n` + end + end; + (* Emit the floating-point literals *) + if !float_literals <> [] then begin + emit_string rodata_space; + ` .align 3\n`; + List.iter + (fun (f, lbl) -> + `{emit_label lbl}: .double 0d{emit_string f}\n`) + !float_literals + end + +(* Emission of data *) + +let declare_global_data s = + ` .globl {emit_symbol s}\n`; + if Config.system = "elf" || Config.system = "bsd" then + ` .type {emit_symbol s}, @object\n` + +let emit_item = function + Cglobal_symbol s -> + declare_global_data s + | Cdefine_symbol s -> + `{emit_symbol s}:\n`; + | Cdefine_label lbl -> + `{emit_label (lbl + 100000)}:\n` + | Cint8 n -> + ` .byte {emit_int n}\n` + | Cint16 n -> + ` .short {emit_int n}\n` + | Cint32 n -> + ` .long {emit_nativeint n}\n` + | Cint n -> + ` .long {emit_nativeint n}\n` + | Csingle f -> + ` .float 0d{emit_string f}\n` + | Cdouble f -> + ` .double 0d{emit_string f}\n` + | Csymbol_address s -> + ` .long {emit_symbol s}\n` + | Clabel_address lbl -> + ` .long {emit_label (lbl + 100000)}\n` + | Cstring s -> + emit_bytes_directive " .byte " s + | Cskip n -> + if n > 0 then ` .space {emit_int n}\n` + | Calign n -> + ` .align {emit_int (Misc.log2 n)}\n` + +let data l = + emit_string data_space; + List.iter emit_item l + +(* Beginning / end of an assembly file *) + +let begin_assembly() = + Hashtbl.clear symbol_constants; + Hashtbl.clear float_constants; + defined_functions := StringSet.empty; + external_functions := StringSet.empty; + num_jumptbl_entries := 0; + jumptbl_entries := []; + lbl_jumptbl := 0; + (* Emit the beginning of the segments *) + let lbl_begin = Compilenv.current_unit_name() ^ "__data_begin" in + emit_string data_space; + declare_global_data lbl_begin; + `{emit_symbol lbl_begin}:\n`; + let lbl_begin = Compilenv.current_unit_name() ^ "__code_begin" in + emit_string code_space; + declare_global_data lbl_begin; + `{emit_symbol lbl_begin}:\n` + +let end_assembly() = + (* Emit the jump table *) + if !num_jumptbl_entries > 0 then begin + let lbl_tbl = + if toc then begin + let lbl_tbl = new_label() in + ` .toc\n`; + `{emit_label !lbl_jumptbl}: .tc {emit_label lbl_tbl}[TC], {emit_label lbl_tbl}\n`; + lbl_tbl + end else !lbl_jumptbl in + emit_string code_space; + `{emit_label lbl_tbl}:\n`; + List.iter + (fun lbl -> ` .long {emit_label lbl} - {emit_label lbl_tbl}\n`) + (List.rev !jumptbl_entries); + jumptbl_entries := [] + end; + if toc then begin + (* Emit the table of constants *) + ` .toc\n`; + Hashtbl.iter emit_symbol_constant symbol_constants; + Hashtbl.iter emit_float_constant float_constants + end; + if pic_externals then + (* Emit the pointers to external functions *) + StringSet.iter emit_external !external_functions; + (* Emit the end of the segments *) + emit_string code_space; + let lbl_end = Compilenv.current_unit_name() ^ "__code_end" in + declare_global_data lbl_end; + `{emit_symbol lbl_end}:\n`; + emit_string data_space; + let lbl_end = Compilenv.current_unit_name() ^ "__data_end" in + declare_global_data lbl_end; + `{emit_symbol lbl_end}:\n`; + ` .long 0\n`; + (* Emit the frame descriptors *) + emit_string rodata_space; + let lbl = Compilenv.current_unit_name() ^ "__frametable" in + declare_global_data lbl; + `{emit_symbol lbl}:\n`; + ` .long {emit_int (List.length !frame_descriptors)}\n`; + List.iter emit_frame !frame_descriptors; + frame_descriptors := [] diff --git a/asmcomp/power/proc.ml b/asmcomp/power/proc.ml new file mode 100644 index 00000000..573169ee --- /dev/null +++ b/asmcomp/power/proc.ml @@ -0,0 +1,252 @@ +(***********************************************************************) +(* *) +(* 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: proc.ml,v 1.10 2003/07/17 15:11:02 xleroy Exp $ *) + +(* Description of the Power PC *) + +open Misc +open Cmm +open Reg +open Arch +open Mach + +(* Instruction selection *) + +let word_addressed = false + +(* Registers available for register allocation *) + +(* Integer register map: + 0 temporary, null register for some operations + 1 stack pointer + 2 pointer to table of contents + 3 - 10 function arguments and results + 11 - 12 temporaries + 13 pointer to small data area + 14 - 28 general purpose, preserved by C + 29 trap pointer + 30 allocation limit + 31 allocation pointer + Floating-point register map: + 0 temporary + 1 - 13 function arguments and results + 14 - 31 general purpose, preserved by C +*) + +let int_reg_name = + if Config.system = "rhapsody" then + [| "r3"; "r4"; "r5"; "r6"; "r7"; "r8"; "r9"; "r10"; + "r14"; "r15"; "r16"; "r17"; "r18"; "r19"; "r20"; "r21"; + "r22"; "r23"; "r24"; "r25"; "r26"; "r27"; "r28" |] + else + [| "3"; "4"; "5"; "6"; "7"; "8"; "9"; "10"; + "14"; "15"; "16"; "17"; "18"; "19"; "20"; "21"; + "22"; "23"; "24"; "25"; "26"; "27"; "28" |] + +let float_reg_name = + if Config.system = "rhapsody" then + [| "f1"; "f2"; "f3"; "f4"; "f5"; "f6"; "f7"; "f8"; + "f9"; "f10"; "f11"; "f12"; "f13"; "f14"; "f15"; "f16"; + "f17"; "f18"; "f19"; "f20"; "f21"; "f22"; "f23"; "f24"; + "f25"; "f26"; "f27"; "f28"; "f29"; "f30"; "f31" |] + else + [| "1"; "2"; "3"; "4"; "5"; "6"; "7"; "8"; + "9"; "10"; "11"; "12"; "13"; "14"; "15"; "16"; + "17"; "18"; "19"; "20"; "21"; "22"; "23"; "24"; + "25"; "26"; "27"; "28"; "29"; "30"; "31" |] + +let num_register_classes = 2 + +let register_class r = + match r.typ with + Int -> 0 + | Addr -> 0 + | Float -> 1 + +let num_available_registers = [| 23; 31 |] + +let first_available_register = [| 0; 100 |] + +let register_name r = + if r < 100 then int_reg_name.(r) else float_reg_name.(r - 100) + +let rotate_registers = true + +(* Representation of hard registers by pseudo-registers *) + +let hard_int_reg = + let v = Array.create 23 Reg.dummy in + for i = 0 to 22 do v.(i) <- Reg.at_location Int (Reg i) done; v + +let hard_float_reg = + let v = Array.create 31 Reg.dummy in + for i = 0 to 30 do v.(i) <- Reg.at_location Float (Reg(100 + i)) done; v + +let all_phys_regs = + Array.append hard_int_reg hard_float_reg + +let phys_reg n = + if n < 100 then hard_int_reg.(n) else hard_float_reg.(n - 100) + +let stack_slot slot ty = + Reg.at_location ty (Stack slot) + +(* Calling conventions *) + +let calling_conventions + first_int last_int first_float last_float make_stack stack_ofs arg = + let loc = Array.create (Array.length arg) Reg.dummy in + let int = ref first_int in + let float = ref first_float in + let ofs = ref stack_ofs in + for i = 0 to Array.length arg - 1 do + match arg.(i).typ with + Int | Addr as ty -> + if !int <= last_int then begin + loc.(i) <- phys_reg !int; + incr int + end else begin + loc.(i) <- stack_slot (make_stack !ofs) ty; + ofs := !ofs + size_int + end + | Float -> + if !float <= last_float then begin + loc.(i) <- phys_reg !float; + incr float + end else begin + loc.(i) <- stack_slot (make_stack !ofs) Float; + ofs := !ofs + size_float + end + done; + let final_ofs = if toc && !ofs > 0 then !ofs + 32 else !ofs in + (loc, Misc.align final_ofs 16) + (* Keep stack 16-aligned. + Under PowerOpen, keep a free 32 byte linkage area at the bottom + if we need to stack-allocate some arguments. *) + +let incoming ofs = Incoming ofs +let outgoing ofs = Outgoing ofs +let not_supported ofs = fatal_error "Proc.loc_results: cannot call" + +let loc_arguments arg = + calling_conventions 0 7 100 112 outgoing 0 arg +let loc_parameters arg = + let (loc, ofs) = calling_conventions 0 7 100 112 incoming 0 arg in loc +let loc_results res = + let (loc, ofs) = calling_conventions 0 7 100 112 not_supported 0 res in loc + +(* C calling conventions under PowerOpen: + use GPR 3-10 and FPR 1-13 just like ML calling + conventions, but always reserve stack space for all arguments. + Also, using a float register automatically reserves two int registers. + (If we were to call a non-prototyped C function, each float argument + would have to go both in a float reg and in the matching pair + of integer regs.) + + C calling conventions under SVR4: + use GPR 3-10 and FPR 1-8 just like ML calling conventions. + Using a float register does not affect the int registers. + Always reserve 8 bytes at bottom of stack, plus whatever is needed + to hold the overflow arguments. *) + +let poweropen_external_conventions first_int last_int + first_float last_float arg = + let loc = Array.create (Array.length arg) Reg.dummy in + let int = ref first_int in + let float = ref first_float in + let ofs = ref 56 in + for i = 0 to Array.length arg - 1 do + match arg.(i).typ with + Int | Addr as ty -> + if !int <= last_int then begin + loc.(i) <- phys_reg !int; + incr int + end else begin + loc.(i) <- stack_slot (Outgoing !ofs) ty; + ofs := !ofs + size_int + end + | Float -> + if !float <= last_float then begin + loc.(i) <- phys_reg !float; + incr float + end else begin + loc.(i) <- stack_slot (Outgoing !ofs) Float; + ofs := !ofs + size_float + end; + int := !int + 2 + done; + (loc, Misc.align !ofs 16) (* Keep stack 16-aligned *) + +let loc_external_arguments = + match Config.system with + "aix" | "rhapsody" -> poweropen_external_conventions 0 7 100 112 + | "elf" | "bsd" -> calling_conventions 0 7 100 107 outgoing 8 + | _ -> assert false + +let extcall_use_push = false + +(* Results are in GPR 3 and FPR 1 *) + +let loc_external_results res = + let (loc, ofs) = calling_conventions 0 0 100 100 not_supported 0 res in loc + +(* Exceptions are in GPR 3 *) + +let loc_exn_bucket = phys_reg 0 + +(* Registers destroyed by operations *) + +let destroyed_at_c_call = + Array.of_list(List.map phys_reg + [0; 1; 2; 3; 4; 5; 6; 7; + 100; 101; 102; 103; 104; 105; 106; 107; 108; 109; 110; 111; 112]) + +let destroyed_at_oper = function + Iop(Icall_ind | Icall_imm _ | Iextcall(_, true)) -> all_phys_regs + | Iop(Iextcall(_, false)) -> destroyed_at_c_call + | _ -> [||] + +let destroyed_at_raise = all_phys_regs + +(* Maximal register pressure *) + +let safe_register_pressure = function + Iextcall(_, _) -> 15 + | _ -> 23 + +let max_register_pressure = function + Iextcall(_, _) -> [| 15; 18 |] + | _ -> [| 23; 30 |] + +(* Layout of the stack *) + +let num_stack_slots = [| 0; 0 |] +let contains_calls = ref false + +(* Calling the assembler *) + +let assemble_file infile outfile = + let infile = Filename.quote infile + and outfile = Filename.quote outfile in + match Config.system with + "aix" -> + let proc = if powerpc then "ppc" else "pwr" in + Ccomp.command ("as -u -m " ^ proc ^ " -o " ^ outfile ^ " " ^ infile) + | "elf" -> + Ccomp.command ("as -u -m ppc -o " ^ outfile ^ " " ^ infile) + | "rhapsody" | "bsd" -> + Ccomp.command ("as -o " ^ outfile ^ " " ^ infile) + | _ -> assert false + +open Clflags;; +open Config;; diff --git a/asmcomp/power/reload.ml b/asmcomp/power/reload.ml new file mode 100644 index 00000000..e2ffd75c --- /dev/null +++ b/asmcomp/power/reload.ml @@ -0,0 +1,18 @@ +(***********************************************************************) +(* *) +(* 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: reload.ml,v 1.3 1999/11/17 18:56:46 xleroy Exp $ *) + +(* Reloading for the PowerPC *) + +let fundecl f = + (new Reloadgen.reload_generic)#fundecl f diff --git a/asmcomp/power/scheduling.ml b/asmcomp/power/scheduling.ml new file mode 100644 index 00000000..4674bde0 --- /dev/null +++ b/asmcomp/power/scheduling.ml @@ -0,0 +1,66 @@ +(***********************************************************************) +(* *) +(* 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: scheduling.ml,v 1.5 1999/11/17 18:56:46 xleroy Exp $ *) + +(* Instruction scheduling for the Power PC *) + +open Arch +open Mach + +class scheduler = object + +inherit Schedgen.scheduler_generic + +(* Latencies (in cycles). Based roughly on the "common model". *) + +method oper_latency = function + Ireload -> 2 + | Iload(_, _) -> 2 + | Iconst_float _ -> 2 (* turned into a load *) + | Iconst_symbol _ -> if toc then 2 (* turned into a load *) else 1 + | Iintop Imul -> 9 + | Iintop_imm(Imul, _) -> 5 + | Iintop(Idiv | Imod) -> 36 + | Iaddf | Isubf -> 4 + | Imulf -> 5 + | Idivf -> 33 + | Ispecific(Imultaddf | Imultsubf) -> 5 + | _ -> 1 + +method reload_retaddr_latency = 12 + (* If we can have that many cycles between the reloadretaddr and the + return, we can expect that the blr branch will be completely folded. *) + +(* Issue cycles. Rough approximations. *) + +method oper_issue_cycles = function + Iconst_float _ | Iconst_symbol _ -> if toc then 1 else 2 + | Iload(_, Ibased(_, _)) -> 2 + | Istore(_, Ibased(_, _)) -> 2 + | Ialloc _ -> 4 + | Iintop(Imod) -> 40 (* assuming full stall *) + | Iintop(Icomp _) -> 4 + | Iintop_imm(Idiv, _) -> 2 + | Iintop_imm(Imod, _) -> 4 + | Iintop_imm(Icomp _, _) -> 4 + | Ifloatofint -> 9 + | Iintoffloat -> 4 + | _ -> 1 + +method reload_retaddr_issue_cycles = 3 + (* load then stalling mtlr *) + +end + +let fundecl f = (new scheduler)#schedule_fundecl f + diff --git a/asmcomp/power/selection.ml b/asmcomp/power/selection.ml new file mode 100644 index 00000000..495db6c1 --- /dev/null +++ b/asmcomp/power/selection.ml @@ -0,0 +1,107 @@ +(***********************************************************************) +(* *) +(* 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: selection.ml,v 1.5 2000/12/28 13:03:01 weis Exp $ *) + +(* Instruction selection for the Power PC processor *) + +open Misc +open Cmm +open Reg +open Arch +open Mach + +(* Recognition of addressing modes *) + +type addressing_expr = + Asymbol of string + | Alinear of expression + | Aadd of expression * expression + +let rec select_addr = function + Cconst_symbol s when not toc -> + (* don't recognize this mode in the TOC-based model *) + (Asymbol s, 0) + | Cop((Caddi | Cadda), [arg; Cconst_int m]) -> + let (a, n) = select_addr arg in (a, n + m) + | Cop((Caddi | Cadda), [Cconst_int m; arg]) -> + let (a, n) = select_addr arg in (a, n + m) + | Cop((Caddi | Cadda), [arg1; arg2]) -> + begin match (select_addr arg1, select_addr arg2) with + ((Alinear e1, n1), (Alinear e2, n2)) -> + (Aadd(e1, e2), n1 + n2) + | _ -> + (Aadd(arg1, arg2), 0) + end + | exp -> + (Alinear exp, 0) + +(* Instruction selection *) + +class selector = object (self) + +inherit Selectgen.selector_generic as super + +method is_immediate n = (n <= 32767) && (n >= -32768) + +method select_addressing exp = + match select_addr exp with + (Asymbol s, d) -> + (Ibased(s, d), Ctuple []) + | (Alinear e, d) -> + (Iindexed d, e) + | (Aadd(e1, e2), d) -> + if d = 0 + then (Iindexed2, Ctuple[e1; e2]) + else (Iindexed d, Cop(Cadda, [e1; e2])) + +method select_operation op args = + match (op, args) with + (* Prevent the recognition of (x / cst) and (x % cst) when cst is not + a power of 2, which do not correspond to an instruction. *) + (Cdivi, [arg; Cconst_int n]) when n = 1 lsl (Misc.log2 n) -> + (Iintop_imm(Idiv, n), [arg]) + | (Cdivi, _) -> + (Iintop Idiv, args) + | (Cmodi, [arg; Cconst_int n]) when n = 1 lsl (Misc.log2 n) -> + (Iintop_imm(Imod, n), [arg]) + | (Cmodi, _) -> + (Iintop Imod, args) + (* The and, or and xor instructions have a different range of immediate + operands than the other instructions *) + | (Cand, _) -> self#select_logical Iand args + | (Cor, _) -> self#select_logical Ior args + | (Cxor, _) -> self#select_logical Ixor args + (* intoffloat goes through a library function on the RS6000 *) + | (Cintoffloat, _) when not powerpc -> + (Iextcall("itrunc", false), args) + (* Recognize mult-add and mult-sub instructions *) + | (Caddf, [Cop(Cmulf, [arg1; arg2]); arg3]) -> + (Ispecific Imultaddf, [arg1; arg2; arg3]) + | (Caddf, [arg3; Cop(Cmulf, [arg1; arg2])]) -> + (Ispecific Imultaddf, [arg1; arg2; arg3]) + | (Csubf, [Cop(Cmulf, [arg1; arg2]); arg3]) -> + (Ispecific Imultsubf, [arg1; arg2; arg3]) + | _ -> + super#select_operation op args + +method select_logical op = function + [arg; Cconst_int n] when n >= 0 && n <= 0xFFFF -> + (Iintop_imm(op, n), [arg]) + | [Cconst_int n; arg] when n >= 0 && n <= 0xFFFF -> + (Iintop_imm(op, n), [arg]) + | args -> + (Iintop op, args) + +end + +let fundecl f = (new selector)#emit_fundecl f diff --git a/asmcomp/printcmm.ml b/asmcomp/printcmm.ml new file mode 100644 index 00000000..b3e0b19c --- /dev/null +++ b/asmcomp/printcmm.ml @@ -0,0 +1,203 @@ +(***********************************************************************) +(* *) +(* 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: printcmm.ml,v 1.24 2002/11/24 15:55:24 xleroy Exp $ *) + +(* Pretty-printing of C-- code *) + +open Format +open Cmm + +let machtype_component ppf = function + | Addr -> fprintf ppf "addr" + | Int -> fprintf ppf "int" + | Float -> fprintf ppf "float" + +let machtype ppf mty = + match Array.length mty with + | 0 -> fprintf ppf "unit" + | n -> machtype_component ppf mty.(0); + for i = 1 to n-1 do + fprintf ppf "*%a" machtype_component mty.(i) + done + +let comparison = function + | Ceq -> "==" + | Cne -> "!=" + | Clt -> "<" + | Cle -> "<=" + | Cgt -> ">" + | Cge -> ">=" + +let chunk = function + | Byte_unsigned -> "unsigned int8" + | Byte_signed -> "signed int8" + | Sixteen_unsigned -> "unsigned int16" + | Sixteen_signed -> "signed int16" + | Thirtytwo_unsigned -> "unsigned int32" + | Thirtytwo_signed -> "signed int32" + | Word -> "" + | Single -> "float32" + | Double -> "float64" + | Double_u -> "float64u" + +let operation = function + | Capply ty -> "app" + | Cextcall(lbl, ty, alloc) -> Printf.sprintf "extcall \"%s\"" lbl + | Cload Word -> "load" + | Cload c -> Printf.sprintf "load %s" (chunk c) + | Calloc -> "alloc" + | Cstore Word -> "store" + | Cstore c -> Printf.sprintf "store %s" (chunk c) + | Caddi -> "+" + | Csubi -> "-" + | Cmuli -> "*" + | Cdivi -> "/" + | Cmodi -> "mod" + | Cand -> "and" + | Cor -> "or" + | Cxor -> "xor" + | Clsl -> "<<" + | Clsr -> ">>u" + | Casr -> ">>s" + | Ccmpi c -> comparison c + | Cadda -> "+a" + | Csuba -> "-a" + | Ccmpa c -> Printf.sprintf "%sa" (comparison c) + | Cnegf -> "~f" + | Cabsf -> "absf" + | Caddf -> "+f" + | Csubf -> "-f" + | Cmulf -> "*f" + | Cdivf -> "/f" + | Cfloatofint -> "floatofint" + | Cintoffloat -> "intoffloat" + | Ccmpf c -> Printf.sprintf "%sf" (comparison c) + | Craise -> "raise" + | Ccheckbound -> "checkbound" + +let rec expr ppf = function + | Cconst_int n -> fprintf ppf "%i" n + | Cconst_natint n -> fprintf ppf "%s" (Nativeint.to_string n) + | Cconst_float s -> fprintf ppf "%s" s + | Cconst_symbol s -> fprintf ppf "\"%s\"" s + | Cconst_pointer n -> fprintf ppf "%ia" n + | Cconst_natpointer n -> fprintf ppf "%sa" (Nativeint.to_string n) + | Cvar id -> Ident.print ppf id + | Clet(id, def, (Clet(_, _, _) as body)) -> + let print_binding id ppf def = + fprintf ppf "@[<2>%a@ %a@]" Ident.print id expr def in + let rec in_part ppf = function + | Clet(id, def, body) -> + fprintf ppf "@ %a" (print_binding id) def; + in_part ppf body + | exp -> exp in + fprintf ppf "@[<2>(let@ @[<1>(%a" (print_binding id) def; + let exp = in_part ppf body in + fprintf ppf ")@]@ %a)@]" sequence exp + | Clet(id, def, body) -> + fprintf ppf + "@[<2>(let@ @[<2>%a@ %a@]@ %a)@]" + Ident.print id expr def sequence body + | Cassign(id, exp) -> + fprintf ppf "@[<2>(assign @[<2>%a@ %a@])@]" Ident.print id expr exp + | Ctuple el -> + let tuple ppf el = + let first = ref true in + List.iter + (fun e -> + if !first then first := false else fprintf ppf "@ "; + expr ppf e) + el in + fprintf ppf "@[<1>[%a]@]" tuple el + | Cop(op, el) -> + fprintf ppf "@[<2>(%s" (operation op); + List.iter (fun e -> fprintf ppf "@ %a" expr e) el; + begin match op with + | Capply mty -> fprintf ppf "@ %a" machtype mty + | Cextcall(_, mty, _) -> fprintf ppf "@ %a" machtype mty + | _ -> () + end; + fprintf ppf ")@]" + | Csequence(e1, e2) -> + fprintf ppf "@[<2>(seq@ %a@ %a)@]" sequence e1 sequence e2 + | Cifthenelse(e1, e2, e3) -> + fprintf ppf "@[<2>(if@ %a@ %a@ %a)@]" expr e1 expr e2 expr e3 + | Cswitch(e1, index, cases) -> + let print_case i ppf = + for j = 0 to Array.length index - 1 do + if index.(j) = i then fprintf ppf "case %i:" j + done in + let print_cases ppf = + for i = 0 to Array.length cases - 1 do + fprintf ppf "@ @[<2>%t@ %a@]" (print_case i) sequence cases.(i) + done in + fprintf ppf "@[@[<2>(switch@ %a@ @]%t)@]" expr e1 print_cases + | Cloop e -> + fprintf ppf "@[<2>(loop@ %a)@]" sequence e + | Ccatch(i, ids, e1, e2) -> + fprintf ppf + "@[<2>(catch@ %a@;<1 -2>with(%d%a)@ %a)@]" + sequence e1 i + (fun ppf ids -> + List.iter + (fun id -> fprintf ppf " %a" Ident.print id) + ids) ids + sequence e2 + | Cexit (i, el) -> + fprintf ppf "@[<2>(exit %d" i ; + List.iter (fun e -> fprintf ppf "@ %a" expr e) el; + fprintf ppf ")@]" + | Ctrywith(e1, id, e2) -> + fprintf ppf "@[<2>(try@ %a@;<1 -2>with@ %a@ %a)@]" + sequence e1 Ident.print id sequence e2 + +and sequence ppf = function + | Csequence(e1, e2) -> fprintf ppf "%a@ %a" sequence e1 sequence e2 + | e -> expression ppf e + +and expression ppf e = fprintf ppf "%a" expr e + +let fundecl ppf f = + let print_cases ppf cases = + let first = ref true in + List.iter + (fun (id, ty) -> + if !first then first := false else fprintf ppf "@ "; + fprintf ppf "%a: %a" Ident.print id machtype ty) + cases in + fprintf ppf "@[<1>(function %s@;<1 4>@[<1>(%a)@]@ @[%a@])@]@." + f.fun_name print_cases f.fun_args sequence f.fun_body + +let data_item ppf = function + | Cdefine_symbol s -> fprintf ppf "\"%s\":" s + | Cdefine_label l -> fprintf ppf "L%i:" l + | Cglobal_symbol s -> fprintf ppf "global \"%s\"" s + | Cint8 n -> fprintf ppf "byte %i" n + | Cint16 n -> fprintf ppf "int16 %i" n + | Cint32 n -> fprintf ppf "int32 %s" (Nativeint.to_string n) + | Cint n -> fprintf ppf "int %s" (Nativeint.to_string n) + | Csingle f -> fprintf ppf "single %s" f + | Cdouble f -> fprintf ppf "double %s" f + | Csymbol_address s -> fprintf ppf "addr \"%s\"" s + | Clabel_address l -> fprintf ppf "addr L%i" l + | Cstring s -> fprintf ppf "string \"%s\"" s + | Cskip n -> fprintf ppf "skip %i" n + | Calign n -> fprintf ppf "align %i" n + +let data ppf dl = + let items ppf = List.iter (fun d -> fprintf ppf "@ %a" data_item d) dl in + fprintf ppf "@[(data%t)@]" items + +let phrase ppf = function + | Cfunction f -> fundecl ppf f + | Cdata dl -> data ppf dl diff --git a/asmcomp/printcmm.mli b/asmcomp/printcmm.mli new file mode 100644 index 00000000..4da8751b --- /dev/null +++ b/asmcomp/printcmm.mli @@ -0,0 +1,27 @@ +(***********************************************************************) +(* *) +(* 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: printcmm.mli,v 1.6 2000/04/21 08:10:34 weis Exp $ *) + +(* Pretty-printing of C-- code *) + +open Format + +val machtype_component : formatter -> Cmm.machtype_component -> unit +val machtype : formatter -> Cmm.machtype_component array -> unit +val comparison : Cmm.comparison -> string +val chunk : Cmm.memory_chunk -> string +val operation : Cmm.operation -> string +val expression : formatter -> Cmm.expression -> unit +val fundecl : formatter -> Cmm.fundecl -> unit +val data : formatter -> Cmm.data_item list -> unit +val phrase : formatter -> Cmm.phrase -> unit diff --git a/asmcomp/printlinear.ml b/asmcomp/printlinear.ml new file mode 100644 index 00000000..0a33d393 --- /dev/null +++ b/asmcomp/printlinear.ml @@ -0,0 +1,74 @@ +(***********************************************************************) +(* *) +(* 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: printlinear.ml,v 1.12 2000/04/21 08:10:35 weis Exp $ *) + +(* Pretty-printing of linearized machine code *) + +open Format +open Mach +open Printmach +open Linearize + +let label ppf l = + Format.fprintf ppf "L%i" l + +let instr ppf i = + match i.desc with + | Lend -> () + | Lop op -> + begin match op with + | Ialloc _ | Icall_ind | Icall_imm _ | Iextcall(_, _) -> + fprintf ppf "@[<1>{%a}@]@," regsetaddr i.live + | _ -> () + end; + operation op i.arg ppf i.res + | Lreloadretaddr -> + fprintf ppf "reload retaddr" + | Lreturn -> + fprintf ppf "return %a" regs i.arg + | Llabel lbl -> + fprintf ppf "%a:" label lbl + | Lbranch lbl -> + fprintf ppf "goto %a" label lbl + | Lcondbranch(tst, lbl) -> + fprintf ppf "if %a goto %a" (test tst) i.arg label lbl + | Lcondbranch3(lbl0, lbl1, lbl2) -> + fprintf ppf "switch3 %a" reg i.arg.(0); + let case n = function + | None -> () + | Some lbl -> + fprintf ppf "@,case %i: goto %a" n label lbl in + case 0 lbl0; case 1 lbl1; case 2 lbl2; + fprintf ppf "@,endswitch" + | Lswitch lblv -> + fprintf ppf "switch %a" reg i.arg.(0); + for i = 0 to Array.length lblv - 1 do + fprintf ppf "case %i: goto %a" i label lblv.(i) + done; + fprintf ppf "@,endswitch" + | Lsetuptrap lbl -> + fprintf ppf "setup trap %a" label lbl + | Lpushtrap -> + fprintf ppf "push trap" + | Lpoptrap -> + fprintf ppf "pop trap" + | Lraise -> + fprintf ppf "raise %a" reg i.arg.(0) + +let rec all_instr ppf i = + match i.desc with + | Lend -> () + | _ -> fprintf ppf "%a@,%a" instr i all_instr i.next + +let fundecl ppf f = + fprintf ppf "@[%s:@,%a@]" f.fun_name all_instr f.fun_body diff --git a/asmcomp/printlinear.mli b/asmcomp/printlinear.mli new file mode 100644 index 00000000..514f1100 --- /dev/null +++ b/asmcomp/printlinear.mli @@ -0,0 +1,21 @@ +(***********************************************************************) +(* *) +(* 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: printlinear.mli,v 1.5 2000/04/21 08:10:35 weis Exp $ *) + +(* Pretty-printing of linearized machine code *) + +open Format +open Linearize + +val instr: formatter -> instruction -> unit +val fundecl: formatter -> fundecl -> unit diff --git a/asmcomp/printmach.ml b/asmcomp/printmach.ml new file mode 100644 index 00000000..e13420b2 --- /dev/null +++ b/asmcomp/printmach.ml @@ -0,0 +1,217 @@ +(***********************************************************************) +(* *) +(* 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: printmach.ml,v 1.22 2000/08/11 19:50:54 maranget Exp $ *) + +(* Pretty-printing of pseudo machine code *) + +open Format +open Cmm +open Reg +open Mach + +let reg ppf r = + if String.length r.name > 0 then + fprintf ppf "%s" r.name + else + fprintf ppf "%s" (match r.typ with Addr -> "A" | Int -> "I" | Float -> "F"); + fprintf ppf "/%i" r.stamp; + begin match r.loc with + | Unknown -> () + | Reg r -> + fprintf ppf "[%s]" (Proc.register_name r) + | Stack(Local s) -> + fprintf ppf "[s%i]" s + | Stack(Incoming s) -> + fprintf ppf "[si%i]" s + | Stack(Outgoing s) -> + fprintf ppf "[so%i]" s + end + +let regs ppf v = + match Array.length v with + | 0 -> () + | 1 -> reg ppf v.(0) + | n -> reg ppf v.(0); + for i = 1 to n-1 do fprintf ppf "@ %a" reg v.(i) done + +let regset ppf s = + let first = ref true in + Reg.Set.iter + (fun r -> + if !first then begin first := false; fprintf ppf "%a" reg r end + else fprintf ppf "@ %a" reg r) + s + +let regsetaddr ppf s = + let first = ref true in + Reg.Set.iter + (fun r -> + if !first then begin first := false; fprintf ppf "%a" reg r end + else fprintf ppf "@ %a" reg r; + match r.typ with Addr -> fprintf ppf "*" | _ -> ()) + s + +let intcomp = function + | Isigned c -> Printf.sprintf " %ss " (Printcmm.comparison c) + | Iunsigned c -> Printf.sprintf " %su " (Printcmm.comparison c) + +let floatcomp c = + Printf.sprintf " %sf " (Printcmm.comparison c) + +let intop = function + | Iadd -> " + " + | Isub -> " - " + | Imul -> " * " + | Idiv -> " div " + | Imod -> " mod " + | Iand -> " & " + | Ior -> " | " + | Ixor -> " ^ " + | Ilsl -> " << " + | Ilsr -> " >>u " + | Iasr -> " >>s " + | Icomp cmp -> intcomp cmp + | Icheckbound -> " check > " + +let test tst ppf arg = + match tst with + | Itruetest -> reg ppf arg.(0) + | Ifalsetest -> fprintf ppf "not %a" reg arg.(0) + | Iinttest cmp -> fprintf ppf "%a%s%a" reg arg.(0) (intcomp cmp) reg arg.(1) + | Iinttest_imm(cmp, n) -> fprintf ppf "%a%s%i" reg arg.(0) (intcomp cmp) n + | Ifloattest(cmp, neg) -> + fprintf ppf "%s%a%s%a" + (if neg then "not " else "") + reg arg.(0) (floatcomp cmp) reg arg.(1) + | Ieventest -> fprintf ppf "%a & 1 == 0" reg arg.(0) + | Ioddtest -> fprintf ppf "%a & 1 == 1" reg arg.(0) + +let print_live = ref false + +let operation op arg ppf res = + if Array.length res > 0 then fprintf ppf "%a := " regs res; + match op with + | Imove -> regs ppf arg + | Ispill -> fprintf ppf "%a (spill)" regs arg + | Ireload -> fprintf ppf "%a (reload)" regs arg + | Iconst_int n -> fprintf ppf "%s" (Nativeint.to_string n) + | Iconst_float s -> fprintf ppf "%s" s + | Iconst_symbol s -> fprintf ppf "\"%s\"" s + | Icall_ind -> fprintf ppf "call %a" regs arg + | Icall_imm lbl -> fprintf ppf "call \"%s\" %a" lbl regs arg + | Itailcall_ind -> fprintf ppf "tailcall %a" regs arg + | Itailcall_imm lbl -> fprintf ppf "tailcall \"%s\" %a" lbl regs arg + | Iextcall(lbl, alloc) -> + fprintf ppf "extcall \"%s\" %a%s" lbl regs arg + (if not alloc then "" else " (noalloc)") + | Istackoffset n -> + fprintf ppf "offset stack %i" n + | Iload(chunk, addr) -> + fprintf ppf "%s[%a]" + (Printcmm.chunk chunk) (Arch.print_addressing reg addr) arg + | Istore(chunk, addr) -> + fprintf ppf "%s[%a] := %a" + (Printcmm.chunk chunk) + (Arch.print_addressing reg addr) + (Array.sub arg 1 (Array.length arg - 1)) + reg arg.(0) + | Ialloc n -> fprintf ppf "alloc %i" n + | Iintop(op) -> fprintf ppf "%a%s%a" reg arg.(0) (intop op) reg arg.(1) + | Iintop_imm(op, n) -> fprintf ppf "%a%s%i" reg arg.(0) (intop op) n + | Inegf -> fprintf ppf "-f %a" reg arg.(0) + | Iabsf -> fprintf ppf "absf %a" reg arg.(0) + | Iaddf -> fprintf ppf "%a +f %a" reg arg.(0) reg arg.(1) + | Isubf -> fprintf ppf "%a -f %a" reg arg.(0) reg arg.(1) + | Imulf -> fprintf ppf "%a *f %a" reg arg.(0) reg arg.(1) + | Idivf -> fprintf ppf "%a /f %a" reg arg.(0) reg arg.(1) + | Ifloatofint -> fprintf ppf "floatofint %a" reg arg.(0) + | Iintoffloat -> fprintf ppf "intoffloat %a" reg arg.(0) + | Ispecific op -> + Arch.print_specific_operation reg op ppf arg + +let rec instr ppf i = + if !print_live then begin + fprintf ppf "@[<1>{%a" regsetaddr i.live; + if Array.length i.arg > 0 then fprintf ppf "@ +@ %a" regs i.arg; + fprintf ppf "}@]@,"; + end; + begin match i.desc with + | Iend -> () + | Iop op -> + operation op i.arg ppf i.res + | Ireturn -> + fprintf ppf "return %a" regs i.arg + | Iifthenelse(tst, ifso, ifnot) -> + fprintf ppf "@[if %a then@,%a" (test tst) i.arg instr ifso; + begin match ifnot.desc with + | Iend -> () + | _ -> fprintf ppf "@;<0 -2>else@,%a" instr ifnot + end; + fprintf ppf "@;<0 -2>endif@]" + | Iswitch(index, cases) -> + fprintf ppf "switch %a" reg i.arg.(0); + for i = 0 to Array.length cases - 1 do + fprintf ppf "@,@[@["; + for j = 0 to Array.length index - 1 do + if index.(j) = i then fprintf ppf "case %i:@," j + done; + fprintf ppf "@]@,%a@]" instr cases.(i) + done; + fprintf ppf "@,endswitch" + | Iloop(body) -> + fprintf ppf "@[loop@,%a@;<0 -2>endloop@]" instr body + | Icatch(i, body, handler) -> + fprintf + ppf "@[catch@,%a@;<0 -2>with(%d)@,%a@;<0 -2>endcatch@]" + instr body i instr handler + | Iexit i -> + fprintf ppf "exit(%d)" i + | Itrywith(body, handler) -> + fprintf ppf "@[try@,%a@;<0 -2>with@,%a@;<0 -2>endtry@]" + instr body instr handler + | Iraise -> + fprintf ppf "raise %a" reg i.arg.(0) + end; + begin match i.next.desc with + Iend -> () + | _ -> fprintf ppf "@,%a" instr i.next + end + +let fundecl ppf f = + fprintf ppf "@[%s(%a)@,%a@]" + f.fun_name regs f.fun_args instr f.fun_body + +let phase msg ppf f = + fprintf ppf "*** %s@.%a@." msg fundecl f + +let interference ppf r = + let interf ppf = + List.iter + (fun r -> fprintf ppf "@ %a" reg r) + r.interf in + fprintf ppf "@[<2>%a:%t@]@." reg r interf + +let interferences ppf () = + fprintf ppf "*** Interferences@."; + List.iter (interference ppf) (Reg.all_registers()) + +let preference ppf r = + let prefs ppf = + List.iter + (fun (r, w) -> fprintf ppf "@ %a weight %i" reg r w) + r.prefer in + fprintf ppf "@[<2>%a: %t@]@." reg r prefs + +let preferences ppf () = + fprintf ppf "*** Preferences@."; + List.iter (preference ppf) (Reg.all_registers()) diff --git a/asmcomp/printmach.mli b/asmcomp/printmach.mli new file mode 100644 index 00000000..9dc483cd --- /dev/null +++ b/asmcomp/printmach.mli @@ -0,0 +1,31 @@ +(***********************************************************************) +(* *) +(* 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: printmach.mli,v 1.6 2000/04/21 08:10:37 weis Exp $ *) + +(* Pretty-printing of pseudo machine code *) + +open Format + +val reg: formatter -> Reg.t -> unit +val regs: formatter -> Reg.t array -> unit +val regset: formatter -> Reg.Set.t -> unit +val regsetaddr: formatter -> Reg.Set.t -> unit +val operation: Mach.operation -> Reg.t array -> formatter -> Reg.t array -> unit +val test: Mach.test -> formatter -> Reg.t array -> unit +val instr: formatter -> Mach.instruction -> unit +val fundecl: formatter -> Mach.fundecl -> unit +val phase: string -> formatter -> Mach.fundecl -> unit +val interferences: formatter -> unit -> unit +val preferences: formatter -> unit -> unit + +val print_live: bool ref diff --git a/asmcomp/proc.mli b/asmcomp/proc.mli new file mode 100644 index 00000000..f15f256b --- /dev/null +++ b/asmcomp/proc.mli @@ -0,0 +1,50 @@ +(***********************************************************************) +(* *) +(* 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: proc.mli,v 1.16 1999/11/17 18:56:35 xleroy Exp $ *) + +(* Processor descriptions *) + +(* Instruction selection *) +val word_addressed: bool + +(* Registers available for register allocation *) +val num_register_classes: int +val register_class: Reg.t -> int +val num_available_registers: int array +val first_available_register: int array +val register_name: int -> string +val phys_reg: int -> Reg.t +val rotate_registers: bool + +(* Calling conventions *) +val loc_arguments: Reg.t array -> Reg.t array * int +val loc_results: Reg.t array -> Reg.t array +val loc_parameters: Reg.t array -> Reg.t array +val loc_external_arguments: Reg.t array -> Reg.t array * int +val loc_external_results: Reg.t array -> Reg.t array +val loc_exn_bucket: Reg.t + +(* Maximal register pressures for pre-spilling *) +val safe_register_pressure: Mach.operation -> int +val max_register_pressure: Mach.operation -> int array + +(* Registers destroyed by operations *) +val destroyed_at_oper: Mach.instruction_desc -> Reg.t array +val destroyed_at_raise: Reg.t array + +(* Info for laying out the stack frame *) +val num_stack_slots: int array +val contains_calls: bool ref + +(* Calling the assembler *) +val assemble_file: string -> string -> int diff --git a/asmcomp/reg.ml b/asmcomp/reg.ml new file mode 100644 index 00000000..ab16c615 --- /dev/null +++ b/asmcomp/reg.ml @@ -0,0 +1,144 @@ +(***********************************************************************) +(* *) +(* 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: reg.ml,v 1.10 2000/06/29 11:44:06 xleroy Exp $ *) + +open Cmm + +type t = + { mutable name: string; + stamp: int; + typ: Cmm.machtype_component; + mutable loc: location; + mutable spill: bool; + mutable interf: t list; + mutable prefer: (t * int) list; + mutable degree: int; + mutable spill_cost: int; + mutable visited: bool } + +and location = + Unknown + | Reg of int + | Stack of stack_location + +and stack_location = + Local of int + | Incoming of int + | Outgoing of int + +type reg = t + +let dummy = + { name = ""; stamp = 0; typ = Int; loc = Unknown; spill = false; + interf = []; prefer = []; degree = 0; spill_cost = 0; visited = false } + +let currstamp = ref 0 +let reg_list = ref([] : t list) + +let create ty = + let r = { name = ""; stamp = !currstamp; typ = ty; loc = Unknown; + spill = false; interf = []; prefer = []; degree = 0; + spill_cost = 0; visited = false } in + reg_list := r :: !reg_list; + incr currstamp; + r + +let createv tyv = + let n = Array.length tyv in + let rv = Array.create n dummy in + for i = 0 to n-1 do rv.(i) <- create tyv.(i) done; + rv + +let clone r = + let nr = create r.typ in + nr.name <- r.name; + nr + +let at_location ty loc = + let r = { name = "R"; stamp = !currstamp; typ = ty; loc = loc; spill = false; + interf = []; prefer = []; degree = 0; spill_cost = 0; + visited = false } in + incr currstamp; + r + +let first_virtual_reg_stamp = ref (-1) + +let reset() = + (* When reset() is called for the first time, the current stamp reflects + all hard pseudo-registers that have been allocated by Proc, so + remember it and use it as the base stamp for allocating + soft pseudo-registers *) + if !first_virtual_reg_stamp = -1 then first_virtual_reg_stamp := !currstamp; + currstamp := !first_virtual_reg_stamp; + reg_list := [] + +let all_registers() = !reg_list +let num_registers() = !currstamp + +let reinit_reg r = + r.loc <- Unknown; + r.interf <- []; + r.prefer <- []; + r.degree <- 0; + (* Preserve the very high spill costs introduced by the reloading pass *) + if r.spill_cost >= 100000 + then r.spill_cost <- 100000 + else r.spill_cost <- 0 + +let reinit() = + List.iter reinit_reg !reg_list + +module RegOrder = + struct + type t = reg + let compare r1 r2 = r1.stamp - r2.stamp + end + +module Set = Set.Make(RegOrder) +module Map = Map.Make(RegOrder) + +let add_set_array s v = + match Array.length v with + 0 -> s + | 1 -> Set.add v.(0) s + | n -> let rec add_all i = + if i >= n then s else Set.add v.(i) (add_all(i+1)) + in add_all 0 + +let diff_set_array s v = + match Array.length v with + 0 -> s + | 1 -> Set.remove v.(0) s + | n -> let rec remove_all i = + if i >= n then s else Set.remove v.(i) (remove_all(i+1)) + in remove_all 0 + +let inter_set_array s v = + match Array.length v with + 0 -> Set.empty + | 1 -> if Set.mem v.(0) s + then Set.add v.(0) Set.empty + else Set.empty + | n -> let rec inter_all i = + if i >= n then Set.empty + else if Set.mem v.(i) s then Set.add v.(i) (inter_all(i+1)) + else inter_all(i+1) + in inter_all 0 + +let set_of_array v = + match Array.length v with + 0 -> Set.empty + | 1 -> Set.add v.(0) Set.empty + | n -> let rec add_all i = + if i >= n then Set.empty else Set.add v.(i) (add_all(i+1)) + in add_all 0 diff --git a/asmcomp/reg.mli b/asmcomp/reg.mli new file mode 100644 index 00000000..7d93612c --- /dev/null +++ b/asmcomp/reg.mli @@ -0,0 +1,56 @@ +(***********************************************************************) +(* *) +(* 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: reg.mli,v 1.7 1999/11/17 18:56:35 xleroy Exp $ *) + +(* Pseudo-registers *) + +type t = + { mutable name: string; (* Name (for printing) *) + stamp: int; (* Unique stamp *) + typ: Cmm.machtype_component; (* Type of contents *) + mutable loc: location; (* Actual location *) + mutable spill: bool; (* "true" to force stack allocation *) + mutable interf: t list; (* Other regs live simultaneously *) + mutable prefer: (t * int) list; (* Preferences for other regs *) + mutable degree: int; (* Number of other regs live sim. *) + mutable spill_cost: int; (* Estimate of spilling cost *) + mutable visited: bool } (* For graph walks *) + +and location = + Unknown + | Reg of int + | Stack of stack_location + +and stack_location = + Local of int + | Incoming of int + | Outgoing of int + +val dummy: t +val create: Cmm.machtype_component -> t +val createv: Cmm.machtype -> t array +val clone: t -> t +val at_location: Cmm.machtype_component -> location -> t + +module Set: Set.S with type elt = t +module Map: Map.S with type key = t + +val add_set_array: Set.t -> t array -> Set.t +val diff_set_array: Set.t -> t array -> Set.t +val inter_set_array: Set.t -> t array -> Set.t +val set_of_array: t array -> Set.t + +val reset: unit -> unit +val all_registers: unit -> t list +val num_registers: unit -> int +val reinit: unit -> unit diff --git a/asmcomp/reload.mli b/asmcomp/reload.mli new file mode 100644 index 00000000..11c8c047 --- /dev/null +++ b/asmcomp/reload.mli @@ -0,0 +1,18 @@ +(***********************************************************************) +(* *) +(* 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: reload.mli,v 1.6 1999/11/17 18:56:35 xleroy Exp $ *) + +(* Insert load/stores for pseudoregs that got assigned to stack locations. *) + +val fundecl: Mach.fundecl -> Mach.fundecl * bool + diff --git a/asmcomp/reloadgen.ml b/asmcomp/reloadgen.ml new file mode 100644 index 00000000..1600f18f --- /dev/null +++ b/asmcomp/reloadgen.ml @@ -0,0 +1,140 @@ +(***********************************************************************) +(* *) +(* 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: reloadgen.ml,v 1.5 2000/08/11 19:50:55 maranget Exp $ *) + +(* Insert load/stores for pseudoregs that got assigned to stack locations. *) + +open Misc +open Reg +open Mach + +let access_stack r = + try + for i = 0 to Array.length r - 1 do + match r.(i).loc with Stack _ -> raise Exit | _ -> () + done; + false + with Exit -> + true + +let insert_move src dst next = + if src.loc = dst.loc + then next + else instr_cons (Iop Imove) [|src|] [|dst|] next + +let insert_moves src dst next = + let rec insmoves i = + if i >= Array.length src + then next + else insert_move src.(i) dst.(i) (insmoves (i+1)) + in insmoves 0 + +class reload_generic = object (self) + +val mutable redo_regalloc = false + +method makereg r = + match r.loc with + Unknown -> fatal_error "Reload.makereg" + | Reg _ -> r + | Stack _ -> + redo_regalloc <- true; + let newr = Reg.clone r in + (* Strongly discourage spilling this register *) + newr.spill_cost <- 100000; + newr + +method private makeregs rv = + let n = Array.length rv in + let newv = Array.create n Reg.dummy in + for i = 0 to n-1 do newv.(i) <- self#makereg rv.(i) done; + newv + +method private makereg1 rv = + let newv = Array.copy rv in + newv.(0) <- self#makereg rv.(0); + newv + +method reload_operation op arg res = + (* By default, assume that arguments and results must reside + in hardware registers. For moves, allow one arg or one + res to be stack-allocated, but do something for + stack-to-stack moves *) + match op with + Imove | Ireload | Ispill -> + begin match arg.(0), res.(0) with + {loc = Stack s1}, {loc = Stack s2} when s1 <> s2 -> + ([| self#makereg arg.(0) |], res) + | _ -> + (arg, res) + end + | _ -> + (self#makeregs arg, self#makeregs res) + +method reload_test tst args = + self#makeregs args + +method private reload i = + match i.desc with + (* For function calls, returns, etc: the arguments and results are + already at the correct position (e.g. on stack for some arguments). + However, something needs to be done for the function pointer in + indirect calls. *) + Iend | Ireturn | Iop(Itailcall_imm _) | Iraise -> i + | Iop(Itailcall_ind) -> + let newarg = self#makereg1 i.arg in + insert_moves i.arg newarg + (instr_cons_live i.desc newarg i.res i.live i.next) + | Iop(Icall_imm _ | Iextcall(_, _)) -> + instr_cons_live i.desc i.arg i.res i.live (self#reload i.next) + | Iop(Icall_ind) -> + let newarg = self#makereg1 i.arg in + insert_moves i.arg newarg + (instr_cons_live i.desc newarg i.res i.live (self#reload i.next)) + | Iop op -> + let (newarg, newres) = self#reload_operation op i.arg i.res in + insert_moves i.arg newarg + (instr_cons_live i.desc newarg newres i.live + (insert_moves newres i.res + (self#reload i.next))) + | Iifthenelse(tst, ifso, ifnot) -> + let newarg = self#reload_test tst i.arg in + insert_moves i.arg newarg + (instr_cons + (Iifthenelse(tst, self#reload ifso, self#reload ifnot)) newarg [||] + (self#reload i.next)) + | Iswitch(index, cases) -> + let newarg = self#makeregs i.arg in + insert_moves i.arg newarg + (instr_cons (Iswitch(index, Array.map (self#reload) cases)) newarg [||] + (self#reload i.next)) + | Iloop body -> + instr_cons (Iloop(self#reload body)) [||] [||] (self#reload i.next) + | Icatch(nfail, body, handler) -> + instr_cons + (Icatch(nfail, self#reload body, self#reload handler)) [||] [||] + (self#reload i.next) + | Iexit i -> + instr_cons (Iexit i) [||] [||] dummy_instr + | Itrywith(body, handler) -> + instr_cons (Itrywith(self#reload body, self#reload handler)) [||] [||] + (self#reload i.next) + +method fundecl f = + redo_regalloc <- false; + let new_body = self#reload f.fun_body in + ({fun_name = f.fun_name; fun_args = f.fun_args; + fun_body = new_body; fun_fast = f.fun_fast}, + redo_regalloc) + +end diff --git a/asmcomp/reloadgen.mli b/asmcomp/reloadgen.mli new file mode 100644 index 00000000..febb9367 --- /dev/null +++ b/asmcomp/reloadgen.mli @@ -0,0 +1,26 @@ +(***********************************************************************) +(* *) +(* 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: reloadgen.mli,v 1.4 1999/11/17 18:56:36 xleroy Exp $ *) + +class reload_generic : object + method reload_operation : + Mach.operation -> Reg.t array -> Reg.t array -> Reg.t array * Reg.t array + method reload_test : Mach.test -> Reg.t array -> Reg.t array + (* Can be overriden to reflect instructions that can operate + directly on stack locations *) + method makereg : Reg.t -> Reg.t + (* Can be overriden to avoid creating new registers of some class + (i.e. if all "registers" of that class are actually on stack) *) + method fundecl : Mach.fundecl -> Mach.fundecl * bool + (* The entry point *) +end diff --git a/asmcomp/schedgen.ml b/asmcomp/schedgen.ml new file mode 100644 index 00000000..1ba7726c --- /dev/null +++ b/asmcomp/schedgen.ml @@ -0,0 +1,358 @@ +(***********************************************************************) +(* *) +(* 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: schedgen.ml,v 1.10 2000/12/28 13:02:54 weis Exp $ *) + +(* Instruction scheduling *) + +open Misc +open Reg +open Mach +open Linearize + +(* Representation of the code DAG. *) + +type code_dag_node = + { instr: instruction; (* The instruction *) + delay: int; (* How many cycles before result is available *) + mutable sons: (code_dag_node * int) list; + (* Instructions that depend on it *) + mutable date: int; (* Start date *) + mutable length: int; (* Length of longest path to result *) + mutable ancestors: int; (* Number of ancestors *) + mutable emitted_ancestors: int } (* Number of emitted ancestors *) + +let dummy_node = + { instr = end_instr; delay = 0; sons = []; date = 0; + length = -1; ancestors = 0; emitted_ancestors = 0 } + +(* The code dag itself is represented by two tables from registers to nodes: + - "results" maps registers to the instructions that produced them; + - "uses" maps registers to the instructions that use them. + In addition: + - code_stores contains the latest store nodes emitted so far + - code_loads contains all load nodes emitted since the last store + - code_checkbounds contains the latest checkbound node not matched + by a subsequent load or store. *) + +let code_results = (Hashtbl.create 31 : (location, code_dag_node) Hashtbl.t) +let code_uses = (Hashtbl.create 31 : (location, code_dag_node) Hashtbl.t) +let code_stores = ref ([] : code_dag_node list) +let code_loads = ref ([] : code_dag_node list) +let code_checkbounds = ref ([] : code_dag_node list) + +let clear_code_dag () = + Hashtbl.clear code_results; + Hashtbl.clear code_uses; + code_stores := []; + code_loads := []; + code_checkbounds := [] + +(* Add an edge to the code DAG *) + +let add_edge ancestor son delay = + ancestor.sons <- (son, delay) :: ancestor.sons; + son.ancestors <- son.ancestors + 1 + +let add_edge_after son ancestor = add_edge ancestor son 0 + +(* Compute length of longest path to a result. + For leafs of the DAG, see whether their result is used in the instruction + immediately following the basic block (a "critical" output). *) + +let is_critical critical_outputs results = + try + for i = 0 to Array.length results - 1 do + let r = results.(i).loc in + for j = 0 to Array.length critical_outputs - 1 do + if critical_outputs.(j).loc = r then raise Exit + done + done; + false + with Exit -> + true + +let rec longest_path critical_outputs node = + if node.length < 0 then begin + match node.sons with + [] -> + node.length <- + if is_critical critical_outputs node.instr.res + || node.instr.desc = Lreloadretaddr (* alway critical *) + then node.delay + else 0 + | sons -> + node.length <- + List.fold_left + (fun len (son, delay) -> + max len (longest_path critical_outputs son + delay)) + 0 sons + end; + node.length + +(* Remove an instruction from the ready queue *) + +let rec remove_instr node = function + [] -> [] + | instr :: rem -> + if instr == node then rem else instr :: remove_instr node rem + +(* We treat Lreloadretaddr as a word-sized load *) + +let some_load = (Iload(Cmm.Word, Arch.identity_addressing)) + +(* The generic scheduler *) + +class virtual scheduler_generic = object (self) + +(* Determine whether an operation ends a basic block or not. + Can be overriden for some processors to signal specific instructions + that terminate a basic block. *) + +method oper_in_basic_block = function + Icall_ind -> false + | Icall_imm _ -> false + | Itailcall_ind -> false + | Itailcall_imm _ -> false + | Iextcall(_, _) -> false + | Istackoffset _ -> false + | Ialloc _ -> false + | _ -> true + +(* Determine whether an instruction ends a basic block or not *) + +method private instr_in_basic_block instr = + match instr.desc with + Lop op -> self#oper_in_basic_block op + | Lreloadretaddr -> true + | _ -> false + +(* Determine whether an operation is a memory store or a memory load. + Can be overriden for some processors to signal specific + load or store instructions (e.g. on the I386). *) + +method is_store = function + Istore(_, _) -> true + | _ -> false + +method is_load = function + Iload(_, _) -> true + | _ -> false + +method is_checkbound = function + Iintop Icheckbound -> true + | Iintop_imm(Icheckbound, _) -> true + | _ -> false + +method private instr_is_store instr = + match instr.desc with + Lop op -> self#is_store op + | _ -> false + +method private instr_is_load instr = + match instr.desc with + Lop op -> self#is_load op + | _ -> false + +method private instr_is_checkbound instr = + match instr.desc with + Lop op -> self#is_checkbound op + | _ -> false + +(* Estimate the latency of an operation. *) + +method virtual oper_latency : Mach.operation -> int + +(* Estimate the latency of a Lreloadretaddr operation. *) + +method reload_retaddr_latency = self#oper_latency some_load + +(* Estimate the delay needed to evaluate an instruction *) + +method private instr_latency instr = + match instr.desc with + Lop op -> self#oper_latency op + | Lreloadretaddr -> self#reload_retaddr_latency + | _ -> assert false + +(* Estimate the number of cycles consumed by emitting an operation. *) + +method virtual oper_issue_cycles : Mach.operation -> int + +(* Estimate the number of cycles consumed by emitting a Lreloadretaddr. *) + +method reload_retaddr_issue_cycles = self#oper_issue_cycles some_load + +(* Estimate the number of cycles consumed by emitting an instruction. *) + +method private instr_issue_cycles instr = + match instr.desc with + Lop op -> self#oper_issue_cycles op + | Lreloadretaddr -> self#reload_retaddr_issue_cycles + | _ -> assert false + +(* Add an instruction to the code dag *) + +method private add_instruction ready_queue instr = + let delay = self#instr_latency instr in + let node = + { instr = instr; + delay = delay; + sons = []; + date = 0; + length = -1; + ancestors = 0; + emitted_ancestors = 0 } in + (* Add edges from all instructions that define one of the registers used + (RAW dependencies) *) + for i = 0 to Array.length instr.arg - 1 do + try + let ancestor = Hashtbl.find code_results instr.arg.(i).loc in + add_edge ancestor node ancestor.delay + with Not_found -> + () + done; + (* Also add edges from all instructions that use one of the result regs + of this instruction (WAR dependencies). *) + for i = 0 to Array.length instr.res - 1 do + let ancestors = Hashtbl.find_all code_uses instr.res.(i).loc in + List.iter (add_edge_after node) ancestors + done; + (* Also add edges from all instructions that have already defined one + of the results of this instruction (WAW dependencies). *) + for i = 0 to Array.length instr.res - 1 do + try + let ancestor = Hashtbl.find code_results instr.res.(i).loc in + add_edge ancestor node 0 + with Not_found -> + () + done; + (* If this is a load, add edges from the most recent store viewed so + far (if any) and remember the load. Also add edges from the most + recent checkbound and forget that checkbound. *) + if self#instr_is_load instr then begin + List.iter (add_edge_after node) !code_stores; + code_loads := node :: !code_loads; + List.iter (add_edge_after node) !code_checkbounds; + code_checkbounds := [] + end + (* If this is a store, add edges from the most recent store, + as well as all loads viewed since then, and also the most recent + checkbound. Remember the store, + discarding the previous stores, loads and checkbounds. *) + else if self#instr_is_store instr then begin + List.iter (add_edge_after node) !code_stores; + List.iter (add_edge_after node) !code_loads; + List.iter (add_edge_after node) !code_checkbounds; + code_stores := [node]; + code_loads := []; + code_checkbounds := [] + end + else if self#instr_is_checkbound instr then begin + code_checkbounds := [node] + end; + (* Remember the registers used and produced by this instruction *) + for i = 0 to Array.length instr.res - 1 do + Hashtbl.add code_results instr.res.(i).loc node + done; + for i = 0 to Array.length instr.arg - 1 do + Hashtbl.add code_uses instr.arg.(i).loc node + done; + (* If this is a root instruction (all arguments already computed), + add it to the ready queue *) + if node.ancestors = 0 then node :: ready_queue else ready_queue + +(* Given a list of instructions and a date, choose one or several + that are ready to be computed (start date <= current date) + and that we can emit in one cycle. Favor instructions with + maximal distance to result. If we can't find any, return None. + This does not take multiple issues into account, though. *) + +method private ready_instruction date queue = + let rec extract best = function + [] -> + if best == dummy_node then None else Some best + | instr :: rem -> + let new_best = + if instr.date <= date && instr.length > best.length + then instr else best in + extract new_best rem in + extract dummy_node queue + +(* Schedule a basic block, adding its instructions in front of the given + instruction sequence *) + +method private reschedule ready_queue date cont = + if ready_queue = [] then cont else begin + match self#ready_instruction date ready_queue with + None -> + self#reschedule ready_queue (date + 1) cont + | Some node -> + (* Remove node from queue *) + let new_queue = ref (remove_instr node ready_queue) in + (* Update the start date and number of ancestors emitted of + all descendents of this node. Enter those that become ready + in the queue. *) + let issue_cycles = self#instr_issue_cycles node.instr in + List.iter + (fun (son, delay) -> + let completion_date = date + issue_cycles + delay - 1 in + if son.date < completion_date then son.date <- completion_date; + son.emitted_ancestors <- son.emitted_ancestors + 1; + if son.emitted_ancestors = son.ancestors then + new_queue := son :: !new_queue) + node.sons; + instr_cons node.instr.desc node.instr.arg node.instr.res + (self#reschedule !new_queue (date + issue_cycles) cont) + end + +(* Entry point *) +(* Don't bother to schedule for initialization code and the like. *) + +method schedule_fundecl f = + + let rec schedule i = + match i.desc with + Lend -> i + | _ -> + if self#instr_in_basic_block i then begin + clear_code_dag(); + schedule_block [] i + end else + { desc = i.desc; arg = i.arg; res = i.res; live = i.live; + next = schedule i.next } + + and schedule_block ready_queue i = + if self#instr_in_basic_block i then + schedule_block (self#add_instruction ready_queue i) i.next + else begin + let critical_outputs = + match i.desc with + Lop(Icall_ind | Itailcall_ind) -> [| i.arg.(0) |] + | Lop(Icall_imm _ | Itailcall_imm _ | Iextcall(_, _)) -> [||] + | Lreturn -> [||] + | _ -> i.arg in + List.iter (fun x -> let len = longest_path critical_outputs x in ()) + ready_queue; + self#reschedule ready_queue 0 (schedule i) + end in + + if f.fun_fast then begin + let new_body = schedule f.fun_body in + clear_code_dag(); + { fun_name = f.fun_name; + fun_body = new_body; + fun_fast = f.fun_fast } + end else + f + +end diff --git a/asmcomp/schedgen.mli b/asmcomp/schedgen.mli new file mode 100644 index 00000000..8c651548 --- /dev/null +++ b/asmcomp/schedgen.mli @@ -0,0 +1,46 @@ +(***********************************************************************) +(* *) +(* 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: schedgen.mli,v 1.6 1999/11/17 18:56:36 xleroy Exp $ *) + +(* Instruction scheduling *) + +type code_dag_node = + { instr: Linearize.instruction; + delay: int; + mutable sons: (code_dag_node * int) list; + mutable date: int; + mutable length: int; + mutable ancestors: int; + mutable emitted_ancestors: int } + +class virtual scheduler_generic : object + (* Can be overriden by processor description *) + method virtual oper_issue_cycles : Mach.operation -> int + (* Number of cycles needed to issue the given operation *) + method virtual oper_latency : Mach.operation -> int + (* Number of cycles needed to complete the given operation *) + method reload_retaddr_issue_cycles : int + (* Number of cycles needed to issue a Lreloadretaddr operation *) + method reload_retaddr_latency : int + (* Number of cycles needed to complete a Lreloadretaddr operation *) + method oper_in_basic_block : Mach.operation -> bool + (* Says whether the given operation terminates a basic block *) + method is_store : Mach.operation -> bool + (* Says whether the given operation is a memory store *) + method is_load : Mach.operation -> bool + (* Says whether the given operation is a memory load *) + method is_checkbound : Mach.operation -> bool + (* Says whether the given operation is a checkbound *) + (* Entry point *) + method schedule_fundecl : Linearize.fundecl -> Linearize.fundecl +end diff --git a/asmcomp/scheduling.mli b/asmcomp/scheduling.mli new file mode 100644 index 00000000..aef1f413 --- /dev/null +++ b/asmcomp/scheduling.mli @@ -0,0 +1,17 @@ +(***********************************************************************) +(* *) +(* 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: scheduling.mli,v 1.3 1999/11/17 18:56:36 xleroy Exp $ *) + +(* Instruction scheduling *) + +val fundecl: Linearize.fundecl -> Linearize.fundecl diff --git a/asmcomp/selectgen.ml b/asmcomp/selectgen.ml new file mode 100644 index 00000000..1fd62479 --- /dev/null +++ b/asmcomp/selectgen.ml @@ -0,0 +1,821 @@ +(***********************************************************************) +(* *) +(* 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: selectgen.ml,v 1.30 2003/02/25 15:50:12 xleroy Exp $ *) + +(* Selection of pseudo-instructions, assignment of pseudo-registers, + sequentialization. *) + +open Misc +open Cmm +open Reg +open Mach + +type environment = (Ident.t, Reg.t array) Tbl.t + +(* Infer the type of the result of an operation *) + +let oper_result_type = function + Capply ty -> ty + | Cextcall(s, ty, alloc) -> ty + | Cload c -> + begin match c with + Word -> typ_addr + | Single | Double | Double_u -> typ_float + | _ -> typ_int + end + | Calloc -> typ_addr + | Cstore c -> typ_void + | Caddi | Csubi | Cmuli | Cdivi | Cmodi | + Cand | Cor | Cxor | Clsl | Clsr | Casr | + Ccmpi _ | Ccmpa _ | Ccmpf _ -> typ_int + | Cadda | Csuba -> typ_addr + | Cnegf | Cabsf | Caddf | Csubf | Cmulf | Cdivf -> typ_float + | Cfloatofint -> typ_float + | Cintoffloat -> typ_int + | Craise -> typ_void + | Ccheckbound -> typ_void + +(* Infer the size in bytes of the result of a simple expression *) + +let size_expr env exp = + let rec size localenv = function + Cconst_int _ | Cconst_natint _ -> Arch.size_int + | Cconst_symbol _ | Cconst_pointer _ | Cconst_natpointer _ -> + Arch.size_addr + | Cconst_float _ -> Arch.size_float + | Cvar id -> + begin try + Tbl.find id localenv + with Not_found -> + try + let regs = Tbl.find id env in + size_machtype (Array.map (fun r -> r.typ) regs) + with Not_found -> + fatal_error("Selection.size_expr: unbound var " ^ + Ident.unique_name id) + end + | Ctuple el -> + List.fold_right (fun e sz -> size localenv e + sz) el 0 + | Cop(op, args) -> + size_machtype(oper_result_type op) + | Clet(id, arg, body) -> + size (Tbl.add id (size localenv arg) localenv) body + | Csequence(e1, e2) -> + size localenv e2 + | _ -> + fatal_error "Selection.size_expr" + in size Tbl.empty exp + +(* These are C library functions that are known to be pure + (no side effects at all) and worth not pre-computing. *) + +let pure_external_functions = + ["acos"; "asin"; "atan"; "atan2"; "cos"; "exp"; "log"; + "log10"; "sin"; "sqrt"; "tan"] + +(* Says if an expression is "simple". A "simple" expression has no + side-effects and its execution can be delayed until its value + is really needed. In the case of e.g. an [alloc] instruction, + the non-simple arguments are computed in right-to-left order + first, then the block is allocated, then the simple arguments are + evaluated and stored. *) + +let rec is_simple_expr = function + Cconst_int _ -> true + | Cconst_natint _ -> true + | Cconst_float _ -> true + | Cconst_symbol _ -> true + | Cconst_pointer _ -> true + | Cconst_natpointer _ -> true + | Cvar _ -> true + | Ctuple el -> List.for_all is_simple_expr el + | Clet(id, arg, body) -> is_simple_expr arg && is_simple_expr body + | Csequence(e1, e2) -> is_simple_expr e1 && is_simple_expr e2 + | Cop(op, args) -> + begin match op with + (* The following may have side effects *) + | Capply _ | Calloc | Cstore _ | Craise -> false + (* External C functions normally have side effects, unless known *) + | Cextcall(fn, _, alloc) -> + not alloc && + List.mem fn pure_external_functions && + List.for_all is_simple_expr args + (* The remaining operations are simple if their args are *) + | _ -> + List.for_all is_simple_expr args + end + | _ -> false + +(* Swap the two arguments of an integer comparison *) + +let swap_intcomp = function + Isigned cmp -> Isigned(swap_comparison cmp) + | Iunsigned cmp -> Iunsigned(swap_comparison cmp) + +(* Naming of registers *) + +let all_regs_anonymous rv = + try + for i = 0 to Array.length rv - 1 do + if String.length rv.(i).name > 0 then raise Exit + done; + true + with Exit -> + false + +let name_regs id rv = + if Array.length rv = 1 then + rv.(0).name <- Ident.name id + else + for i = 0 to Array.length rv - 1 do + rv.(i).name <- Ident.name id ^ "#" ^ string_of_int i + done + +(* "Join" two instruction sequences, making sure they return their results + in the same registers. *) + +let join opt_r1 seq1 opt_r2 seq2 = + match (opt_r1, opt_r2) with + (None, _) -> opt_r2 + | (_, None) -> opt_r1 + | (Some r1, Some r2) -> + let l1 = Array.length r1 in + assert (l1 = Array.length r2); + let r = Array.create l1 Reg.dummy in + for i = 0 to l1-1 do + if String.length r1.(i).name = 0 then begin + r.(i) <- r1.(i); + seq2#insert_move r2.(i) r1.(i) + end else if String.length r2.(i).name = 0 then begin + r.(i) <- r2.(i); + seq1#insert_move r1.(i) r2.(i) + end else begin + r.(i) <- Reg.create r1.(i).typ; + seq1#insert_move r1.(i) r.(i); + seq2#insert_move r2.(i) r.(i) + end + done; + Some r + +(* Same, for N branches *) + +let join_array rs = + let some_res = ref None in + for i = 0 to Array.length rs - 1 do + let (r, s) = rs.(i) in + if r <> None then some_res := r + done; + match !some_res with + None -> None + | Some template -> + let size_res = Array.length template in + let res = Array.create size_res Reg.dummy in + for i = 0 to size_res - 1 do + res.(i) <- Reg.create template.(i).typ + done; + for i = 0 to Array.length rs - 1 do + let (r, s) = rs.(i) in + match r with + None -> () + | Some r -> s#insert_moves r res + done; + Some res + +(* Registers for catch constructs *) +let catch_regs = ref [] + +(* Name of function being compiled *) +let current_function_name = ref "" + +(* The default instruction selection class *) + +class virtual selector_generic = object (self) + +(* Says whether an integer constant is a suitable immediate argument *) + +method virtual is_immediate : int -> bool + +(* Selection of addressing modes *) + +method virtual select_addressing : + Cmm.expression -> Arch.addressing_mode * Cmm.expression + +(* Default instruction selection for stores (of words) *) + +method select_store addr arg = + (Istore(Word, addr), arg) + +(* Default instruction selection for operators *) + +method select_operation op args = + match (op, args) with + (Capply ty, Cconst_symbol s :: rem) -> (Icall_imm s, rem) + | (Capply ty, _) -> (Icall_ind, args) + | (Cextcall(s, ty, alloc), _) -> (Iextcall(s, alloc), args) + | (Cload chunk, [arg]) -> + let (addr, eloc) = self#select_addressing arg in + (Iload(chunk, addr), [eloc]) + | (Cstore chunk, [arg1; arg2]) -> + let (addr, eloc) = self#select_addressing arg1 in + if chunk = Word then begin + let (op, newarg2) = self#select_store addr arg2 in + (op, [newarg2; eloc]) + end else begin + (Istore(chunk, addr), [arg2; eloc]) + (* Inversion addr/datum in Istore *) + end + | (Calloc, _) -> (Ialloc 0, args) + | (Caddi, _) -> self#select_arith_comm Iadd args + | (Csubi, _) -> self#select_arith Isub args + | (Cmuli, [arg1; Cconst_int n]) -> + let l = Misc.log2 n in + if n = 1 lsl l + then (Iintop_imm(Ilsl, l), [arg1]) + else self#select_arith_comm Imul args + | (Cmuli, [Cconst_int n; arg1]) -> + let l = Misc.log2 n in + if n = 1 lsl l + then (Iintop_imm(Ilsl, l), [arg1]) + else self#select_arith_comm Imul args + | (Cmuli, _) -> self#select_arith_comm Imul args + | (Cdivi, _) -> self#select_arith Idiv args + | (Cmodi, _) -> self#select_arith_comm Imod args + | (Cand, _) -> self#select_arith_comm Iand args + | (Cor, _) -> self#select_arith_comm Ior args + | (Cxor, _) -> self#select_arith_comm Ixor args + | (Clsl, _) -> self#select_shift Ilsl args + | (Clsr, _) -> self#select_shift Ilsr args + | (Casr, _) -> self#select_shift Iasr args + | (Ccmpi comp, _) -> self#select_arith_comp (Isigned comp) args + | (Cadda, _) -> self#select_arith_comm Iadd args + | (Csuba, _) -> self#select_arith Isub args + | (Ccmpa comp, _) -> self#select_arith_comp (Iunsigned comp) args + | (Cnegf, _) -> (Inegf, args) + | (Cabsf, _) -> (Iabsf, args) + | (Caddf, _) -> (Iaddf, args) + | (Csubf, _) -> (Isubf, args) + | (Cmulf, _) -> (Imulf, args) + | (Cdivf, _) -> (Idivf, args) + | (Cfloatofint, _) -> (Ifloatofint, args) + | (Cintoffloat, _) -> (Iintoffloat, args) + | (Ccheckbound, _) -> self#select_arith Icheckbound args + | _ -> fatal_error "Selection.select_oper" + +method private select_arith_comm op = function + [arg; Cconst_int n] when self#is_immediate n -> + (Iintop_imm(op, n), [arg]) + | [arg; Cconst_pointer n] when self#is_immediate n -> + (Iintop_imm(op, n), [arg]) + | [Cconst_int n; arg] when self#is_immediate n -> + (Iintop_imm(op, n), [arg]) + | [Cconst_pointer n; arg] when self#is_immediate n -> + (Iintop_imm(op, n), [arg]) + | args -> + (Iintop op, args) + +method private select_arith op = function + [arg; Cconst_int n] when self#is_immediate n -> + (Iintop_imm(op, n), [arg]) + | [arg; Cconst_pointer n] when self#is_immediate n -> + (Iintop_imm(op, n), [arg]) + | args -> + (Iintop op, args) + +method private select_shift op = function + [arg; Cconst_int n] when n >= 0 && n < Arch.size_int * 8 -> + (Iintop_imm(op, n), [arg]) + | args -> + (Iintop op, args) + +method private select_arith_comp cmp = function + [arg; Cconst_int n] when self#is_immediate n -> + (Iintop_imm(Icomp cmp, n), [arg]) + | [arg; Cconst_pointer n] when self#is_immediate n -> + (Iintop_imm(Icomp cmp, n), [arg]) + | [Cconst_int n; arg] when self#is_immediate n -> + (Iintop_imm(Icomp(swap_intcomp cmp), n), [arg]) + | [Cconst_pointer n; arg] when self#is_immediate n -> + (Iintop_imm(Icomp(swap_intcomp cmp), n), [arg]) + | args -> + (Iintop(Icomp cmp), args) + +(* Instruction selection for conditionals *) + +method select_condition = function + Cop(Ccmpi cmp, [arg1; Cconst_int n]) when self#is_immediate n -> + (Iinttest_imm(Isigned cmp, n), arg1) + | Cop(Ccmpi cmp, [Cconst_int n; arg2]) when self#is_immediate n -> + (Iinttest_imm(Isigned(swap_comparison cmp), n), arg2) + | Cop(Ccmpi cmp, [arg1; Cconst_pointer n]) when self#is_immediate n -> + (Iinttest_imm(Isigned cmp, n), arg1) + | Cop(Ccmpi cmp, [Cconst_pointer n; arg2]) when self#is_immediate n -> + (Iinttest_imm(Isigned(swap_comparison cmp), n), arg2) + | Cop(Ccmpi cmp, args) -> + (Iinttest(Isigned cmp), Ctuple args) + | Cop(Ccmpa cmp, [arg1; Cconst_pointer n]) when self#is_immediate n -> + (Iinttest_imm(Iunsigned cmp, n), arg1) + | Cop(Ccmpa cmp, [arg1; Cconst_int n]) when self#is_immediate n -> + (Iinttest_imm(Iunsigned cmp, n), arg1) + | Cop(Ccmpa cmp, [Cconst_pointer n; arg2]) when self#is_immediate n -> + (Iinttest_imm(Iunsigned(swap_comparison cmp), n), arg2) + | Cop(Ccmpa cmp, [Cconst_int n; arg2]) when self#is_immediate n -> + (Iinttest_imm(Iunsigned(swap_comparison cmp), n), arg2) + | Cop(Ccmpa cmp, args) -> + (Iinttest(Iunsigned cmp), Ctuple args) + | Cop(Ccmpf cmp, args) -> + (Ifloattest(cmp, false), Ctuple args) + | Cop(Cand, [arg; Cconst_int 1]) -> + (Ioddtest, arg) + | arg -> + (Itruetest, arg) + +(* Buffering of instruction sequences *) + +val mutable instr_seq = dummy_instr + +method insert desc arg res = + instr_seq <- instr_cons desc arg res instr_seq + +method extract = + let rec extract res i = + if i == dummy_instr + then res + else extract (instr_cons i.desc i.arg i.res res) i.next in + extract (end_instr()) instr_seq + +(* Insert a sequence of moves from one pseudoreg set to another. *) + +method insert_move src dst = + if src.stamp <> dst.stamp then + self#insert (Iop Imove) [|src|] [|dst|] + +method insert_moves src dst = + for i = 0 to Array.length src - 1 do + self#insert_move src.(i) dst.(i) + done + +(* Insert moves and stack offsets for function arguments and results *) + +method insert_move_args arg loc stacksize = + if stacksize <> 0 then self#insert (Iop(Istackoffset stacksize)) [||] [||]; + self#insert_moves arg loc + +method insert_move_results loc res stacksize = + if stacksize <> 0 then self#insert(Iop(Istackoffset(-stacksize))) [||] [||]; + self#insert_moves loc res + +(* Add an Iop opcode. Can be overriden by processor description + to insert moves before and after the operation, i.e. for two-address + instructions, or instructions using dedicated registers. *) + +method insert_op op rs rd = + self#insert (Iop op) rs rd; + rd + +(* Add the instructions for the given expression + at the end of the self sequence *) + +method emit_expr env exp = + match exp with + Cconst_int n -> + let r = Reg.createv typ_int in + Some(self#insert_op (Iconst_int(Nativeint.of_int n)) [||] r) + | Cconst_natint n -> + let r = Reg.createv typ_int in + Some(self#insert_op (Iconst_int n) [||] r) + | Cconst_float n -> + let r = Reg.createv typ_float in + Some(self#insert_op (Iconst_float n) [||] r) + | Cconst_symbol n -> + let r = Reg.createv typ_addr in + Some(self#insert_op (Iconst_symbol n) [||] r) + | Cconst_pointer n -> + let r = Reg.createv typ_addr in + Some(self#insert_op (Iconst_int(Nativeint.of_int n)) [||] r) + | Cconst_natpointer n -> + let r = Reg.createv typ_addr in + Some(self#insert_op (Iconst_int n) [||] r) + | Cvar v -> + begin try + Some(Tbl.find v env) + with Not_found -> + fatal_error("Selection.emit_expr: unbound var " ^ Ident.unique_name v) + end + | Clet(v, e1, e2) -> + begin match self#emit_expr env e1 with + None -> None + | Some r1 -> self#emit_expr (self#bind_let env v r1) e2 + end + | Cassign(v, e1) -> + let rv = + try + Tbl.find v env + with Not_found -> + fatal_error ("Selection.emit_expr: unbound var " ^ Ident.name v) in + begin match self#emit_expr env e1 with + None -> None + | Some r1 -> self#insert_moves r1 rv; Some [||] + end + | Ctuple [] -> + Some [||] + | Ctuple exp_list -> + begin match self#emit_parts_list env exp_list with + None -> None + | Some(simple_list, ext_env) -> + Some(self#emit_tuple ext_env simple_list) + end + | Cop(Craise, [arg]) -> + begin match self#emit_expr env arg with + None -> None + | Some r1 -> + let rd = [|Proc.loc_exn_bucket|] in + self#insert (Iop Imove) r1 rd; + self#insert Iraise rd [||]; + None + end + | Cop(Ccmpf comp, args) -> + self#emit_expr env (Cifthenelse(exp, Cconst_int 1, Cconst_int 0)) + | Cop(op, args) -> + begin match self#emit_parts_list env args with + None -> None + | Some(simple_args, env) -> + let ty = oper_result_type op in + let (new_op, new_args) = self#select_operation op simple_args in + match new_op with + Icall_ind -> + Proc.contains_calls := true; + let r1 = self#emit_tuple env new_args in + let rarg = Array.sub r1 1 (Array.length r1 - 1) in + let rd = Reg.createv ty in + let (loc_arg, stack_ofs) = Proc.loc_arguments rarg in + let loc_res = Proc.loc_results rd in + self#insert_move_args rarg loc_arg stack_ofs; + self#insert (Iop Icall_ind) + (Array.append [|r1.(0)|] loc_arg) loc_res; + self#insert_move_results loc_res rd stack_ofs; + Some rd + | Icall_imm lbl -> + Proc.contains_calls := true; + let r1 = self#emit_tuple env new_args in + let rd = Reg.createv ty in + let (loc_arg, stack_ofs) = Proc.loc_arguments r1 in + let loc_res = Proc.loc_results rd in + self#insert_move_args r1 loc_arg stack_ofs; + self#insert (Iop(Icall_imm lbl)) loc_arg loc_res; + self#insert_move_results loc_res rd stack_ofs; + Some rd + | Iextcall(lbl, alloc) -> + Proc.contains_calls := true; + let (loc_arg, stack_ofs) = + self#emit_extcall_args env new_args in + let rd = Reg.createv ty in + let loc_res = Proc.loc_external_results rd in + self#insert (Iop(Iextcall(lbl, alloc))) loc_arg loc_res; + self#insert_move_results loc_res rd stack_ofs; + Some rd + | Ialloc _ -> + Proc.contains_calls := true; + let rd = Reg.createv typ_addr in + let size = size_expr env (Ctuple new_args) in + self#insert (Iop(Ialloc size)) [||] rd; + self#emit_stores env new_args rd; + Some rd + | op -> + let r1 = self#emit_tuple env new_args in + let rd = Reg.createv ty in + Some (self#insert_op op r1 rd) + end + | Csequence(e1, e2) -> + begin match self#emit_expr env e1 with + None -> None + | Some r1 -> self#emit_expr env e2 + end + | Cifthenelse(econd, eif, eelse) -> + let (cond, earg) = self#select_condition econd in + begin match self#emit_expr env earg with + None -> None + | Some rarg -> + let (rif, sif) = self#emit_sequence env eif in + let (relse, selse) = self#emit_sequence env eelse in + let r = join rif sif relse selse in + self#insert (Iifthenelse(cond, sif#extract, selse#extract)) + rarg [||]; + r + end + | Cswitch(esel, index, ecases) -> + begin match self#emit_expr env esel with + None -> None + | Some rsel -> + let rscases = Array.map (self#emit_sequence env) ecases in + let r = join_array rscases in + self#insert (Iswitch(index, + Array.map (fun (r, s) -> s#extract) rscases)) + rsel [||]; + r + end + | Cloop(ebody) -> + let (rarg, sbody) = self#emit_sequence env ebody in + self#insert (Iloop(sbody#extract)) [||] [||]; + Some [||] + | Ccatch(nfail, ids, e1, e2) -> + let rs = + List.map + (fun id -> + let r = Reg.createv typ_addr in name_regs id r; r) + ids in + catch_regs := (nfail, Array.concat rs) :: !catch_regs ; + let (r1, s1) = self#emit_sequence env e1 in + catch_regs := List.tl !catch_regs ; + let new_env = + List.fold_left + (fun env (id,r) -> Tbl.add id r env) + env (List.combine ids rs) in + let (r2, s2) = self#emit_sequence new_env e2 in + let r = join r1 s1 r2 s2 in + self#insert (Icatch(nfail, s1#extract, s2#extract)) [||] [||]; + r + | Cexit (nfail,args) -> + begin match self#emit_parts_list env args with + None -> None + | Some (simple_list, ext_env) -> + let src = self#emit_tuple ext_env simple_list in + let dest = + try List.assoc nfail !catch_regs + with Not_found -> + Misc.fatal_error + ("Selectgen.emit_expr, on exit("^string_of_int nfail^")") in + self#insert_moves src dest ; + self#insert (Iexit nfail) [||] [||]; + None + end + | Ctrywith(e1, v, e2) -> + Proc.contains_calls := true; + let (r1, s1) = self#emit_sequence env e1 in + let rv = Reg.createv typ_addr in + let (r2, s2) = self#emit_sequence (Tbl.add v rv env) e2 in + let r = join r1 s1 r2 s2 in + self#insert + (Itrywith(s1#extract, + instr_cons (Iop Imove) [|Proc.loc_exn_bucket|] rv + (s2#extract))) + [||] [||]; + r + +method private emit_sequence env exp = + let s = {< instr_seq = dummy_instr >} in + let r = s#emit_expr env exp in + (r, s) + +method private bind_let env v r1 = + if all_regs_anonymous r1 then begin + name_regs v r1; + Tbl.add v r1 env + end else begin + let rv = Array.create (Array.length r1) Reg.dummy in + for i = 0 to Array.length r1 - 1 do + rv.(i) <- Reg.create r1.(i).typ + done; + name_regs v rv; + self#insert_moves r1 rv; + Tbl.add v rv env + end + +method private emit_parts env exp = + if is_simple_expr exp then + Some (exp, env) + else begin + match self#emit_expr env exp with + None -> None + | Some r -> + match Array.length r with + 0 -> + Some (Ctuple [], env) + | 1 -> + (* The normal case *) + let id = Ident.create "bind" in + let r0 = r.(0) in + if String.length r0.name = 0 then + (* r0 is an anonymous, unshared register; use it directly *) + Some (Cvar id, Tbl.add id r env) + else begin + (* Introduce a fresh temp reg to hold the result *) + let v0 = Reg.create r0.typ in + self#insert_move r0 v0; + Some (Cvar id, Tbl.add id [|v0|] env) + end + | _ -> + (* Must not happen, we no longer support nested tuples *) + assert false + end + +method private emit_parts_list env exp_list = + match exp_list with + [] -> Some ([], env) + | exp :: rem -> + (* This ensures right-to-left evaluation, consistent with the + bytecode compiler *) + match self#emit_parts_list env rem with + None -> None + | Some(new_rem, new_env) -> + match self#emit_parts new_env exp with + None -> None + | Some(new_exp, fin_env) -> Some(new_exp :: new_rem, fin_env) + +method private emit_tuple env exp_list = + let rec emit_list = function + [] -> [] + | exp :: rem -> + (* Again, force right-to-left evaluation *) + let loc_rem = emit_list rem in + match self#emit_expr env exp with + None -> assert false (* should have been caught in emit_parts *) + | Some loc_exp -> loc_exp :: loc_rem in + Array.concat(emit_list exp_list) + +method emit_extcall_args env args = + let r1 = self#emit_tuple env args in + let (loc_arg, stack_ofs as arg_stack) = Proc.loc_external_arguments r1 in + self#insert_move_args r1 loc_arg stack_ofs; + arg_stack + +method emit_stores env data regs_addr = + let a = + ref (Arch.offset_addressing Arch.identity_addressing (-Arch.size_int)) in + List.iter + (fun e -> + let (op, arg) = self#select_store !a e in + match self#emit_expr env arg with + None -> assert false + | Some regs -> + match op with + Istore(_, _) -> + for i = 0 to Array.length regs - 1 do + let r = regs.(i) in + let kind = if r.typ = Float then Double_u else Word in + self#insert (Iop(Istore(kind, !a))) + (Array.append [|r|] regs_addr) [||]; + a := Arch.offset_addressing !a (size_component r.typ) + done + | _ -> + self#insert (Iop op) (Array.append regs regs_addr) [||]; + a := Arch.offset_addressing !a (size_expr env e)) + data + +(* Same, but in tail position *) + +method private emit_return env exp = + match self#emit_expr env exp with + None -> () + | Some r -> + let loc = Proc.loc_results r in + self#insert_moves r loc; + self#insert Ireturn loc [||] + +method emit_tail env exp = + match exp with + Clet(v, e1, e2) -> + begin match self#emit_expr env e1 with + None -> () + | Some r1 -> self#emit_tail (self#bind_let env v r1) e2 + end + | Cop(Capply ty as op, args) -> + begin match self#emit_parts_list env args with + None -> () + | Some(simple_args, env) -> + let (new_op, new_args) = self#select_operation op simple_args in + match new_op with + Icall_ind -> + let r1 = self#emit_tuple env new_args in + let rarg = Array.sub r1 1 (Array.length r1 - 1) in + let (loc_arg, stack_ofs) = Proc.loc_arguments rarg in + if stack_ofs = 0 then begin + self#insert_moves rarg loc_arg; + self#insert (Iop Itailcall_ind) + (Array.append [|r1.(0)|] loc_arg) [||] + end else begin + Proc.contains_calls := true; + let rd = Reg.createv ty in + let loc_res = Proc.loc_results rd in + self#insert_move_args rarg loc_arg stack_ofs; + self#insert (Iop Icall_ind) + (Array.append [|r1.(0)|] loc_arg) loc_res; + self#insert(Iop(Istackoffset(-stack_ofs))) [||] [||]; + self#insert Ireturn loc_res [||] + end + | Icall_imm lbl -> + let r1 = self#emit_tuple env new_args in + let (loc_arg, stack_ofs) = Proc.loc_arguments r1 in + if stack_ofs = 0 then begin + self#insert_moves r1 loc_arg; + self#insert (Iop(Itailcall_imm lbl)) loc_arg [||] + end else if lbl = !current_function_name then begin + let loc_arg' = Proc.loc_parameters r1 in + self#insert_moves r1 loc_arg'; + self#insert (Iop(Itailcall_imm lbl)) loc_arg' [||] + end else begin + Proc.contains_calls := true; + let rd = Reg.createv ty in + let loc_res = Proc.loc_results rd in + self#insert_move_args r1 loc_arg stack_ofs; + self#insert (Iop(Icall_imm lbl)) loc_arg loc_res; + self#insert(Iop(Istackoffset(-stack_ofs))) [||] [||]; + self#insert Ireturn loc_res [||] + end + | _ -> fatal_error "Selection.emit_tail" + end + | Csequence(e1, e2) -> + begin match self#emit_expr env e1 with + None -> () + | Some r1 -> self#emit_tail env e2 + end + | Cifthenelse(econd, eif, eelse) -> + let (cond, earg) = self#select_condition econd in + begin match self#emit_expr env earg with + None -> () + | Some rarg -> + self#insert (Iifthenelse(cond, self#emit_tail_sequence env eif, + self#emit_tail_sequence env eelse)) + rarg [||] + end + | Cswitch(esel, index, ecases) -> + begin match self#emit_expr env esel with + None -> () + | Some rsel -> + self#insert + (Iswitch(index, Array.map (self#emit_tail_sequence env) ecases)) + rsel [||] + end + | Ccatch(nfail, ids, e1, e2) -> + let rs = + List.map + (fun id -> + let r = Reg.createv typ_addr in + name_regs id r ; + r) + ids in + catch_regs := (nfail, Array.concat rs) :: !catch_regs ; + let s1 = self#emit_tail_sequence env e1 in + catch_regs := List.tl !catch_regs ; + let new_env = + List.fold_left + (fun env (id,r) -> Tbl.add id r env) + env (List.combine ids rs) in + let s2 = self#emit_tail_sequence new_env e2 in + self#insert (Icatch(nfail, s1, s2)) [||] [||] + | Ctrywith(e1, v, e2) -> + Proc.contains_calls := true; + let (opt_r1, s1) = self#emit_sequence env e1 in + let rv = Reg.createv typ_addr in + let s2 = self#emit_tail_sequence (Tbl.add v rv env) e2 in + self#insert + (Itrywith(s1#extract, + instr_cons (Iop Imove) [|Proc.loc_exn_bucket|] rv s2)) + [||] [||]; + begin match opt_r1 with + None -> () + | Some r1 -> + let loc = Proc.loc_results r1 in + self#insert_moves r1 loc; + self#insert Ireturn loc [||] + end + | _ -> + self#emit_return env exp + +method private emit_tail_sequence env exp = + let s = {< instr_seq = dummy_instr >} in + s#emit_tail env exp; + s#extract + +(* Sequentialization of a function definition *) + +method emit_fundecl f = + Proc.contains_calls := false; + current_function_name := f.Cmm.fun_name; + let rargs = + List.map + (fun (id, ty) -> let r = Reg.createv ty in name_regs id r; r) + f.Cmm.fun_args in + let rarg = Array.concat rargs in + let loc_arg = Proc.loc_parameters rarg in + let env = + List.fold_right2 + (fun (id, ty) r env -> Tbl.add id r env) + f.Cmm.fun_args rargs Tbl.empty in + self#insert_moves loc_arg rarg; + self#emit_tail env f.Cmm.fun_body; + { fun_name = f.Cmm.fun_name; + fun_args = loc_arg; + fun_body = self#extract; + fun_fast = f.Cmm.fun_fast } + +end diff --git a/asmcomp/selectgen.mli b/asmcomp/selectgen.mli new file mode 100644 index 00000000..2033247b --- /dev/null +++ b/asmcomp/selectgen.mli @@ -0,0 +1,67 @@ +(***********************************************************************) +(* *) +(* 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: selectgen.mli,v 1.6 2002/11/04 16:25:09 xleroy Exp $ *) + +(* Selection of pseudo-instructions, assignment of pseudo-registers, + sequentialization. *) + +type environment = (Ident.t, Reg.t array) Tbl.t + +val size_expr : environment -> Cmm.expression -> int + +class virtual selector_generic : object + (* The following methods must or can be overriden by the processor + description *) + method virtual is_immediate : int -> bool + (* Must be defined to indicate whether a constant is a suitable + immediate operand to arithmetic instructions *) + method virtual select_addressing : + Cmm.expression -> Arch.addressing_mode * Cmm.expression + (* Must be defined to select addressing modes *) + method select_operation : + Cmm.operation -> + Cmm.expression list -> Mach.operation * Cmm.expression list + (* Can be overriden to deal with special arithmetic instructions *) + method select_condition : Cmm.expression -> Mach.test * Cmm.expression + (* Can be overriden to deal with special test instructions *) + method select_store : + Arch.addressing_mode -> Cmm.expression -> Mach.operation * Cmm.expression + (* Can be overriden to deal with special store constant instructions *) + method insert_op : + Mach.operation -> Reg.t array -> Reg.t array -> Reg.t array + (* Can be overriden to deal with 2-address instructions + or instructions with hardwired input/output registers *) + method emit_extcall_args : + environment -> Cmm.expression list -> Reg.t array * int + (* Can be overriden to deal with stack-based calling conventions *) + method emit_stores : + environment -> Cmm.expression list -> Reg.t array -> unit + (* Fill a freshly allocated block. Can be overriden for architectures + that do not provide Arch.offset_addressing. *) + + (* The following method is the entry point and should not be overriden *) + method emit_fundecl : Cmm.fundecl -> Mach.fundecl + + (* The following methods should not be overriden. They cannot be + declared "private" in the current implementation because they + are not always applied to "self", but ideally they should be private. *) + method extract : Mach.instruction + method insert : Mach.instruction_desc -> Reg.t array -> Reg.t array -> unit + method insert_move : Reg.t -> Reg.t -> unit + method insert_move_args : Reg.t array -> Reg.t array -> int -> unit + method insert_move_results : Reg.t array -> Reg.t array -> int -> unit + method insert_moves : Reg.t array -> Reg.t array -> unit + method emit_expr : + (Ident.t, Reg.t array) Tbl.t -> Cmm.expression -> Reg.t array option + method emit_tail : (Ident.t, Reg.t array) Tbl.t -> Cmm.expression -> unit +end diff --git a/asmcomp/selection.mli b/asmcomp/selection.mli new file mode 100644 index 00000000..e7a164e1 --- /dev/null +++ b/asmcomp/selection.mli @@ -0,0 +1,18 @@ +(***********************************************************************) +(* *) +(* 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: selection.mli,v 1.6 1999/11/17 18:56:37 xleroy Exp $ *) + +(* Selection of pseudo-instructions, assignment of pseudo-registers, + sequentialization. *) + +val fundecl: Cmm.fundecl -> Mach.fundecl diff --git a/asmcomp/sparc/arch.ml b/asmcomp/sparc/arch.ml new file mode 100644 index 00000000..c8a00be2 --- /dev/null +++ b/asmcomp/sparc/arch.ml @@ -0,0 +1,75 @@ +(***********************************************************************) +(* *) +(* 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: arch.ml,v 1.8 2002/11/29 15:03:08 xleroy Exp $ *) + +(* Specific operations for the Sparc processor *) + +open Misc +open Format + +(* SPARC V8 adds multiply and divide. + SPARC V9 adds double precision float operations, conditional + move, and more instructions that are only useful in 64 bit mode. + Sun calls 32 bit V9 "V8+". *) +type arch_version = SPARC_V7 | SPARC_V8 | SPARC_V9 + +let arch_version = ref SPARC_V7 + +let command_line_options = + [ "-march=v8", Arg.Unit (fun () -> arch_version := SPARC_V8), + " Generate code for SPARC V8 processors"; + "-march=v9", Arg.Unit (fun () -> arch_version := SPARC_V9), + " Generate code for SPARC V9 processors" ] + +type specific_operation = unit (* None worth mentioning *) + +(* Addressing modes *) + +type addressing_mode = + Ibased of string * int (* symbol + displ *) + | Iindexed of int (* reg + displ *) + +(* Sizes, endianness *) + +let big_endian = true + +let size_addr = 4 +let size_int = 4 +let size_float = 8 + +(* Operations on addressing modes *) + +let identity_addressing = Iindexed 0 + +let offset_addressing addr delta = + match addr with + Ibased(s, n) -> Ibased(s, n + delta) + | Iindexed n -> Iindexed(n + delta) + +let num_args_addressing = function + Ibased(s, n) -> 0 + | Iindexed n -> 1 + +(* Printing operations and addressing modes *) + +let print_addressing printreg addr ppf arg = + match addr with + | Ibased(s, n) -> + let idx = if n <> 0 then Printf.sprintf " + %i" n else "" in + fprintf ppf "\"%s\"%s" s idx + | Iindexed n -> + let idx = if n <> 0 then Printf.sprintf " + %i" n else "" in + fprintf ppf "%a%s" printreg arg.(0) idx + +let print_specific_operation printreg op ppf arg = + Misc.fatal_error "Arch_sparc.print_specific_operation" diff --git a/asmcomp/sparc/emit.mlp b/asmcomp/sparc/emit.mlp new file mode 100644 index 00000000..1d23432e --- /dev/null +++ b/asmcomp/sparc/emit.mlp @@ -0,0 +1,752 @@ +(***********************************************************************) +(* *) +(* 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: emit.mlp,v 1.18 2003/07/17 15:11:03 xleroy Exp $ *) + +(* Emission of Sparc assembly code *) + +open Location +open Misc +open Cmm +open Arch +open Proc +open Reg +open Mach +open Linearize +open Emitaux + +(* Tradeoff between code size and code speed *) + +let fastcode_flag = ref true + +(* Layout of the stack *) +(* Always keep the stack 8-aligned. + Always leave 96 bytes at the bottom of the stack *) + +let stack_offset = ref 0 + +let frame_size () = + let size = + !stack_offset + + 4 * num_stack_slots.(0) + 8 * num_stack_slots.(1) + + (if !contains_calls then 4 else 0) in + Misc.align size 8 + +let slot_offset loc cl = + match loc with + Incoming n -> frame_size() + n + 96 + | Local n -> + if cl = 0 + then !stack_offset + num_stack_slots.(1) * 8 + n * 4 + 96 + else !stack_offset + n * 8 + 96 + | Outgoing n -> n + 96 + +(* Return the other register in a register pair *) + +let next_in_pair = function + {loc = Reg r; typ = (Int | Addr)} -> phys_reg (r + 1) + | {loc = Reg r; typ = Float} -> phys_reg (r + 16) + | _ -> fatal_error "Emit.next_in_pair" + +(* Symbols are prefixed with _ under SunOS *) + +let symbol_prefix = + if Config.system = "sunos" then "_" else "" + +let emit_symbol s = + if String.length s >= 1 & s.[0] = '.' + then emit_string s + else begin emit_string symbol_prefix; Emitaux.emit_symbol '$' s end + +let emit_size lbl = + if Config.system = "solaris" then + ` .size {emit_symbol lbl},.-{emit_symbol lbl}\n` + +let rodata () = + if Config.system = "solaris" (* || Config.system = "linux" *) then + ` .section \".rodata\"\n` + else + ` .data\n` + +(* Check if an integer or native integer is an immediate operand *) + +let is_immediate n = + n <= 4095 && n >= -4096 + +let is_native_immediate n = + n <= Nativeint.of_int 4095 && n >= Nativeint.of_int (-4096) + +(* Output a label *) + +let label_prefix = + if Config.system = "sunos" then "L" else ".L" + +let emit_label lbl = + emit_string label_prefix; emit_int lbl + +(* Output a pseudo-register *) + +let emit_reg r = + match r.loc with + Reg r -> emit_string (register_name r) + | _ -> fatal_error "Emit.emit_reg" + +(* Output a stack reference *) + +let emit_stack r = + match r.loc with + Stack s -> + let ofs = slot_offset s (register_class r) in `[%sp + {emit_int ofs}]` + | _ -> fatal_error "Emit.emit_stack" + +(* Output a load *) + +let emit_load instr addr arg dst = + match addr with + Ibased(s, 0) -> + ` sethi %hi({emit_symbol s}), %g1\n`; + ` {emit_string instr} [%g1 + %lo({emit_symbol s})], {emit_reg dst}\n` + | Ibased(s, ofs) -> + ` sethi %hi({emit_symbol s} + {emit_int ofs}), %g1\n`; + ` {emit_string instr} [%g1 + %lo({emit_symbol s} + {emit_int ofs})], {emit_reg dst}\n` + | Iindexed ofs -> + if is_immediate ofs then + ` {emit_string instr} [{emit_reg arg.(0)} + {emit_int ofs}], {emit_reg dst}\n` + else begin + ` sethi %hi({emit_int ofs}), %g1\n`; + ` or %g1, %lo({emit_int ofs}), %g1\n`; + ` {emit_string instr} [{emit_reg arg.(0)} + %g1], {emit_reg dst}\n` + end + +(* Output a store *) + +let emit_store instr addr arg src = + match addr with + Ibased(s, 0) -> + ` sethi %hi({emit_symbol s}), %g1\n`; + ` {emit_string instr} {emit_reg src}, [%g1 + %lo({emit_symbol s})]\n` + | Ibased(s, ofs) -> + ` sethi %hi({emit_symbol s} + {emit_int ofs}), %g1\n`; + ` {emit_string instr} {emit_reg src}, [%g1 + %lo({emit_symbol s} + {emit_int ofs})]\n` + | Iindexed ofs -> + if is_immediate ofs then + ` {emit_string instr} {emit_reg src}, [{emit_reg arg.(1)} + {emit_int ofs}]\n` + else begin + ` sethi %hi({emit_int ofs}), %g1\n`; + ` or %g1, %lo({emit_int ofs}), %g1\n`; + ` {emit_string instr} {emit_reg src}, [{emit_reg arg.(1)} + %g1]\n` + end + +(* Record live pointers at call points *) + +type frame_descr = + { fd_lbl: int; (* Return address *) + fd_frame_size: int; (* Size of stack frame *) + fd_live_offset: int list } (* Offsets/regs of live addresses *) + +let frame_descriptors = ref([] : frame_descr list) + +let record_frame live = + let lbl = new_label() in + let live_offset = ref [] in + Reg.Set.iter + (function + {typ = Addr; loc = Reg r} -> + live_offset := ((r lsl 1) + 1) :: !live_offset + | {typ = Addr; loc = Stack s} as reg -> + live_offset := + slot_offset s (register_class reg) :: !live_offset + | _ -> ()) + live; + frame_descriptors := + { fd_lbl = lbl; + fd_frame_size = frame_size(); + fd_live_offset = !live_offset } :: !frame_descriptors; + `{emit_label lbl}:` + +let emit_frame fd = + ` .word {emit_label fd.fd_lbl}\n`; + ` .half {emit_int fd.fd_frame_size}\n`; + ` .half {emit_int (List.length fd.fd_live_offset)}\n`; + List.iter + (fun n -> + ` .half {emit_int n}\n`) + fd.fd_live_offset; + ` .align 4\n` + +(* Record floating-point constants *) + +let float_constants = ref ([] : (int * string) list) + +let emit_float_constant (lbl, cst) = + rodata (); + ` .align 8\n`; + `{emit_label lbl}: .double 0r{emit_string cst}\n` + +(* Emission of the profiling prelude *) +let emit_profile () = + begin match Config.system with + "solaris" -> + let lbl = new_label() in + ` .section \".bss\"\n`; + `{emit_label lbl}: .skip 4\n`; + ` .text\n`; + ` save %sp,-96,%sp\n`; + ` sethi %hi({emit_label lbl}),%o0\n`; + ` call _mcount\n`; + ` or %o0,%lo({emit_label lbl}),%o0\n`; + ` restore\n` + | _ -> () + end + +(* Names of various instructions *) + +let name_for_int_operation = function + Iadd -> "add" + | Isub -> "sub" + | Iand -> "and" + | Ior -> "or" + | Ixor -> "xor" + | Ilsl -> "sll" + | Ilsr -> "srl" + | Iasr -> "sra" + | Imul -> "smul" + | _ -> Misc.fatal_error "Emit.name_for_int_operation" + +let name_for_float_operation = function + Inegf -> if !arch_version = SPARC_V9 then "fnegd" else "fnegs" + | Iabsf -> if !arch_version = SPARC_V9 then "fabsd" else "fabss" + | Iaddf -> "faddd" + | Isubf -> "fsubd" + | Imulf -> "fmuld" + | Idivf -> "fdivd" + | _ -> Misc.fatal_error "Emit.name_for_float_operation" + +let name_for_int_movcc = function + Isigned Ceq -> "e" | Isigned Cne -> "ne" + | Isigned Cle -> "le" | Isigned Cgt -> "g" + | Isigned Clt -> "l" | Isigned Cge -> "ge" + | Iunsigned Ceq -> "e" | Iunsigned Cne -> "ne" + | Iunsigned Cle -> "leu" | Iunsigned Cgt -> "gu" + | Iunsigned Clt -> "lu" | Iunsigned Cge -> "geu" + +let name_for_int_comparison = function + Isigned Ceq -> "be" | Isigned Cne -> "bne" + | Isigned Cle -> "ble" | Isigned Cgt -> "bg" + | Isigned Clt -> "bl" | Isigned Cge -> "bge" + | Iunsigned Ceq -> "be" | Iunsigned Cne -> "bne" + | Iunsigned Cle -> "bleu" | Iunsigned Cgt -> "bgu" + | Iunsigned Clt -> "blu" | Iunsigned Cge -> "bgeu" + +let name_for_float_comparison cmp neg = + match cmp with + Ceq -> if neg then "fbne" else "fbe" + | Cne -> if neg then "fbe" else "fbne" + | Cle -> if neg then "fbug" else "fble" + | Cgt -> if neg then "fbule" else "fbg" + | Clt -> if neg then "fbuge" else "fbl" + | Cge -> if neg then "fbul" else "fbge" + +(* Output the assembly code for an instruction *) + +let function_name = ref "" +let tailrec_entry_point = ref 0 + +let rec emit_instr i dslot = + match i.desc with + Lend -> () + | Lop(Imove | Ispill | Ireload) -> + let src = i.arg.(0) and dst = i.res.(0) in + begin match (src, dst) with + {loc = Reg rs; typ = (Int | Addr)}, {loc = Reg rd} -> + ` mov {emit_reg src}, {emit_reg dst}\n` + | {loc = Reg rs; typ = Float}, {loc = Reg rd; typ = Float} -> + if !arch_version = SPARC_V9 then + ` fmovd {emit_reg src}, {emit_reg dst}\n` + else begin + ` fmovs {emit_reg src}, {emit_reg dst}\n`; + ` fmovs {emit_reg(next_in_pair src)}, {emit_reg(next_in_pair dst)}\n` + end + | {loc = Reg rs; typ = Float}, {loc = Reg rd; typ = (Int | Addr)} -> + (* This happens when calling C functions and passing a float arg + in %o0...%o5 *) + ` sub %sp, 8, %sp\n`; + ` std {emit_reg src}, [%sp + 96]\n`; + ` ld [%sp + 96], {emit_reg dst}\n`; + ` ld [%sp + 100], {emit_reg(next_in_pair dst)}\n`; + ` add %sp, 8, %sp\n` + | {loc = Reg rs; typ = (Int | Addr)}, {loc = Stack sd} -> + ` st {emit_reg src}, {emit_stack dst}\n` + | {loc = Reg rs; typ = Float}, {loc = Stack sd} -> + ` std {emit_reg src}, {emit_stack dst}\n` + | {loc = Stack ss; typ = (Int | Addr)}, {loc = Reg rd} -> + ` ld {emit_stack src}, {emit_reg dst}\n` + | {loc = Stack ss; typ = Float}, {loc = Reg rd} -> + ` ldd {emit_stack src}, {emit_reg dst}\n` + | (_, _) -> + fatal_error "Emit: Imove" + end + | Lop(Iconst_int n) -> + if is_native_immediate n then + ` mov {emit_nativeint n}, {emit_reg i.res.(0)}\n` + else begin + ` sethi %hi({emit_nativeint n}), %g1\n`; + ` or %g1, %lo({emit_nativeint n}), {emit_reg i.res.(0)}\n` + end + | Lop(Iconst_float s) -> + (* On UltraSPARC, the fzero instruction could be used to set a + floating point register pair to zero. *) + let lbl = new_label() in + float_constants := (lbl, s) :: !float_constants; + ` sethi %hi({emit_label lbl}), %g1\n`; + ` ldd [%g1 + %lo({emit_label lbl})], {emit_reg i.res.(0)}\n` + | Lop(Iconst_symbol s) -> + ` sethi %hi({emit_symbol s}), %g1\n`; + ` or %g1, %lo({emit_symbol s}), {emit_reg i.res.(0)}\n` + | Lop(Icall_ind) -> + `{record_frame i.live} call {emit_reg i.arg.(0)}\n`; + fill_delay_slot dslot + | Lop(Icall_imm s) -> + `{record_frame i.live} call {emit_symbol s}\n`; + fill_delay_slot dslot + | Lop(Itailcall_ind) -> + let n = frame_size() in + if !contains_calls then + ` ld [%sp + {emit_int(n - 4 + 96)}], %o7\n`; + ` jmp {emit_reg i.arg.(0)}\n`; + ` add %sp, {emit_int n}, %sp\n` (* in delay slot *) + | Lop(Itailcall_imm s) -> + let n = frame_size() in + if s = !function_name then begin + ` b {emit_label !tailrec_entry_point}\n`; + fill_delay_slot dslot + end else begin + if !contains_calls then + ` ld [%sp + {emit_int(n - 4 + 96)}], %o7\n`; + ` sethi %hi({emit_symbol s}), %g1\n`; + ` jmp %g1 + %lo({emit_symbol s})\n`; + ` add %sp, {emit_int n}, %sp\n` (* in delay slot *) + end + | Lop(Iextcall(s, alloc)) -> + if alloc then begin + ` sethi %hi({emit_symbol s}), %g2\n`; + `{record_frame i.live} call {emit_symbol "caml_c_call"}\n`; + ` or %g2, %lo({emit_symbol s}), %g2\n` (* in delay slot *) + end else begin + ` call {emit_symbol s}\n`; + fill_delay_slot dslot + end + | Lop(Istackoffset n) -> + ` add %sp, {emit_int (-n)}, %sp\n`; + stack_offset := !stack_offset + n + | Lop(Iload(chunk, addr)) -> + let dest = i.res.(0) in + begin match chunk with + Double_u -> + emit_load "ld" addr i.arg dest; + emit_load "ld" (offset_addressing addr 4) i.arg (next_in_pair dest) + | Single -> + emit_load "ld" addr i.arg dest; + ` fstod {emit_reg dest}, {emit_reg dest}\n` + | _ -> + let loadinstr = + match chunk with + Byte_unsigned -> "ldub" + | Byte_signed -> "ldsb" + | Sixteen_unsigned -> "lduh" + | Sixteen_signed -> "ldsh" + | Double -> "ldd" + | _ -> "ld" in + emit_load loadinstr addr i.arg dest + end + | Lop(Istore(chunk, addr)) -> + let src = i.arg.(0) in + begin match chunk with + Double_u -> + emit_store "st" addr i.arg src; + emit_store "st" (offset_addressing addr 4) i.arg (next_in_pair src) + | Single -> + ` fdtos {emit_reg src}, %f30\n`; + emit_store "st" addr i.arg (phys_reg 115) (* %f30 *) + | _ -> + let storeinstr = + match chunk with + | Byte_unsigned | Byte_signed -> "stb" + | Sixteen_unsigned | Sixteen_signed -> "sth" + | Double -> "std" + | _ -> "st" in + emit_store storeinstr addr i.arg src + end + | Lop(Ialloc n) -> + if !fastcode_flag then begin + let indirect = Config.system <> "solaris" in + let lbl_cont = new_label() in + if indirect then + ` ld [%l7], %g1\n`; + ` sub %l6, {emit_int n}, %l6\n`; + if indirect then + ` cmp %l6, %g1\n` + else + ` cmp %l6, %l7\n`; + ` bgeu {emit_label lbl_cont}\n`; + ` add %l6, 4, {emit_reg i.res.(0)}\n`; (* in delay slot *) + `{record_frame i.live} call {emit_symbol "caml_call_gc"}\n`; + ` mov {emit_int n}, %g2\n`; (* in delay slot *) + ` add %l6, 4, {emit_reg i.res.(0)}\n`; + `{emit_label lbl_cont}:\n` + end else begin + `{record_frame i.live} call {emit_symbol "caml_alloc"}\n`; + ` mov {emit_int n}, %g2\n`; (* in delay slot *) + ` add %l6, 4, {emit_reg i.res.(0)}\n` + end + | Lop(Iintop(Icomp cmp)) -> + ` cmp {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; + if !arch_version = SPARC_V9 then begin + let comp = name_for_int_movcc cmp in + ` mov 0, {emit_reg i.res.(0)}\n`; + ` mov{emit_string comp} %icc, 1, {emit_reg i.res.(0)}\n` + end + else begin + let comp = name_for_int_comparison cmp + and lbl = new_label() in + ` {emit_string comp},a {emit_label lbl}\n`; + ` mov 1, {emit_reg i.res.(0)}\n`; + ` mov 0, {emit_reg i.res.(0)}\n`; + `{emit_label lbl}:\n` + end + | Lop(Iintop Icheckbound) -> + ` cmp {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; + ` tleu 5\n` (* 5 = ST_RANGE_CHECK *) + | Lop(Iintop Idiv) -> + ` sra {emit_reg i.arg.(0)}, 31, %g1\n`; + ` wr %g1, %y\n`; + ` sdiv {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.res.(0)}\n` + | Lop(Iintop op) -> + let instr = name_for_int_operation op in + ` {emit_string instr} {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.res.(0)}\n` + | Lop(Iintop_imm(Ilsl, 1)) -> + (* UltraSPARC has two add units but only one shifter. *) + ` add {emit_reg i.arg.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.res.(0)}\n` + | Lop(Iintop_imm(Idiv, n)) -> + let l = Misc.log2 n in + if n = 1 lsl l then begin + let lbl = new_label() in + ` cmp {emit_reg i.arg.(0)}, 0\n`; + ` bge {emit_label lbl}\n`; + ` mov {emit_reg i.arg.(0)}, %g1\n`; (* in delay slot *) + ` add %g1, {emit_int (n-1)}, %g1\n`; + `{emit_label lbl}:\n`; + ` sra %g1, {emit_int l}, {emit_reg i.res.(0)}\n` + end else begin + ` sra {emit_reg i.arg.(0)}, 31, %g1\n`; + ` wr %g1, %y\n`; + ` sdiv {emit_reg i.arg.(0)}, {emit_int n}, {emit_reg i.res.(0)}\n` + end + | Lop(Iintop_imm(Imod, n)) -> (* n is a power of 2 *) + let log = Misc.log2 n in + let lbl = new_label() in + ` tst {emit_reg i.arg.(0)}\n`; + ` bge {emit_label lbl}\n`; + ` andcc {emit_reg i.arg.(0)}, {emit_int (n-1)}, {emit_reg i.res.(0)}\n`; (* in delay slot *) + ` be {emit_label lbl}\n`; + ` nop\n`; + ` sub {emit_reg i.res.(0)}, {emit_int n}, {emit_reg i.res.(0)}\n`; + `{emit_label lbl}:\n` + | Lop(Iintop_imm(Icomp cmp, n)) -> + ` cmp {emit_reg i.arg.(0)}, {emit_int n}\n`; + if !arch_version = SPARC_V9 then begin + let comp = name_for_int_movcc cmp in + ` mov 0, {emit_reg i.res.(0)}\n`; + ` mov{emit_string comp} %xcc, 1, {emit_reg i.res.(0)}\n` + end else begin + let comp = name_for_int_comparison cmp + and lbl = new_label() in + ` {emit_string comp},a {emit_label lbl}\n`; + ` mov 1, {emit_reg i.res.(0)}\n`; + ` mov 0, {emit_reg i.res.(0)}\n`; + `{emit_label lbl}:\n` + end + | Lop(Iintop_imm(Icheckbound, n)) -> + ` cmp {emit_reg i.arg.(0)}, {emit_int n}\n`; + ` tleu 5\n` (* 5 = ST_RANGE_CHECK *) + | Lop(Iintop_imm(op, n)) -> + let instr = name_for_int_operation op in + ` {emit_string instr} {emit_reg i.arg.(0)}, {emit_int n}, {emit_reg i.res.(0)}\n` + | Lop(Inegf | Iabsf as op) -> + let instr = name_for_float_operation op in + ` {emit_string instr} {emit_reg i.arg.(0)}, {emit_reg i.res.(0)}\n`; + if !arch_version <> SPARC_V9 then + ` fmovs {emit_reg(next_in_pair i.arg.(0))}, {emit_reg(next_in_pair i.res.(0))}\n` + | Lop(Iaddf | Isubf | Imulf | Idivf as op) -> + let instr = name_for_float_operation op in + ` {emit_string instr} {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.res.(0)}\n` + | Lop(Ifloatofint) -> + ` sub %sp, 8, %sp\n`; + ` st {emit_reg i.arg.(0)}, [%sp + 96]\n`; + ` ld [%sp + 96], %f30\n`; + ` add %sp, 8, %sp\n`; + ` fitod %f30, {emit_reg i.res.(0)}\n` + | Lop(Iintoffloat) -> + ` fdtoi {emit_reg i.arg.(0)}, %f30\n`; + ` sub %sp, 8, %sp\n`; + ` st %f30, [%sp + 96]\n`; + ` ld [%sp + 96], {emit_reg i.res.(0)}\n`; + ` add %sp, 8, %sp\n` + | Lop(Ispecific sop) -> + assert false + | Lreloadretaddr -> + let n = frame_size() in + ` ld [%sp + {emit_int(n - 4 + 96)}], %o7\n` + | Lreturn -> + let n = frame_size() in + ` retl\n`; + if n = 0 then + ` nop\n` + else + ` add %sp, {emit_int n}, %sp\n` + | Llabel lbl -> + `{emit_label lbl}:\n` + | Lbranch lbl -> + ` b {emit_label lbl}\n`; + fill_delay_slot dslot + | Lcondbranch(tst, lbl) -> + begin match tst with + Itruetest -> + ` tst {emit_reg i.arg.(0)}\n`; + ` bne {emit_label lbl}\n` + | Ifalsetest -> + ` tst {emit_reg i.arg.(0)}\n`; + ` be {emit_label lbl}\n` + | Iinttest cmp -> + let comp = name_for_int_comparison cmp in + ` cmp {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; + ` {emit_string comp} {emit_label lbl}\n` + | Iinttest_imm(cmp, n) -> + let comp = name_for_int_comparison cmp in + ` cmp {emit_reg i.arg.(0)}, {emit_int n}\n`; + ` {emit_string comp} {emit_label lbl}\n` + | Ifloattest(cmp, neg) -> + let comp = name_for_float_comparison cmp neg in + ` fcmpd {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; + ` nop\n`; + ` {emit_string comp} {emit_label lbl}\n` + | Ioddtest -> + ` andcc {emit_reg i.arg.(0)}, 1, %g0\n`; + ` bne {emit_label lbl}\n` + | Ieventest -> + ` andcc {emit_reg i.arg.(0)}, 1, %g0\n`; + ` be {emit_label lbl}\n` + end; + fill_delay_slot dslot + | Lcondbranch3(lbl0, lbl1, lbl2) -> + ` cmp {emit_reg i.arg.(0)}, 1\n`; + begin match lbl0 with + None -> () + | Some lbl -> ` bl {emit_label lbl}\n nop\n` + end; + begin match lbl1 with + None -> () + | Some lbl -> ` be {emit_label lbl}\n nop\n` + end; + begin match lbl2 with + None -> () + | Some lbl -> ` bg {emit_label lbl}\n nop\n` + end + | Lswitch jumptbl -> + let lbl_jumptbl = new_label() in + ` sethi %hi({emit_label lbl_jumptbl}), %g1\n`; + ` or %g1, %lo({emit_label lbl_jumptbl}), %g1\n`; + ` sll {emit_reg i.arg.(0)}, 2, %g2\n`; + ` ld [%g1 + %g2], %g1\n`; + ` jmp %g1\n`; (* poor scheduling *) + ` nop\n`; + `{emit_label lbl_jumptbl}:`; + for i = 0 to Array.length jumptbl - 1 do + ` .word {emit_label jumptbl.(i)}\n` + done + | Lsetuptrap lbl -> + ` call {emit_label lbl}\n`; + ` sub %sp, 8, %sp\n` (* in delay slot *) + | Lpushtrap -> + stack_offset := !stack_offset + 8; + ` st %o7, [%sp + 96]\n`; + ` st %l5, [%sp + 100]\n`; + ` mov %sp, %l5\n` + | Lpoptrap -> + ` ld [%sp + 100], %l5\n`; + ` add %sp, 8, %sp\n`; + stack_offset := !stack_offset - 8 + | Lraise -> + ` ld [%l5 + 96], %g1\n`; + ` mov %l5, %sp\n`; + ` ld [%sp + 100], %l5\n`; + ` jmp %g1 + 8\n`; + ` add %sp, 8, %sp\n` + +and fill_delay_slot = function + None -> ` nop\n` + | Some i -> emit_instr i None + +(* Checks if a pseudo-instruction expands to exactly one machine instruction + that does not branch. *) + +let is_one_instr_op = function + Idiv | Imod | Icomp _ | Icheckbound -> false + | _ -> true + +let is_one_instr i = + match i.desc with + Lop op -> + begin match op with + Imove | Ispill | Ireload -> + i.arg.(0).typ <> Float && i.res.(0).typ <> Float + | Iconst_int n -> is_native_immediate n + | Istackoffset _ -> true + | Iload(_, Iindexed n) -> i.res.(0).typ <> Float & is_immediate n + | Istore(_, Iindexed n) -> i.arg.(0).typ <> Float & is_immediate n + | Iintop(op) -> is_one_instr_op op + | Iintop_imm(op, _) -> is_one_instr_op op + | Iaddf | Isubf | Imulf | Idivf -> true + | Iabsf | Inegf -> !arch_version = SPARC_V9 + | _ -> false + end + | _ -> false + +let no_interference res arg = + try + for i = 0 to Array.length arg - 1 do + for j = 0 to Array.length res - 1 do + if arg.(i).loc = res.(j).loc then raise Exit + done + done; + true + with Exit -> + false + +(* Emit a sequence of instructions, trying to fill delay slots for branches *) + +let rec emit_all i = + match i with + {desc = Lend} -> () + | {next = {desc = Lop(Icall_imm _) | Lop(Iextcall(_, false)) | Lbranch _}} + when is_one_instr i -> + emit_instr i.next (Some i); + emit_all i.next.next + | {next = {desc = Lop(Itailcall_imm s)}} + when s = !function_name & is_one_instr i -> + emit_instr i.next (Some i); + emit_all i.next.next + | {next = {desc = Lop(Icall_ind)}} + when is_one_instr i & no_interference i.res i.next.arg -> + emit_instr i.next (Some i); + emit_all i.next.next + | {next = {desc = Lcondbranch(_, _)}} + when is_one_instr i & no_interference i.res i.next.arg -> + emit_instr i.next (Some i); + emit_all i.next.next + | _ -> + emit_instr i None; + emit_all i.next + +(* Emission of a function declaration *) + +let fundecl fundecl = + function_name := fundecl.fun_name; + fastcode_flag := fundecl.fun_fast; + tailrec_entry_point := new_label(); + stack_offset := 0; + float_constants := []; + ` .text\n`; + ` .align 4\n`; + ` .global {emit_symbol fundecl.fun_name}\n`; + if Config.system = "solaris" then + ` .type {emit_symbol fundecl.fun_name},#function\n`; + `{emit_symbol fundecl.fun_name}:\n`; + if !Clflags.gprofile then emit_profile(); + let n = frame_size() in + if n > 0 then + ` sub %sp, {emit_int n}, %sp\n`; + if !contains_calls then + ` st %o7, [%sp + {emit_int(n - 4 + 96)}]\n`; + `{emit_label !tailrec_entry_point}:\n`; + emit_all fundecl.fun_body; + emit_size fundecl.fun_name; + List.iter emit_float_constant !float_constants + +(* Emission of data *) + +let emit_item = function + Cglobal_symbol s -> + ` .global {emit_symbol s}\n`; + | Cdefine_symbol s -> + `{emit_symbol s}:\n` + | Cdefine_label lbl -> + `{emit_label (lbl + 100000)}:\n` + | Cint8 n -> + ` .byte {emit_int n}\n` + | Cint16 n -> + ` .half {emit_int n}\n` + | Cint32 n -> + ` .word {emit_nativeint n}\n` + | Cint n -> + ` .word {emit_nativeint n}\n` + | Csingle f -> + ` .single 0r{emit_string f}\n` + | Cdouble f -> + ` .double 0r{emit_string f}\n` + | Csymbol_address s -> + ` .word {emit_symbol s}\n` + | Clabel_address lbl -> + ` .word {emit_label (lbl + 100000)}\n` + | Cstring s -> + emit_string_directive " .ascii " s + | Cskip n -> + if n > 0 then ` .skip {emit_int n}\n` + | Calign n -> + ` .align {emit_int n}\n` + +let data l = + ` .data\n`; + List.iter emit_item l + +(* Beginning / end of an assembly file *) + +let begin_assembly() = + let lbl_begin = Compilenv.current_unit_name() ^ "__data_begin" in + ` .data\n`; + ` .global {emit_symbol lbl_begin}\n`; + `{emit_symbol lbl_begin}:\n`; + let lbl_begin = Compilenv.current_unit_name() ^ "__code_begin" in + ` .text\n`; + ` .global {emit_symbol lbl_begin}\n`; + `{emit_symbol lbl_begin}:\n` + +let end_assembly() = + ` .text\n`; + let lbl_end = Compilenv.current_unit_name() ^ "__code_end" in + ` .global {emit_symbol lbl_end}\n`; + `{emit_symbol lbl_end}:\n`; + ` .data\n`; + let lbl_end = Compilenv.current_unit_name() ^ "__data_end" in + ` .global {emit_symbol lbl_end}\n`; + `{emit_symbol lbl_end}:\n`; + ` .word 0\n`; + let lbl = Compilenv.current_unit_name() ^ "__frametable" in + rodata (); + ` .global {emit_symbol lbl}\n`; + if Config.system = "solaris" then + ` .type {emit_symbol lbl},#object\n`; + `{emit_symbol lbl}:\n`; + ` .word {emit_int (List.length !frame_descriptors)}\n`; + List.iter emit_frame !frame_descriptors; + emit_size lbl; + frame_descriptors := [] diff --git a/asmcomp/sparc/proc.ml b/asmcomp/sparc/proc.ml new file mode 100644 index 00000000..82131d73 --- /dev/null +++ b/asmcomp/sparc/proc.ml @@ -0,0 +1,214 @@ +(***********************************************************************) +(* *) +(* 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: proc.ml,v 1.7 2002/11/29 15:03:08 xleroy Exp $ *) + +(* Description of the Sparc processor *) + +open Misc +open Cmm +open Reg +open Arch +open Mach + +(* Instruction selection *) + +let word_addressed = false + +(* Registers available for register allocation *) + +(* Register map: + %o0 - %o5 0 - 5 function results, C functions args / res + %i0 - %i5 6 - 11 function arguments, preserved by C + %l0 - %l4 12 - 16 general purpose, preserved by C + %g3 - %g4 17 - 18 general purpose, not preserved by C + + %l5 exception pointer + %l6 allocation pointer + %l7 address of allocation limit + + %g0 always zero + %g1 - %g2 temporaries + %g5 - %g7 reserved for system libraries + + %f0 - %f10 100 - 105 function arguments and results + %f12 - %f28 106 - 114 general purpose + %f30 temporary *) + +let int_reg_name = [| + (* 0-5 *) "%o0"; "%o1"; "%o2"; "%o3"; "%o4"; "%o5"; + (* 6-11 *) "%i0"; "%i1"; "%i2"; "%i3"; "%i4"; "%i5"; + (* 12-16 *) "%l0"; "%l1"; "%l2"; "%l3"; "%l4"; + (* 17-18 *) "%g3"; "%g4" +|] + +let float_reg_name = [| + (* 100-105 *) "%f0"; "%f2"; "%f4"; "%f6"; "%f8"; "%f10"; + (* 106-109 *) "%f12"; "%f14"; "%f16"; "%f18"; + (* 110-114 *) "%f20"; "%f22"; "%f24"; "%f26"; "%f28"; + (* 115 *) "%f30"; + (* Odd parts of register pairs *) + (* 116-121 *) "%f1"; "%f3"; "%f5"; "%f7"; "%f9"; "%f11"; + (* 122-125 *) "%f13"; "%f15"; "%f17"; "%f19"; + (* 126-130 *) "%f21"; "%f23"; "%f25"; "%f27"; "%f29"; + (* 131 *) "%f31" +|] + +let num_register_classes = 2 + +let register_class r = + match r.typ with + Int -> 0 + | Addr -> 0 + | Float -> 1 + +let num_available_registers = [| 19; 15 |] + +let first_available_register = [| 0; 100 |] + +let register_name r = + if r < 100 then int_reg_name.(r) else float_reg_name.(r - 100) + +let rotate_registers = true + +(* Representation of hard registers by pseudo-registers *) + +let hard_int_reg = + let v = Array.create 19 Reg.dummy in + for i = 0 to 18 do v.(i) <- Reg.at_location Int (Reg i) done; + v + +let hard_float_reg = + let v = Array.create 32 Reg.dummy in + for i = 0 to 31 do v.(i) <- Reg.at_location Float (Reg(100 + i)) done; + v + +let all_phys_regs = + Array.append hard_int_reg (Array.sub hard_float_reg 0 15) + (* No need to include the odd parts of float register pairs, + nor the temporary register %f30 *) + +let phys_reg n = + if n < 100 then hard_int_reg.(n) else hard_float_reg.(n - 100) + +let stack_slot slot ty = + Reg.at_location ty (Stack slot) + +(* Calling conventions *) + +let calling_conventions first_int last_int first_float last_float make_stack + arg = + let loc = Array.create (Array.length arg) Reg.dummy in + let int = ref first_int in + let float = ref first_float in + let ofs = ref 0 in + for i = 0 to Array.length arg - 1 do + match arg.(i).typ with + Int | Addr as ty -> + if !int <= last_int then begin + loc.(i) <- phys_reg !int; + incr int + end else begin + loc.(i) <- stack_slot (make_stack !ofs) ty; + ofs := !ofs + size_int + end + | Float -> + if !float <= last_float then begin + loc.(i) <- phys_reg !float; + incr float + end else begin + loc.(i) <- stack_slot (make_stack !ofs) Float; + ofs := !ofs + size_float + end + done; + (loc, Misc.align !ofs 8) (* Keep stack 8-aligned *) + +let incoming ofs = Incoming ofs +let outgoing ofs = Outgoing ofs +let not_supported ofs = fatal_error "Proc.loc_results: cannot call" + +let loc_arguments arg = + calling_conventions 6 15 100 105 outgoing arg +let loc_parameters arg = + let (loc, ofs) = calling_conventions 6 15 100 105 incoming arg in loc +let loc_results res = + let (loc, ofs) = calling_conventions 0 5 100 105 not_supported res in loc + +(* On the Sparc, all arguments to C functions, even floating-point arguments, + are passed in %o0..%o5, then on the stack *) + +let loc_external_arguments arg = + let loc = ref [] in + let reg = ref 0 (* %o0 *) in + let ofs = ref (-4) in (* start at sp + 92 = sp + 96 - 4 *) + for i = 0 to Array.length arg - 1 do + if !reg <= 5 (* %o5 *) then begin + match arg.(i).typ with + Int | Addr -> + loc := phys_reg !reg :: !loc; + incr reg + | Float -> + if !reg = 5 then fatal_error "Proc_sparc: cannot call"; + loc := phys_reg (!reg + 1) :: phys_reg !reg :: !loc; + reg := !reg + 2 + end else begin + loc := stack_slot (outgoing !ofs) arg.(i).typ :: !loc; + ofs := !ofs + size_component arg.(i).typ + end + done; + (* Keep stack 8-aligned *) + (Array.of_list(List.rev !loc), Misc.align (!ofs + 4) 8) + +let loc_external_results res = + let (loc, ofs) = calling_conventions 0 0 100 100 not_supported res in loc + +let loc_exn_bucket = phys_reg 0 (* $o0 *) + +(* Registers destroyed by operations *) + +let destroyed_at_c_call = (* %l0-%l4, %i0-%i5 preserved *) + Array.of_list(List.map phys_reg + [0; 1; 2; 3; 4; 5; 17; 18; + 100; 101; 102; 103; 104; 105; 106; 107; + 108; 109; 110; 111; 112; 113; 114]) + +let destroyed_at_oper = function + Iop(Icall_ind | Icall_imm _ | Iextcall(_, true)) -> all_phys_regs + | Iop(Iextcall(_, false)) -> destroyed_at_c_call + | _ -> [||] + +let destroyed_at_raise = all_phys_regs + +(* Maximal register pressure *) + +let safe_register_pressure = function + Iextcall(_, _) -> 0 + | _ -> 15 + +let max_register_pressure = function + Iextcall(_, _) -> [| 11; 0 |] + | _ -> [| 19; 15 |] + +(* Layout of the stack *) + +let num_stack_slots = [| 0; 0 |] +let contains_calls = ref false + +(* Calling the assembler and the archiver *) + +let assemble_file infile outfile = + let asprefix = begin match !arch_version with + SPARC_V7 -> "as -o " + | SPARC_V8 -> "as -xarch=v8 -o " + | SPARC_V9 -> "as -xarch=v8plus -o " + end in + Ccomp.command (asprefix ^ Filename.quote outfile ^ " " ^ Filename.quote infile) diff --git a/asmcomp/sparc/reload.ml b/asmcomp/sparc/reload.ml new file mode 100644 index 00000000..9d3898a5 --- /dev/null +++ b/asmcomp/sparc/reload.ml @@ -0,0 +1,18 @@ +(***********************************************************************) +(* *) +(* 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: reload.ml,v 1.3 1999/11/17 18:56:47 xleroy Exp $ *) + +(* Reloading for the Sparc *) + +let fundecl f = + (new Reloadgen.reload_generic)#fundecl f diff --git a/asmcomp/sparc/scheduling.ml b/asmcomp/sparc/scheduling.ml new file mode 100644 index 00000000..ca8827fd --- /dev/null +++ b/asmcomp/sparc/scheduling.ml @@ -0,0 +1,65 @@ +(***********************************************************************) +(* *) +(* 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: scheduling.ml,v 1.5 2002/11/29 15:03:08 xleroy Exp $ *) + +open Cmm +open Mach + +(* Instruction scheduling for the Sparc *) + +class scheduler = object + +inherit Schedgen.scheduler_generic + +(* Latencies (in cycles). *) + +(* UltraSPARC issues two integer operations, plus a single load or store, + per cycle. At most one of the integer instructions may be a shift. + Most integer operations have one cycle latency. Unsigned loads take + two cycles. Signed loads take three cycles. Conditional moves have + two cycle latency and may not issue in the same cycle as any other + instruction. Floating point issue rules are complicated, but in + general independent add and multiply can dual issue with four cycle + latency. *) + +method oper_latency = function + Ireload -> 2 + | Iload((Byte_signed|Sixteen_signed|Thirtytwo_signed), _) -> 3 + | Iload(_, _) -> 2 + | Iconst_float _ -> 2 (* turned into a load *) + | Inegf | Iabsf | Iaddf | Isubf | Imulf -> 4 + | Idivf -> 15 + | _ -> 1 + +(* Issue cycles. Rough approximations. *) + +method oper_issue_cycles = function + Iconst_float _ -> 2 + | Iconst_symbol _ -> 2 + | Ialloc _ -> 6 + | Iintop(Icomp _) -> 4 + | Iintop(Icheckbound) -> 2 + | Iintop_imm(Idiv, _) -> 5 + | Iintop_imm(Imod, _) -> 5 + | Iintop_imm(Icomp _, _) -> 4 + | Iintop_imm(Icheckbound, _) -> 2 + | Inegf -> 2 + | Iabsf -> 2 + | Ifloatofint -> 6 + | Iintoffloat -> 6 + | _ -> 1 + +end + +let fundecl f = (new scheduler)#schedule_fundecl f + diff --git a/asmcomp/sparc/selection.ml b/asmcomp/sparc/selection.ml new file mode 100644 index 00000000..6af79721 --- /dev/null +++ b/asmcomp/sparc/selection.ml @@ -0,0 +1,86 @@ +(***********************************************************************) +(* *) +(* 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: selection.ml,v 1.8 2002/11/29 15:03:08 xleroy Exp $ *) + +(* Instruction selection for the Sparc processor *) + +open Misc +open Cmm +open Reg +open Arch +open Mach + +class selector = object (self) + +inherit Selectgen.selector_generic as super + +method is_immediate n = (n <= 4095) && (n >= -4096) + +method select_addressing = function + Cconst_symbol s -> + (Ibased(s, 0), Ctuple []) + | Cop(Cadda, [Cconst_symbol s; Cconst_int n]) -> + (Ibased(s, n), Ctuple []) + | Cop(Cadda, [arg; Cconst_int n]) -> + (Iindexed n, arg) + | Cop(Cadda, [arg1; Cop(Caddi, [arg2; Cconst_int n])]) -> + (Iindexed n, Cop(Cadda, [arg1; arg2])) + | arg -> + (Iindexed 0, arg) + +method select_operation op args = + match (op, args) with + (* For SPARC V7 multiplication, division and modulus are turned into + calls to C library routines, except if the dividend is a power of 2. + For SPARC V8 and V9, use hardware multiplication and division, + but C library routine for modulus. *) + (Cmuli, [arg; Cconst_int n]) when n = 1 lsl (Misc.log2 n) -> + (Iintop_imm(Ilsl, Misc.log2 n), [arg]) + | (Cmuli, [Cconst_int n; arg]) when n = 1 lsl (Misc.log2 n) -> + (Iintop_imm(Ilsl, Misc.log2 n), [arg]) + | (Cmuli, _) when !arch_version = SPARC_V7 -> + (Iextcall(".umul", false), args) + | (Cdivi, [arg; Cconst_int n]) + when self#is_immediate n && n = 1 lsl (Misc.log2 n) -> + (Iintop_imm(Idiv, n), [arg]) + | (Cdivi, _) when !arch_version = SPARC_V7 -> + (Iextcall(".div", false), args) + | (Cmodi, [arg; Cconst_int n]) + when self#is_immediate n && n = 1 lsl (Misc.log2 n) -> + (Iintop_imm(Imod, n), [arg]) + | (Cmodi, _) -> + (Iextcall(".rem", false), args) + | _ -> + super#select_operation op args + +(* Override insert_move_args to deal correctly with floating-point + arguments being passed into pairs of integer registers. *) +method insert_move_args arg loc stacksize = + if stacksize <> 0 then self#insert (Iop(Istackoffset stacksize)) [||] [||]; + let locpos = ref 0 in + for i = 0 to Array.length arg - 1 do + let src = arg.(i) in + let dst = loc.(!locpos) in + match (src, dst) with + ({typ = Float}, {typ = Int}) -> + let dst2 = loc.(!locpos + 1) in + self#insert (Iop Imove) [|src|] [|dst; dst2|]; + locpos := !locpos + 2 + | (_, _) -> + self#insert_move src dst; + incr locpos + done + +end + +let fundecl f = (new selector)#emit_fundecl f diff --git a/asmcomp/spill.ml b/asmcomp/spill.ml new file mode 100644 index 00000000..eb92b196 --- /dev/null +++ b/asmcomp/spill.ml @@ -0,0 +1,403 @@ +(***********************************************************************) +(* *) +(* 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: spill.ml,v 1.18 2001/02/19 20:15:42 maranget Exp $ *) + +(* Insertion of moves to suggest possible spilling / reloading points + before register allocation. *) + +open Reg +open Mach + +(* We say that a register is "destroyed" if it is live across a construct + that potentially destroys all physical registers: function calls or + try...with constructs. + + The "destroyed" registers must therefore reside in the stack during + these instructions.. We will insert spills (stores) just after they + are defined, and reloads just before their first use following a + "destroying" construct. + + Instructions with more live registers than actual registers also + "destroy" registers: we mark as "destroyed" the registers live + across the instruction that haven't been used for the longest time. + These registers will be spilled and reloaded as described above. *) + +(* Association of spill registers to registers *) + +let spill_env = ref (Reg.Map.empty : Reg.t Reg.Map.t) + +let spill_reg r = + try + Reg.Map.find r !spill_env + with Not_found -> + let spill_r = Reg.create r.typ in + spill_r.spill <- true; + if String.length r.name > 0 then spill_r.name <- "spilled-" ^ r.name; + spill_env := Reg.Map.add r spill_r !spill_env; + spill_r + +(* Record the position of last use of registers *) + +let use_date = ref (Reg.Map.empty : int Reg.Map.t) +let current_date = ref 0 + +let record_use regv = + for i = 0 to Array.length regv - 1 do + let r = regv.(i) in + let prev_date = try Reg.Map.find r !use_date with Not_found -> 0 in + if !current_date > prev_date then + use_date := Reg.Map.add r !current_date !use_date + done + +(* Check if the register pressure overflows the maximum pressure allowed + at that point. If so, spill enough registers to lower the pressure. *) + +let add_superpressure_regs op live_regs res_regs spilled = + let max_pressure = Proc.max_register_pressure op in + let regs = Reg.add_set_array live_regs res_regs in + (* Compute the pressure in each register class *) + let pressure = Array.create Proc.num_register_classes 0 in + Reg.Set.iter + (fun r -> + if Reg.Set.mem r spilled then () else begin + match r.loc with + Stack s -> () + | _ -> let c = Proc.register_class r in + pressure.(c) <- pressure.(c) + 1 + end) + regs; + (* Check if pressure is exceeded for each class. *) + let rec check_pressure cl spilled = + if cl >= Proc.num_register_classes then + spilled + else if pressure.(cl) <= max_pressure.(cl) then + check_pressure (cl+1) spilled + else begin + (* Find the least recently used, unspilled, unallocated, live register + in the class *) + let lru_date = ref 1000000 and lru_reg = ref Reg.dummy in + Reg.Set.iter + (fun r -> + if Proc.register_class r = cl && + not (Reg.Set.mem r spilled) && + r.loc = Unknown + then begin + try + let d = Reg.Map.find r !use_date in + if d < !lru_date then begin + lru_date := d; + lru_reg := r + end + with Not_found -> (* Should not happen *) + () + end) + live_regs; + if !lru_reg != Reg.dummy then begin + pressure.(cl) <- pressure.(cl) - 1; + check_pressure cl (Reg.Set.add !lru_reg spilled) + end else + (* Couldn't find any spillable register, give up for this class *) + check_pressure (cl+1) spilled + end in + check_pressure 0 spilled + +(* A-list recording what is destroyed at if-then-else points. *) + +let destroyed_at_fork = ref ([] : (instruction * Reg.Set.t) list) + +(* First pass: insert reload instructions based on an approximation of + what is destroyed at pressure points. *) + +let add_reloads regset i = + Reg.Set.fold + (fun r i -> instr_cons (Iop Ireload) [|spill_reg r|] [|r|] i) + regset i + +let reload_at_exit = ref [] + +let find_reload_at_exit k = + try + List.assoc k !reload_at_exit + with + | Not_found -> Misc.fatal_error "Spill.find_reload_at_exit" + +let reload_at_break = ref Reg.Set.empty + +let rec reload i before = + incr current_date; + record_use i.arg; + record_use i.res; + match i.desc with + Iend -> + (i, before) + | Ireturn | Iop(Itailcall_ind) | Iop(Itailcall_imm _) -> + (add_reloads (Reg.inter_set_array before i.arg) i, + Reg.Set.empty) + | Iop(Icall_ind | Icall_imm _ | Iextcall(_, true)) -> + (* All regs live across must be spilled *) + let (new_next, finally) = reload i.next i.live in + (add_reloads (Reg.inter_set_array before i.arg) + (instr_cons i.desc i.arg i.res new_next), + finally) + | Iop op -> + let new_before = + (* Quick check to see if the register pressure is below the maximum *) + if Reg.Set.cardinal i.live + Array.length i.res <= + Proc.safe_register_pressure op + then before + else add_superpressure_regs op i.live i.res before in + let after = + Reg.diff_set_array (Reg.diff_set_array new_before i.arg) i.res in + let (new_next, finally) = reload i.next after in + (add_reloads (Reg.inter_set_array new_before i.arg) + (instr_cons i.desc i.arg i.res new_next), + finally) + | Iifthenelse(test, ifso, ifnot) -> + let at_fork = Reg.diff_set_array before i.arg in + let date_fork = !current_date in + let (new_ifso, after_ifso) = reload ifso at_fork in + let date_ifso = !current_date in + current_date := date_fork; + let (new_ifnot, after_ifnot) = reload ifnot at_fork in + current_date := max date_ifso !current_date; + let (new_next, finally) = + reload i.next (Reg.Set.union after_ifso after_ifnot) in + let new_i = + instr_cons (Iifthenelse(test, new_ifso, new_ifnot)) + i.arg i.res new_next in + destroyed_at_fork := (new_i, at_fork) :: !destroyed_at_fork; + (add_reloads (Reg.inter_set_array before i.arg) new_i, + finally) + | Iswitch(index, cases) -> + let at_fork = Reg.diff_set_array before i.arg in + let date_fork = !current_date in + let date_join = ref 0 in + let after_cases = ref Reg.Set.empty in + let new_cases = + Array.map + (fun c -> + current_date := date_fork; + let (new_c, after_c) = reload c at_fork in + after_cases := Reg.Set.union !after_cases after_c; + date_join := max !date_join !current_date; + new_c) + cases in + current_date := !date_join; + let (new_next, finally) = reload i.next !after_cases in + (add_reloads (Reg.inter_set_array before i.arg) + (instr_cons (Iswitch(index, new_cases)) + i.arg i.res new_next), + finally) + | Iloop(body) -> + let date_start = !current_date in + let at_head = ref before in + let final_body = ref body in + begin try + while true do + current_date := date_start; + let (new_body, new_at_head) = reload body !at_head in + let merged_at_head = Reg.Set.union !at_head new_at_head in + if Reg.Set.equal merged_at_head !at_head then begin + final_body := new_body; + raise Exit + end; + at_head := merged_at_head + done + with Exit -> () + end; + let (new_next, finally) = reload i.next Reg.Set.empty in + (instr_cons (Iloop(!final_body)) i.arg i.res new_next, + finally) + | Icatch(nfail, body, handler) -> + let new_set = ref Reg.Set.empty in + reload_at_exit := (nfail, new_set) :: !reload_at_exit ; + let (new_body, after_body) = reload body before in + let at_exit = !new_set in + reload_at_exit := List.tl !reload_at_exit ; + let (new_handler, after_handler) = reload handler at_exit in + let (new_next, finally) = + reload i.next (Reg.Set.union after_body after_handler) in + (instr_cons (Icatch(nfail, new_body, new_handler)) i.arg i.res new_next, + finally) + | Iexit nfail -> + let set = find_reload_at_exit nfail in + set := Reg.Set.union !set before; + (i, Reg.Set.empty) + | Itrywith(body, handler) -> + let (new_body, after_body) = reload body before in + let (new_handler, after_handler) = reload handler handler.live in + let (new_next, finally) = + reload i.next (Reg.Set.union after_body after_handler) in + (instr_cons (Itrywith(new_body, new_handler)) i.arg i.res new_next, + finally) + | Iraise -> + (add_reloads (Reg.inter_set_array before i.arg) i, Reg.Set.empty) + +(* Second pass: add spill instructions based on what we've decided to reload. + That is, any register that may be reloaded in the future must be spilled + just after its definition. *) + +(* + As an optimization, if a register needs to be spilled in one branch of + a conditional but not in the other, then we spill it late on entrance + in the branch that needs it spilled. + NB: This strategy is turned off in loops, as it may prevent a spill from + being lifted up all the way out of the loop. + NB again: This strategy is also off in switch arms + as it generates many useless spills inside switch arms + NB ter: is it the same thing for catch bodies ? +*) + + +let spill_at_exit = ref [] +let find_spill_at_exit k = + try + List.assoc k !spill_at_exit + with + | Not_found -> Misc.fatal_error "Spill.find_spill_at_exit" + +let spill_at_raise = ref Reg.Set.empty +let inside_loop = ref false +and inside_arm = ref false +and inside_catch = ref false + +let add_spills regset i = + Reg.Set.fold + (fun r i -> instr_cons (Iop Ispill) [|r|] [|spill_reg r|] i) + regset i + +let rec spill i finally = + match i.desc with + Iend -> + (i, finally) + | Ireturn | Iop(Itailcall_ind) | Iop(Itailcall_imm _) -> + (i, Reg.Set.empty) + | Iop Ireload -> + let (new_next, after) = spill i.next finally in + let before1 = Reg.diff_set_array after i.res in + (instr_cons i.desc i.arg i.res new_next, + Reg.add_set_array before1 i.res) + | Iop _ -> + let (new_next, after) = spill i.next finally in + let before1 = Reg.diff_set_array after i.res in + let before = + match i.desc with + Iop(Icall_ind) | Iop(Icall_imm _) | Iop(Iextcall(_, _)) + | Iop(Iintop Icheckbound) | Iop(Iintop_imm(Icheckbound, _)) -> + Reg.Set.union before1 !spill_at_raise + | _ -> + before1 in + (instr_cons i.desc i.arg i.res + (add_spills (Reg.inter_set_array after i.res) new_next), + before) + | Iifthenelse(test, ifso, ifnot) -> + let (new_next, at_join) = spill i.next finally in + let (new_ifso, before_ifso) = spill ifso at_join in + let (new_ifnot, before_ifnot) = spill ifnot at_join in + if + !inside_loop || !inside_arm + then + (instr_cons (Iifthenelse(test, new_ifso, new_ifnot)) + i.arg i.res new_next, + Reg.Set.union before_ifso before_ifnot) + else begin + let destroyed = List.assq i !destroyed_at_fork in + let spill_ifso_branch = + Reg.Set.diff (Reg.Set.diff before_ifso before_ifnot) destroyed + and spill_ifnot_branch = + Reg.Set.diff (Reg.Set.diff before_ifnot before_ifso) destroyed in + (instr_cons + (Iifthenelse(test, add_spills spill_ifso_branch new_ifso, + add_spills spill_ifnot_branch new_ifnot)) + i.arg i.res new_next, + Reg.Set.diff (Reg.Set.diff (Reg.Set.union before_ifso before_ifnot) + spill_ifso_branch) + spill_ifnot_branch) + end + | Iswitch(index, cases) -> + let (new_next, at_join) = spill i.next finally in + let saved_inside_arm = !inside_arm in + inside_arm := true ; + let before = ref Reg.Set.empty in + let new_cases = + Array.map + (fun c -> + let (new_c, before_c) = spill c at_join in + before := Reg.Set.union !before before_c; + new_c) + cases in + inside_arm := saved_inside_arm ; + (instr_cons (Iswitch(index, new_cases)) i.arg i.res new_next, + !before) + | Iloop(body) -> + let (new_next, _) = spill i.next finally in + let saved_inside_loop = !inside_loop in + inside_loop := true; + let at_head = ref Reg.Set.empty in + let final_body = ref body in + begin try + while true do + let (new_body, before_body) = spill body !at_head in + let new_at_head = Reg.Set.union !at_head before_body in + if Reg.Set.equal new_at_head !at_head then begin + final_body := new_body; raise Exit + end; + at_head := new_at_head + done + with Exit -> () + end; + inside_loop := saved_inside_loop; + (instr_cons (Iloop(!final_body)) i.arg i.res new_next, + !at_head) + | Icatch(nfail, body, handler) -> + let (new_next, at_join) = spill i.next finally in + let (new_handler, at_exit) = spill handler at_join in + let saved_inside_catch = !inside_catch in + inside_catch := true ; + spill_at_exit := (nfail, at_exit) :: !spill_at_exit ; + let (new_body, before) = spill body at_join in + spill_at_exit := List.tl !spill_at_exit; + inside_catch := saved_inside_catch ; + (instr_cons (Icatch(nfail, new_body, new_handler)) i.arg i.res new_next, + before) + | Iexit nfail -> + (i, find_spill_at_exit nfail) + | Itrywith(body, handler) -> + let (new_next, at_join) = spill i.next finally in + let (new_handler, before_handler) = spill handler at_join in + let saved_spill_at_raise = !spill_at_raise in + spill_at_raise := before_handler; + let (new_body, before_body) = spill body at_join in + spill_at_raise := saved_spill_at_raise; + (instr_cons (Itrywith(new_body, new_handler)) i.arg i.res new_next, + before_body) + | Iraise -> + (i, !spill_at_raise) + +(* Entry point *) + +let fundecl f = + spill_env := Reg.Map.empty; + use_date := Reg.Map.empty; + current_date := 0; + let (body1, _) = reload f.fun_body Reg.Set.empty in + let (body2, tospill_at_entry) = spill body1 Reg.Set.empty in + let new_body = + add_spills (Reg.inter_set_array tospill_at_entry f.fun_args) body2 in + spill_env := Reg.Map.empty; + use_date := Reg.Map.empty; + { fun_name = f.fun_name; + fun_args = f.fun_args; + fun_body = new_body; + fun_fast = f.fun_fast } + diff --git a/asmcomp/spill.mli b/asmcomp/spill.mli new file mode 100644 index 00000000..dfd5f1ee --- /dev/null +++ b/asmcomp/spill.mli @@ -0,0 +1,18 @@ +(***********************************************************************) +(* *) +(* 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: spill.mli,v 1.4 1999/11/17 18:56:38 xleroy Exp $ *) + +(* Insertion of moves to suggest possible spilling / reloading points + before register allocation. *) + +val fundecl: Mach.fundecl -> Mach.fundecl diff --git a/asmcomp/split.ml b/asmcomp/split.ml new file mode 100644 index 00000000..34778e8e --- /dev/null +++ b/asmcomp/split.ml @@ -0,0 +1,210 @@ +(***********************************************************************) +(* *) +(* 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: split.ml,v 1.9 2000/08/11 19:50:59 maranget Exp $ *) + +(* Renaming of registers at reload points to split live ranges. *) + +open Reg +open Mach + +(* Substitutions are represented by register maps *) + +type subst = Reg.t Reg.Map.t + +let subst_reg r sub = + try + Reg.Map.find r sub + with Not_found -> + r + +let subst_regs rv sub = + match sub with + None -> rv + | Some s -> + let n = Array.length rv in + let nv = Array.create n Reg.dummy in + for i = 0 to n-1 do nv.(i) <- subst_reg rv.(i) s done; + nv + +(* We maintain equivalence classes of registers using a standard + union-find algorithm *) + +let equiv_classes = ref (Reg.Map.empty : Reg.t Reg.Map.t) + +let rec repres_reg r = + try + repres_reg(Reg.Map.find r !equiv_classes) + with Not_found -> + r + +let repres_regs rv = + let n = Array.length rv in + for i = 0 to n-1 do rv.(i) <- repres_reg rv.(i) done + +(* Identify two registers. + The second register is chosen as canonical representative. *) + +let identify r1 r2 = + let repres1 = repres_reg r1 in + let repres2 = repres_reg r2 in + if repres1.stamp = repres2.stamp then () else begin + equiv_classes := Reg.Map.add repres1 repres2 !equiv_classes + end + +(* Identify the image of a register by two substitutions. + Be careful to use the original register as canonical representative + in case it does not belong to the domain of one of the substitutions. *) + +let identify_sub sub1 sub2 reg = + try + let r1 = Reg.Map.find reg sub1 in + try + let r2 = Reg.Map.find reg sub2 in + identify r1 r2 + with Not_found -> + identify r1 reg + with Not_found -> + try + let r2 = Reg.Map.find reg sub2 in + identify r2 reg + with Not_found -> + () + +(* Identify registers so that the two substitutions agree on the + registers live before the given instruction. *) + +let merge_substs sub1 sub2 i = + match (sub1, sub2) with + (None, None) -> None + | (Some s1, None) -> sub1 + | (None, Some s2) -> sub2 + | (Some s1, Some s2) -> + Reg.Set.iter (identify_sub s1 s2) (Reg.add_set_array i.live i.arg); + sub1 + +(* Same, for N substitutions *) + +let merge_subst_array subv instr = + let rec find_one_subst i = + if i >= Array.length subv then None else begin + match subv.(i) with + None -> find_one_subst (i+1) + | Some si as sub -> + for j = i+1 to Array.length subv - 1 do + match subv.(j) with + None -> () + | Some sj -> + Reg.Set.iter (identify_sub si sj) + (Reg.add_set_array instr.live instr.arg) + done; + sub + end in + find_one_subst 0 + +(* First pass: rename registers at reload points *) + +let exit_subst = ref [] + +let find_exit_subst k = + try + List.assoc k !exit_subst with + | Not_found -> Misc.fatal_error "Split.find_exit_subst" + +let rec rename i sub = + match i.desc with + Iend -> + (i, sub) + | Ireturn | Iop(Itailcall_ind) | Iop(Itailcall_imm _) -> + (instr_cons i.desc (subst_regs i.arg sub) [||] i.next, + None) + | Iop Ireload when i.res.(0).loc = Unknown -> + begin match sub with + None -> rename i.next sub + | Some s -> + let oldr = i.res.(0) in + let newr = Reg.clone i.res.(0) in + let (new_next, sub_next) = + rename i.next (Some(Reg.Map.add oldr newr s)) in + (instr_cons i.desc i.arg [|newr|] new_next, + sub_next) + end + | Iop _ -> + let (new_next, sub_next) = rename i.next sub in + (instr_cons i.desc (subst_regs i.arg sub) (subst_regs i.res sub) + new_next, + sub_next) + | Iifthenelse(tst, ifso, ifnot) -> + let (new_ifso, sub_ifso) = rename ifso sub in + let (new_ifnot, sub_ifnot) = rename ifnot sub in + let (new_next, sub_next) = + rename i.next (merge_substs sub_ifso sub_ifnot i.next) in + (instr_cons (Iifthenelse(tst, new_ifso, new_ifnot)) + (subst_regs i.arg sub) [||] new_next, + sub_next) + | Iswitch(index, cases) -> + let new_sub_cases = Array.map (fun c -> rename c sub) cases in + let sub_merge = + merge_subst_array (Array.map (fun (n, s) -> s) new_sub_cases) i.next in + let (new_next, sub_next) = rename i.next sub_merge in + (instr_cons (Iswitch(index, Array.map (fun (n, s) -> n) new_sub_cases)) + (subst_regs i.arg sub) [||] new_next, + sub_next) + | Iloop(body) -> + let (new_body, sub_body) = rename body sub in + let (new_next, sub_next) = rename i.next (merge_substs sub sub_body i) in + (instr_cons (Iloop(new_body)) [||] [||] new_next, + sub_next) + | Icatch(nfail, body, handler) -> + let new_subst = ref None in + exit_subst := (nfail, new_subst) :: !exit_subst ; + let (new_body, sub_body) = rename body sub in + let sub_entry_handler = !new_subst in + exit_subst := List.tl !exit_subst; + let (new_handler, sub_handler) = rename handler sub_entry_handler in + let (new_next, sub_next) = + rename i.next (merge_substs sub_body sub_handler i.next) in + (instr_cons (Icatch(nfail, new_body, new_handler)) [||] [||] new_next, + sub_next) + | Iexit nfail -> + let r = find_exit_subst nfail in + r := merge_substs !r sub i; + (i, None) + | Itrywith(body, handler) -> + let (new_body, sub_body) = rename body sub in + let (new_handler, sub_handler) = rename handler sub in + let (new_next, sub_next) = + rename i.next (merge_substs sub_body sub_handler i.next) in + (instr_cons (Itrywith(new_body, new_handler)) [||] [||] new_next, + sub_next) + | Iraise -> + (instr_cons Iraise (subst_regs i.arg sub) [||] i.next, + None) + +(* Second pass: replace registers by their final representatives *) + +let set_repres i = + instr_iter (fun i -> repres_regs i.arg; repres_regs i.res) i + +(* Entry point *) + +let fundecl f = + equiv_classes := Reg.Map.empty; + let new_args = Array.copy f.fun_args in + let (new_body, sub_body) = rename f.fun_body (Some Reg.Map.empty) in + repres_regs new_args; + set_repres new_body; + equiv_classes := Reg.Map.empty; + { fun_name = f.fun_name; + fun_args = new_args; + fun_body = new_body; + fun_fast = f.fun_fast } diff --git a/asmcomp/split.mli b/asmcomp/split.mli new file mode 100644 index 00000000..57c48d69 --- /dev/null +++ b/asmcomp/split.mli @@ -0,0 +1,17 @@ +(***********************************************************************) +(* *) +(* 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: split.mli,v 1.4 1999/11/17 18:56:38 xleroy Exp $ *) + +(* Renaming of registers at reload points to split live ranges. *) + +val fundecl: Mach.fundecl -> Mach.fundecl diff --git a/asmrun/.cvsignore b/asmrun/.cvsignore new file mode 100644 index 00000000..ee21b359 --- /dev/null +++ b/asmrun/.cvsignore @@ -0,0 +1,33 @@ +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 new file mode 100644 index 00000000..63c99b5b --- /dev/null +++ b/asmrun/.depend @@ -0,0 +1,498 @@ +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 new file mode 100644 index 00000000..fbd8b728 --- /dev/null +++ b/asmrun/Makefile @@ -0,0 +1,195 @@ +######################################################################### +# # +# 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: Makefile,v 1.49 2002/03/11 10:12:43 xleroy Exp $ + +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 new file mode 100644 index 00000000..84cfc1ed --- /dev/null +++ b/asmrun/Makefile.nt @@ -0,0 +1,77 @@ +######################################################################### +# # +# 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: Makefile.nt,v 1.20 2002/06/18 16:17:34 xleroy Exp $ + +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 new file mode 100644 index 00000000..22a3fbfa --- /dev/null +++ b/asmrun/alpha.S @@ -0,0 +1,440 @@ +/***********************************************************************/ +/* */ +/* 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: alpha.S,v 1.25 2002/09/20 11:40:28 xleroy Exp $ */ + +/* 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 new file mode 100644 index 00000000..5baf21d2 --- /dev/null +++ b/asmrun/amd64.S @@ -0,0 +1,335 @@ +/***********************************************************************/ +/* */ +/* 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: amd64.S,v 1.1 2003/06/30 08:28:45 xleroy Exp $ */ + +/* 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 new file mode 100644 index 00000000..703eab37 --- /dev/null +++ b/asmrun/arm.S @@ -0,0 +1,339 @@ +/***********************************************************************/ +/* */ +/* 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: arm.S,v 1.11 2002/02/08 16:55:32 xleroy Exp $ */ + +/* 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 new file mode 100644 index 00000000..30417640 --- /dev/null +++ b/asmrun/fail.c @@ -0,0 +1,178 @@ +/***********************************************************************/ +/* */ +/* 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: fail.c,v 1.30 2001/12/07 13:39:19 xleroy Exp $ */ + +/* 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; + +/* 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 build the bucket by hand. + 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. */ + +static struct { + header_t hdr; + value exn; +} out_of_memory_bucket, stack_overflow_bucket; + +void raise_out_of_memory(void) +{ + out_of_memory_bucket.hdr = Make_header(1, 0, Caml_white); + out_of_memory_bucket.exn = (value) Out_of_memory; + mlraise((value) &(out_of_memory_bucket.exn)); +} + +void raise_stack_overflow(void) +{ + stack_overflow_bucket.hdr = Make_header(1, 0, Caml_white); + stack_overflow_bucket.exn = (value) Stack_overflow; + mlraise((value) &(stack_overflow_bucket.exn)); +} + +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 "out-of-bound array or string access" +#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 new file mode 100644 index 00000000..c7e29147 --- /dev/null +++ b/asmrun/hppa.S @@ -0,0 +1,550 @@ +;********************************************************************* +;* * +;* 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: hppa.S,v 1.20 2002/02/08 16:55:32 xleroy Exp $ + +; 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 new file mode 100644 index 00000000..9fe8ee53 --- /dev/null +++ b/asmrun/i386.S @@ -0,0 +1,326 @@ +/***********************************************************************/ +/* */ +/* 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: i386.S,v 1.38 2002/06/07 09:49:36 xleroy Exp $ */ + +/* 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 new file mode 100644 index 00000000..8f993887 --- /dev/null +++ b/asmrun/i386nt.asm @@ -0,0 +1,278 @@ +;********************************************************************* +; +; 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: i386nt.asm,v 1.16 2003/06/30 15:39:39 xleroy Exp $ + +; 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 new file mode 100644 index 00000000..b474a029 --- /dev/null +++ b/asmrun/ia64.S @@ -0,0 +1,530 @@ +/***********************************************************************/ +/* */ +/* 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: ia64.S,v 1.9 2002/06/03 14:22:30 xleroy Exp $ */ + +/* 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 new file mode 100644 index 00000000..78ff2447 --- /dev/null +++ b/asmrun/m68k.S @@ -0,0 +1,244 @@ +|*********************************************************************** +|* * +|* 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: m68k.S,v 1.11 2002/02/08 16:55:32 xleroy Exp $ + +| 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 new file mode 100644 index 00000000..d1714318 --- /dev/null +++ b/asmrun/mips.s @@ -0,0 +1,386 @@ +/***********************************************************************/ +/* */ +/* 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: mips.s,v 1.7 2002/03/11 08:38:52 xleroy Exp $ */ + +/* 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 new file mode 100644 index 00000000..14809a03 --- /dev/null +++ b/asmrun/power-aix.S @@ -0,0 +1,513 @@ +#********************************************************************* +#* * +#* 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: power-aix.S,v 1.12 2003/06/20 15:17:52 doligez Exp $ + + .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 new file mode 100644 index 00000000..6e9cf8be --- /dev/null +++ b/asmrun/power-elf.S @@ -0,0 +1,421 @@ +/*********************************************************************/ +/* */ +/* 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: power-elf.S,v 1.15 2003/06/20 15:17:52 doligez Exp $ */ + +#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 new file mode 100644 index 00000000..7017d736 --- /dev/null +++ b/asmrun/power-rhapsody.S @@ -0,0 +1,416 @@ +/*********************************************************************/ +/* */ +/* 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: power-rhapsody.S,v 1.9 2003/06/20 15:17:52 doligez Exp $ */ + +.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 new file mode 100644 index 00000000..14d5f271 --- /dev/null +++ b/asmrun/roots.c @@ -0,0 +1,297 @@ +/***********************************************************************/ +/* */ +/* 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: roots.c,v 1.34 2002/01/20 22:20:51 doligez Exp $ */ + +/* 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 new file mode 100644 index 00000000..089c6ae9 --- /dev/null +++ b/asmrun/signals.c @@ -0,0 +1,677 @@ +/***********************************************************************/ +/* */ +/* 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: signals.c,v 1.74 2003/07/17 15:11:03 xleroy Exp $ */ + +#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 new file mode 100644 index 00000000..7a4ef5f0 --- /dev/null +++ b/asmrun/sparc.S @@ -0,0 +1,398 @@ +/***********************************************************************/ +/* */ +/* 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: sparc.S,v 1.20 2003/07/17 15:11:03 xleroy Exp $ */ + +/* 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 new file mode 100644 index 00000000..b90d4cba --- /dev/null +++ b/asmrun/stack.h @@ -0,0 +1,105 @@ +/***********************************************************************/ +/* */ +/* 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: stack.h,v 1.27 2003/06/30 08:28:45 xleroy Exp $ */ + +/* 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 new file mode 100644 index 00000000..6c3cfba4 --- /dev/null +++ b/asmrun/startup.c @@ -0,0 +1,158 @@ +/***********************************************************************/ +/* */ +/* 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: startup.c,v 1.24 2003/06/16 12:31:12 xleroy Exp $ */ + +/* 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 new file mode 100644 index 00000000..bc591db4 --- /dev/null +++ b/boot/.cvsignore @@ -0,0 +1,4 @@ +Saved +ocamlrun +ocamlyacc +camlheader diff --git a/boot/ocamlc b/boot/ocamlc new file mode 100755 index 0000000000000000000000000000000000000000..a87d14a2fb282f7ba0d2fbc39201d051d5cc9033 GIT binary patch literal 916988 zcmeF)3%uS}Stt6^q-|oVXr~QDq{+^uxweHu14V3hNm_aVi%1K-khbh#lM-4$KzpIB zHnim;VigfDC?M!4-p0FwC@mb+k2ptXMCa%rM?H?08Fj|vZ4`Tc-#6@7Quft)?TcLt*`kA&yDjzG@$bUYbOYU-en;bx1I@ng4Qk(F zbMKwPcWE~_D^}mvczT`xw%eECKeNB)zP00%~WPSe> zSwGP2n>2sX&hq_eZTZ*e!w!Ry-HBfqxM$t5Wa_UEJ{FKQ^0<391uFxMJ#yFAYSqgRW}cpdf%ZkgV*>Ws zZ_GA#I=dbW+kvr|>LGjs#o@JMq&@CsUPO(?}VzWKKt9@O3*R!YQ`SYEb z=WFS*_qd>PwJc+N_XZlh=8Bd(bou!}#%0&*GL}cSoD<*?WA_Lh_OZVpJ{tlt5u?wB z4RkGL!*yAIU(n}9Y<2{Ew^!{|-fGR6=-0}2v6BNiwg1}SHv+l7KcGh(#2?m#Yf1uKIwmW#!mPUnlg>=Cbu30TzWFaxA@Rx6rJJWdlSEQU+_>+dMoDYrQ%ZiEB94r6)&->amDVYHuqq9>-)N1 z&0QaSEFjC-DIWEV$7HJ-IsZ7;PqER#A>NArlZs}FUPdGhBQZGKxD|6TlD+0lO0)ac;)-fAYvwVJuzdoz&3W;+tc*) z^xA=*8|ZZ%-TS#G`qYYNnpnx@MVae)&TTx-Tk$+$;Q7KvKO;Pzp~d%)|Mbv9d@K6b zLX*8csG9rre>n8+!k_yCF)?=k-PnzLn|^GN`@Nx8g}3y4ThoKq-Z;?Lh32=o)}Ch! zJlh9)%|IVF(0}u(hx_`cp?jNtFEpL*gwpwQnH%Hrp2Q<8$KZ8l@T%*#G+wlJ>p=hc zKOT~AU&;T2Hs@|I?|D%2eygp?y)|c7?@ZuPryp%Ra%ydL>)nUN^V5w-ec*8)myUP0 zwVIRjZ=N!DUz>9Wkm3F<8Mn7Jwp*iHucpg}1C6JAaR1_2+wok}c*=+JQ*58z)@qKO zPj7P-J7{a*nT3g=at3l^n>t+3A>Y$hP$4yEYy10 zw`7e?PaNi7KFHWR&{q%iWdnV|KtFS!pAwqhO@V%E>z%LOz73754J zm$lxzhkZA<{*|r&>ej!e^tEOUuba`ozRi38q2~>)e^cw<()E0QUZAJXv-r03F#mLyZ+MR*9vxC!v;{t7bS8^A-+nnLsgOX?7{Zu$D z&G^6hs=8PkE+-nxJ7@A-?5 z@A%2ZV~@R_A<*k{CvON6)`_26(r*peybzEhj(G){++$?R_vOJw!8L&xi&5FOCu6qY zrO$lH*qN~=4)Vz^GPGR*{@TxXbN14K_u7E1+Fb#=+=az^N5=9;w>>p)Z^`wHTNkKH z?URwg*PefxPW5j| z>kY}bv!*Wa_4Q`IHU9Rwz(Zff(zxs*x9p;8TOd#WF?z%V%!%>InJZh#U|-oLh9Awl zwEnWTCeF79>W01AzJNV?cCyJHa$g$Q^U6lkeRF`fe5-unGgfzGuL;N?3qSj6j~@Tp zzQp2t3P z)w~>$WB%-5Q$WA@k#}?E_}$xeWoSOBOEy={tk3wWz#g*LM$fLm^SGW_8BU&oVp0B- zZT5<-c6CsC`*pXH2>iUr%zB`d>84f65yfZSf*SB0kk&LHLaP+vQ@W{$mlUkE%0 zRs`n+8-pDI{qupw)?Nla^t=N@iuSo&OpNh*66)0 z5dS9ycxz98H{tK;vVULZJ^$@zYrmf_7k6`X^)kxWer_qbWR%@xw=Ps-qo3RFI^VAEMQyJfwO8HmWSkfWpHA^ckec< zgKGk|x@YaJGl|dLW8S{?0Y2lBIqiMvzeU$Vc7aeh?kx%Y(EnF|H~Bn_h)a_i|@+!1{IgGt88^%YtBA=;yT(o&X^tn%q-Vm#M(VOE!Jv_ed4rKod0r0 zoaG+w4K(kqnE>fU36+An@~;5T3V>Z9J%R%Com;Qaf}aYLYahPr#m zBEOzh*2$~0vM=MR#d-(uJnQ3gQ)v48nshIkcYdbjG2wY=+L`&&E^h8C`BE2UPuWuO zcrKZFwoHbolbAvC30PLrQaW@?OE~Y?-ey8cKG|cL{Fm3PljXS0tB+cdn}1GE_W?y}-#kGiZJng{hJ zcE-B{x_1R)T=gj?VpY#?wV=r#J=0{KmHAO7-%93@b|Hu6iqE|53l@qO!O!Y^ld`GS`n^vG==!;q7^8lM_r>%l-*cKhyYeCFi+1%X_ltG38xtC*JE>@znjKh8ki?c=+USRPGY{4NN4>vLV%K1+9h ze%)>5hqGLM9IXwr&aa$k;y>#hQ#{M&vPDcQmisf7i&_5kvE)O^u;*y~7-Ja`liHH| zsx9`qOM4sTdodg9y;3~NMzJm%zanFG?2Pi$c-lQ#@0FG7uube!k7b{|+QCEJ!|u2~ z)^l0!eOM~aQTttqvibW4`fZKg-t0+t%=hINyYyw_Rl}b8{fmQm zdUsYo@BJG6gx0GK^l7bM+xqpb_bj%)x%FGqpBJckjXv+3=LXhZ5d3u>nEXb|CwT6% z*?4yw^Q+F#*%{Y!Kf{SWap>ikCx@*XIje$Qf!OuuDCFVure5zektTjqFCHUYvay(b0iFQ4$4TN#L3*)*TA#ujP$|v^Ak2!6Yy=P`^F?-3C2eGSomyPV5b!YVPW`E_{ zn2i;G{rWanao-SHZ0Xd>cD9Ih-6v;dJld{qD%SYx9F*;4FWct=ZLwIhNlnSSTH%ND zUH3m)tk(u?E?@a*uN;`u$`7^D`|+gEi}}F^VDnOU3m);oPcPe?Cv$YNac>*TYsKnl zbns&-9Sc)*&{uXlyvxBee}h7cb5!!?!auI5G3RGK&_;TGGJ7cIb+(?8IXMv9 z{#;?LdxCA^uNl|-M{g&)(9U_)y!~oh&aL-(pAW6k%@)mlCvH^>#^UwVV7ynIk+N5= z*-r+e}|wTcn>-u*OV zva}JrD{%rVr-yyY= z7?uzJTKuh=s{Gy^TgBk5fi<z7Fut2U;K7&7qx1@@DBPdA*EY_B46)_xwFizxQbL_xpNzy`Em4 z`NiVX%jjiKlgFQ)zvt=qmVWObV(PoGGlF_2K|4#@ct5yf%+>b<>VY0T-7w7``xc8g zo4h|Q=0ow6onfEo-k+Y{uMO(1yg6e&v(0mPU7&8wd1j*R>FIsl93R}{?k)T3Zkct~ z-V~nxto?9kO{{)!GJ5z~yKTzctJ+*2)A6j;{d-^I<%=Bhb6n$_cSZk!lYW0McbcrlYO>#3y49zgI7i!qs#i1~ zOPW>Q3uxfUPj*P-3Uk7lQs6uqyTa}H;nC%%c5GbDDuk)Mqi zkMk?q@7&50-DKKlk7v*`v;Mezf9~CgjdOuG-4hg#b1e_<8)G(;b$Z|o)LF+5az&5v z?tp*tLoWO1z=LKpSrwQ0jJ0~NS&?z^@L@jC@Q*xYKl^GtpRvaNWkK0WriQPNqo0GZ zTONSza=`C?ul;6v&15NNem^7t9A*v4TpyI-IxvW_9d-*c%wQts5_Vu<@Tr+*l=jCUU`fUN7|95;+ zt7z^29O(KPaW7+4WUzfha7ti*zkbG`!|#)fJWp>to(6%?gog(ii2L9h2=o9j9q3&GSHgIq&YUn*Z_4kNJ7aAn%6;`Zovq#Qdy1A}6xfwcZ(^ z!#TOA>0XtwJEnSL_Rz04ulHTA-ur@H{psDwdVcBop)bDGjjq1<=Gy%F);ojtx&QTB zTF+ke8LdC7^=G&KsjYuX>zxn$=eGWttv|2zU)K6(4gH0UzNq!jZvCaLe{Sn9YyDTG zCzG8Tf7wbec%S+}V0~-g%!7E|9LPo8IrnCKec(>h?h9@W#9Xuf$)I2Vo6vHkS^v90 zEorY0{wb(C(04O_&yP+vX#Lp!^MhXgRiS(Rzc{RaJan)Bw?p^(KM}guzczHQvmevH zDJXq+XM9ai^6$wQzuIwsKcmrnL4RpSXE^zrS@zccgBi08jbBZaezck>I>X7|xA_n0 zuL$I8Z<~9t(fiV$7<^@**;~0hkn!^1#Q}aaU-~^ageH@WR|a@|r+8DaKQK==K6YEz zd#2)lRnYIbG4!|xJ@UP*(`l+G$%Ln(7pI154Y+*;)=*$^AZ#x5L?w8}xmh@W#zOhT(?g->lP4Y)? zk9Ku{7ayI^4{izY%cb1%(YW}WsgiBq*};YY4?D{Sd-17ZZI*s~bWhW7KmBwUAN>i_ z;orq^e#kDp_JI1`6FfE`!~T(HU*_ob?m~{37Ejq<^}#nyeLoP`SFyDww)4SQE8=ox zz#ewWDbTq-SP1q8?j3gWbw_~Lo?Sto6a4td)#UJKY<^w%<+p4;KjT?8pOUpTfm+1B zGEk3wU-2-ncKNk7VBcrUH~D9eR{E#q<5^js=9}E&?{hz^hDv^4caOAQ#@Ng4QudX8 zXN}$sf!Ll9RNkxR_hpVxv-a>&qjP5<4rHDlEDN++L-%W=uF`REvg?pd?ARQTYi$2q zz%KT?U)Wc3#{IKowBgaPPfhkVlF7!>#g7Mrie2SdjkE7{!R5ipf#(^&oL|1UTlj*{ z8R3g{d&x1jui|lQ#$?U_Gs4f zDm+v4S^0Wb zcq(6NsPg4mvo2tRc6Wg9YY}Pp1nYw{0`YiNpy3m1In)jYa*kL0$e?Fe>%TI+nBEoe z4UZU(Jakw)QW>wFA;a@VV^g2&6_eRR=ZS6372D|bc}6=BuwU)q(c@7YcLint-i*b~ zd!jv03i!0tJ~rXkpBUILu170_?xpsrH}+P~Pcc7|_=fGD<)`E<%i3K5*`OBGp7F^+ z)p*@M*AMj{mcw_VGhX%kB^isk&$jB^eSUrLv0xgXc-!MFXtU&eLDovnG`?PrbH@+* z?rP(7hh?*kjrJJRU3<1-B*cFAGXe+1J~2Qr6kPHoV_7!?w*?TM?WS z@EgsSK0XVf*--k*7xK-&F1S2kpYzCPd3=7rm$|?ketV6l)n5PaCYOh&Y%qp<15GZ; zDBAZe*2S`HygB3EHui`^?Qy2<>0@mVKK`hOipvEV%j^KJd~)~gNl*1&fx?ktVG zQv>(>MS*AaT;MshGtjO+)J^UYzPO_*4u6xHC_Z0jIEkdu5I2)!b3XL$$m+`@02-14Q* z<$ubWeR%XfPv}#MlRl}Q^eMwhpC2tu`uxaa(&wMaO?sbE>|>k$uUqeDMQHzRBK`kt zy=Ms8IoA8PhkBo@^#8r}zK=uuTOvEsUmTPl;v?@>XL2of%YrvG{!22(cVZweRdeEG zZ^^KZ#-lGjV^CB2)vc!sttRwUv!^wBZR?MuX6@hJ_|I(plUo1Op?8PluU<^hU)FlD zaR$}~nlr!#XW-Jn8Ca8t&{(TiWZt<@w-*HBp)Q?kbtz6_qn^bEzvl=3&4K5d+QxHs z;GCQgcwad_sGK=(({zjLQo6;OE&TaR^k@5Izqo1qt@Gzh8~3`rGx3joeA^iCo!@G0 zp^dGNzL6uh*2KrpN{z+#vOs+4oC{tRRNTcGKU+#)h7-Hhm{xX^WuMqgvtO*#J9+99 z@A-ko2fkS28#}B|<5?`1_Je(F*dFjxe12n!&+I6l)s{H$qx@c(@s(|!ea<-kI+xb* zUmM8HRRLer+K$#&PHzb<2I~Sgkp<@m8r|gf^5_)LI|F+>qb?5iwlQA$du^lfzAm7L z4fgX<{+$K(vd@{&u0GUF`0;2*lTY%-oXr!GHs)0Qh|xk@+lHdZHUgk96l*pbd<`^4w925HmcN7s12iIZ5Y4#Y*x zC;bn}w_LDwtSLEUJDeYA#j{wQmG14~m#<~PwELm2HMUjms#fS_19{@6j_NKbJGNwQ zYruXDk27oUDBoOPi)2Fi#s)m2F0w0T{9&hq3$SwWb0`uOj*zI|-JTOn+zt22*&QZ<1J#*;ofxYm!ybPwB z_*~}%znrZIzgYD1WdB+AxGT+%y6t;S*6Fd%hSL9(%(IiX{CwXNnB&8`pz4rKWRPbpF8GXZ4al7KH)6={vLq8p2voVmlYjADjQHi;Z}YxmY~pT0F?&bHzbi=i2;I{yQgS zU+=GX1g-oP6aKM@9nHRIF;j1$)KkWzmwg>z} z`^;&~zG=QX_x!hB{>tJ1+usM}Q>@(={1NAA?}LxeyjFF$R36D1b2U#u+L%iQHES=Q{Q)41w^J=4z8k zX4M?O$?NNmOenvKXVgV@#fv{`O1$>Aap`<*qw$XKeEnU}zw?E4$-A80o;6~zIuMWk zJh9umVBMYUgYpZ%^*(lDxLE%9M6UbVcTblF&KOxY2CoRzk9b($5G)JU1$f}rK+T;Q z&}EK|Y^zv1(^V(-f1o{^<)G@*c@%?sCvukR9l$fY_gjqEWKY>Q?H#Dz0eoL3zxI%I zNl|lL>Z$8k}jJuI8JUyTN^MO`;YSq{oWv{Wh@_`(U%{K=J0yf+pu<66W-oQHC z6nsrUSKX)LJkp-4EtCw-4cJR}EME1@= zlM{0}PKST~C6~Q!_LsgFWqf(S25}#Gdp>bq5qPh8Zm=VeqxnF)I#7G=pKID!K8@LU zSL=;;1+#3T$IqM=(vw#*GMvcZ8(YP2lvDQhGVH@AUi#aD@+HHEt+A={-rJ1tu7Gai zQJxq+n6-uU<)4~Yt72NZ(YFWmo72d`;~c3){uaNv(*toI=kaR&{^E6h#Hc?%>=HBn zZ4c1Pg3T?Smt|bFvoB*d(BWLEnSNcpSg+^!i!-h~^QG##?vIjN&v^UAhkP|C9`ga4 zi`RO|q2JzX1A2SDouM@{)r&ilEt=Sryk2+J4qmY>xf%YmJl~r+v2wO5hP~X9QMS^< zFFt*utBF}U-QVO^Z_F2V8=oBT*VucQT6=GkE6?g;OVHo-bd^0~CuTiuuJ@U5{T#W= z1C1X~nT!rS8_Ey8we@X{j@>vgLa zt=C=8PV&T$u8jfv?cEiyll;-As)f?AJv_$n=G2Xz+?qc&;}2#&-QhVrzn!_|>G?bt zhyfeKx%Osw%zw@Ml73rY-}rAzuZkSD*81<}-Hc4~GZAhwgsBcCkN8INBcVT@08JUg_lj=pShy> z@XFBalt0fk{mP(Z`!{7LwYh%&1(`oD^UkrRw%Me%zcNtU-ZjQN(Zydp{9G5Xr)tW$ z*5$(be4tex7BVJB{dgZW&zG{<@BQ?)elqldtp81*|J&C8UF-k8_5Z8&|1k9b*yvBS z{-0X!QV?J9VYgnsjP;)H=2oZkWR=d)z7q2D|5(N9O|Jh{={DbyGn+`|tBWbF&Y z)bkI>zCQR^p!K$Sw>dc5lh+33$#uRq1ngNC;N2EzKCAR~T)MYpt*{dBXZVq+iJ zr{3-hG(Kp~EnoHqp68VlwT0dtlq|88*9!t??sdTx!3P5Jrtwxict@~L{n&eZVDFa% zYl2gQ6N2LB^NOJMh*jmC9%KIW{Oq$PUl#>zS{ob}@bg*0(}GI_bLykF`Nq(%2rA!d zwc;j*eCYM{_Vw}L$2q~*1SLyO<^rwqsy6ukxPUBlFQ0$C|Lm<===q%WS$=0}V)rHK z-P!6xTxvfZa_X+-gYk0$%^06p$s1aIpw&mw&=z3%fNuJX-O=P3-x|>Q zhp~gd_K+!O>{lOso%Z#~ma5Td^_b;}J>ntmY!i>o0sFQDTLZR$7y$c!C>Z?}7xsuH zpT8iGD}3X8<&@6KyFF~7V|O54y8?Gj<+oy1vhC5>jAt>M-=Fn=jW#={UmK`_ZGrY5 zTHO`>&VhbkzR%hbKA$!CBxZQ!>Fcv*4y}g1CUmW%pB=i_b^1U*cA)=!_}Szq2ing! zdwD-S(C;7UcMtSC2Kud`)vemlyYrxGTfeH&YQ#A(=e+6puIIB}t>~RA{i&^Y=b<0p z`nBoR8hM&pv+n)UIdp&jSpv9_UcHH>=9#NbHwNObnVSpL_Q*TVlQ)fj)_m9}{B_Q5 z?r6RjO?TZ*qYX>#bq>e9r)17PI@mi+e(}i9eSs#P{k**;hplz*nSZ2u>)gu;(BJDo zyHoh&o)8bYnzqk7(`f;|>w;el`251)_y+6if~~>XfjdzhS+{mvAkW6;$`-QSi7SHQ zx5mC&bC$II0okVqWQgI;K)X6nAKqQ)F}^VW-xh3#k#YZ;S$Da8>vuD|4bjXjo)5TbhN{$}NC-Tk-ZVSpr zHoF5V2BoX^(5rdh`I&%SeB?9P=6^OAYmX0VMY6DOCQ)Bkm*gaNb`)ll;tTDZHp3JE=GQV-Zu--@Q=)DPm?lFVl#B~Ao+cyH6B*A*FYe^Yi}B__e%uwe2Rj38 zN8la4Xga2WzFPyWANRZmvbJ|vuer)szjs_C>qzF#3tzpDRGo{Tp8=_@Z2|hy;r(!T z=a&GrlA6 zT-&Yi($wQzz`kb(YlBs7>^@_&dGTkDv9rK-<0l667`q?E-`F#Ry~cE~U)<4;Z?qVp zPi=JBQ182Chv%C8WlP1Y>^ZrumrZz~?5enxZF=ivU&YrPdnzyD=3JYn!&>E}?$XLB z8?Cch?D?Q=4%|gsf~|r20M83^#_k_-+-2mu7s+9V*rC@2;&U+2+#hm6zC3C79O@=~ z?ohITpJxYT$jhcc?D6ou){4L9ad+$s*r(?k-P-6IKQ(gL&&Nvw&G=c9(V>`HpXN7v z#9WT7vwe3U2P*=xFn4D_pBT9-$)^`jYPKS6@0t*=pmifIqY1wE40?nl?-_zTLLG_$9d*X; z&R8Q?Qy1cMd?1GNfu_b`KG4*t9MHwjWdR#6Y&8GS&kV$i-`m=__tEDHd)deKI!j{9 z2R4_#_F3Q8`WpA|s`FXX?3*`8t8>6!d)QXG^mw6sqMJ|b=7Tkj4{~xtkdL#I|E9z8 zj2D7BPZ>_0hvxSV^KwQXUn>UFd=!7+XFs0iCz@4$1|%xU7hJix=Qbpd_q3appC#^Q%pyXR0h`7B0;IP|gT<1othjGHB! z-d>LJQnJea)0^DQ>CN>y-y7OITl=_I-B&G5i?3QMd&S5e^jx4$YmI)sm0oM5%eZu% z+{V*%$)(!Ui`)8uFKD{ed97{Acx6B~-OZ0r8v7zFKrjvi#zQDP)KIS!3lXG7FkSRy&1H5dJr`>^C*%gQ>e!QN| ze7A><;wnyf>15}8pt*-u1bE1-b^P;z#t(bSpS~u?^M;>{?SYsc8~jS{Y5k7i>jJj& zTU||yx&8J|i}@@+olEk1ANWSE`OydbTIHm-!~E#OZ#5s}Z87`hpkj#EXR~QK7Mh&- z^jgWCpHPQnh>`d@d$q3b?@O}9N|SH=WY@gCH6DGeSlV||pc(T)oq30z3&gZ)s^aTz z5<|Mx7#-rQ_4L1_PPy0kv|=(k^lrqydLC4bh*_O8y!^i~n8j<}eL{yg*7sPu+Z>(G zXk&Fuwl(qF71*Or#J6h3_>Q1*AikdU760`a+Xwa8%3e0u>t;hPn&*H2j!FOAIduaBWvs#men z>UmbS>c_j`xXjfV6eo@EpN;eIXxm-3R$SDKdT`h9WucA5Wm};6_uBGb^aG*oVVgPo z{ysmuGAFm&1N+VYRsJAxx(RQ;wk&h&hyNbps|Wg?(DG99$b5U|(oN33b45Q{ABg@{ z>FH4CHUEzGGdA^Qy=1ZNy^+P=-nYBMkJlL}UV8sDyku&x3=bW}r)Nv?v*);fIP~A- zwRU2lAN@ZoJn~>o?M&l&Yk1sQ*6IwZ$zInlhsS>RZ_Ts$xcr@pbdy-1cf@Wv;s<(D z^L2H`{l4$dzM`{q%(40TUr#@Npr1U@Umlu0?#|NXXPJCBwVV5;%<-w0eeEFYm7&9O zSk667jytPruyWqV(Hi>1*5g4}-i+bo){6m}eR}fsp4a-*TEDjS>sr5|^{2PqIl{lS z^?XC0+4?87{_NI2we>q%?{35YjMlry(e5Dqd>hZD*XUzQ)#krxXS3q|)AG81G+tD=-nOANiMsL`Ggi9HXRH!``Kk5d+J>2&9Te6 z#;&qa%rrcFp}#;5z15$c@%q5CazlWhUOgT$sJ?hhmVVr~H*@;}GQfDWb6Mspe$F?D zpIR{%Gx-xUGIj@aRm}J`D`xB_Up!6-w2Fr{^3{`^p~atHrw8KaUFZ0qYVqofr`ftD z^S!NXWNX>T-qA*}c(i|B6OohHxgRw8)sT2rZSZenATDecSMg=DT7daL6E|_076|ukm zrx|m)rcy|SKI0x3)3zfhA4CCjQ{cJcc(0aOTqEDk=jJ2vM{Phk{clAQ% z#H09~rKR}Exib(GHrMA*vdocnWg9P6!(z@){`0ZMcVtY)DS_t!9csGbGxq!x@)9-Ia~50FS`PAd;R9+XY6O`ul;;GzU^fb8GYZ|-rI}MJ$+v= z-qU1Sd&879=UKf}j__8F_GYYp#Netn76U$sfioZmRfpmr-<2D&s&Stuajm#d^IL4m z?E6`M)1g(KjM>N!Hp)L6>6?}(_R=->N0TS#gp9tQWiLLtcw;atPj8yCCQllFDwgV` za;JArmj{}Bnv<&@<9$xXmSAfjFIwfS&!6~wHgwY`cjaGypSZu=5etDae~jg3TcG*7 z2y8=J|FtRKH+-ahmQ_#N8y~scg@-V%zS1PlYZ_c!{^L{p~bo9`S#3ZY7!&o zf<5B-bxpT9xj!+eeb#?$knL|M)q0kXc}({A^u~d{Bs4y9<*V)+cVJ)F*3o$M#b*rO zUG=M5e`@R1f_cv#wIha_e2`Ij`1TV}GwqBjFRy_8xNpp`FThoi> z#eqf^J4acwe4G!jCNE^zuO>C}%bxOOA#-#VuXvdo`P?nv(9N&Rcw3U_Pw?S@th<8^!IJ~czJtLv0ev^LvAuHc zjI0Z^aW1ADzKi*IcA%!|q@ONw#REvQeJ!Lf9r7mD)=D;BVDp~f!vXp7zz(&dq1B4>%$AA|nZ5sPGIw*}Y=ArJqQJiO z!F-^RFPFVM^}i+{V_Bfi_XVC8^&GBq!RNJs__DcdqO)u;moQBJod;Qq*+R~=xZII> zXN0X{#cnohZ0h57Pv~pge7ec^1kXrMx5l1dh&}9mb0EI-)-%C*ed$2&4Xu&=q~N*$ z-_?P3Zy+~ciAY2LVo)@l^G)XqjR))w-D6xw*LtlLU473p&Q04>bF=pK>pf4+myYUt zo^fv4o<81crKjaXI~ZISEDtL0YEtg)5m)ndcE|e3(&6)n@5banU+38ULyj}q?~}x?oHt(b9FFFj`OC8hqhEaN=Mv%NNh^S zG+X-hI(y`cGdZw55I1xFmXr00p>yTDizPko5AE*2IjwVtc1BhN;`oihj=(vb4>a+- zA@F(6UOLh2D!Od62D^iO0sXsL?~d6JoYi{vigE1~2knBOYJi-Z0=nf+J>YXMyJOY` zYXb4G=AN~O@ASGKORxG^8_-)aNgKIM#W};tbDcasvRe*~r}@n`I(on5k8HjD{O32HS9bj@-^nZA#iM)|V~xz- zp1M!)?hSf-s#f^ThHHb51X_Q8ls4t%iN^_`|Y)-a&&6O{rV{D_N+TwZ0Y&R26k4SzbWI&vslgr8hvWy!GLdT z0(zVau~t`dsjs@VXIB2~c^U|ackr1h~cd#X074o4YF)r_1~&5+?aHOdf!N28X+ z(fv^JGo0kCuQTg?t;xeJsg<7${B7Oe4E#;yzSh{Uk?S0u8uYal^6;8_s9&2_cj}w` zzIMfCsrunZ*>Fb2pUe8G`-T5!cDg^8_lwVZ<^Q&f>pVVMch1{d4g7lgPXvEF)PeZR zZ=F}q80TX?(E7ZO_g>Y0JwM3!WaN|i=0KgO#s2fWIBPEq$OdwtAJ<&<>Y~>BeKlUH z?`?2L_Ov_JUFa_JJd+2s@08WE+IA<1i)WepmtW>8Zr1FrHF>QyXP|QIc`e86?eB4S z$id*kKwWCJ=j4p-c|qW;YiwQFsrz=L=ib2WWAlM|{;CpBDnLA7i#Zb7F8&pj8dj{+@qF*1tKB2YYq~ zj|s%B;^;X`2HtO(GC$^o?d<#NKwLCAP(MC@zAdQSvQaE%>HF5KjdoPrD$Zy!ZV9dk zDz{@U`Z#{3`I4Kp0Xh5^pHcqm%$1G&9pj`HtUC|Zt5)Pft;ji<#V0SbYV@s*mpzr| zN2?wWMCMJwta_}vezbgf$rN9dHF=kd}1b;CR!cjui!-$|9|`s)m$I{H?;VP|NqzHr@pGjma0+pgQsGpt~YeCT55moQ{$h?cVcR^ zVobJofvRDD7rJVA*157*^F9b-Ia}+{dqB2W+#h)-B(Ht# z@5{UxpWb*%k3HJm!IuZC5NYU}0`}uMG1wD4FDP4Y$oMsZwfauXvnto$dO26)9nta=&7>w>EFdbXaO zIkDld=AHa;lhLPtma{7~ne5pRICpcws6*}2!3Mb-b?}Ys${oG-R6O_xY*0t!$lc8W zS!IKmXlyX2t_xKY_VW3C$w|fG+|c~D55M@afnB36v~}S3MS*;73dE{x#;4IsE_-$d z@*-~ZRE_M*SdPlp0~xOk#6w)g!oHHtZeYVLfw-`h4+jIySj;vD_80%{8RK8s=IShs zzF60KKhg3i_GFwCtO?jnzdd{*(;AzrFZt|R8?eVafSMu0cLOEE9`Q0K$44qJtP_97 zJouSH#hO2N1njTcX7hZYZ4Ts9{^aiY0bA}3d^hF{YWD=s2-XI8#RPxpVYk|J_Ql6q z#en?v0p81k`9Pyv&NO*EBM=k(WYM!fI6F|EV%V?otzQdy_;(iU{XlHFGCi4lgMERz zTNhjv&`;iu)>o}ojj5xBpnNSGGBx>~g)Ql~26Tb_eLUFL*ArdhK;O3o;H0`$^;hdV+B$va==$Q!vAy>ENuCM)p1VSmX^)(#L$SiIZuhkH z+W$NGVM%Ypt3t18{A{`*bg%D%f&ZiVp$1<|-VcP94|~c6XMi2-)RTW+P_^s);6FEb zN8n6-JVNF9l7QXM4%DCfWG-Oyu7Ioy0=jm$UQN6%a6Z_^e;`9&wxI1tlZPhf=HRyA zMFAP|*~?&uJDeSANn^kBq_OwZfFE+UEGQlITv0Qha1N&fKz+b-Bv+4C2KQCZM@zB9fagyUrf%AJqfR~(+ zhoAO4`#+l6Wg|bFJNA`r?37#ktt|^Qb8~_G*lT@Tz#o4PfKE1-Eg4Q^(y6f@zc&8- zO^)m(b6r5!#(-=-892Z98>f{W_-o82F;Qps)5WhpiEaDSmu<&qtl5jN_i@%7-|+H{ z%sy`+5C2|>{TBy(rjKpqi#R?$U>95KxxpSWSC4W~erGtDQy+VR4+mm@cYx;gT?PEtjkAJjjMdmbX^y}qCtd0w`THBLx*>-Qn=LeSu8rnMf8e8i3 z!{3~-{F3J!vB^38?LhOL23x^-ROk51ANu9tsln=iZ6^f1tdE3V2#QxPM||mJRcz!! zWB1j;Pa@Ljd~fPV{Ex=2lfysFuJ6wLXqPjvlwEg+r)nU>iJfcHzX_4X&ic6#JLekI z!;!*!3EnR|iajM;?LWWU_mYg=qoc2DGPjtoeGb*cxPR>u`$v9fa4~(yW?k&mVAYDc zIw`39Jt<>#s8;Z757hOt;8X2c?m1s_?3XM1ou|76*yto(DhvzcPQQLb!n-4Uy$kFIjqkDqh z-j{^_+CXFPzQ8@ApWuEtIe|Axm43y+1j7$ z`N_&5S!0}U%-Uk>)9iE)X=TrjjK96n>~IH(l~z1^GVbFop5j~eASY^C-0EJ*aB`26 z{~c|9Lwe7_bphF>PyP3`^0LtLfhLB|Z@)e(hxpxJbbe>xJo87~wgg*)swHdg0r~0I zR)@YKpmQNmqjQ0KSX^puTgGJh_n~C*NerA-zR{_7KIa3?+Pp!Un6ZtX(tm8mrN6HM za>-`{dGxZY^pfj7IU2p>mtOLK9`R$_e4zC+TEw!9h?`e43-6T_s|dSATcM~I)CdPW*Zwz z&ym>1XSR`HKOM97J9lM++M(ZnV_tmhXPdq1Mh@`s{nqfXlWntjzM?&I@XL|C?0RPA z>FxbIsnNZi@5mfqHng6u%5T*Mes<~U(EB-oUd`%#x2yN;*dEv`)~}5nRbTr;i-SDS z+3N{8c~_oG&t|gtqz=TTc=<-2*cA_()(2H9_{m|j8tM1jt7d_oI|4OJ-a_liW#_s8 z|5JlMj~`^oojE+G277`J2V#A9@XVlOl^-RGeZ4Gpm3;5T*1Yo;4;^G|59}3>pUC#jzNQ^lw3B70jPE-;ZLW;?&Qo*i(ScjXVxnZWQkEPi`|tQKGs^r z!n*J8#lpQb##c;^57d3d*4e?UnWMk_sTy0zoLVOT;=pr#Sx~W4cVt^1W!L*r$=)BH zx}P(g#OyQCSNUZR@cqTX1A)5U8EEFcv-89G(yN_q0lWPz2zI#ttclae^Y2=0#YoKR zGr)?B>uw%b{OWl_H(<|P zup{{Hpz*dMU@qCi_0ln>4Unvd_9GXH|isd+VWW-v__T_w-Clgpxe`QJNbp6}Cm-#cZ# z>O<^%x$hfzpaCOFXsc~^+r<$xeu{NivBl)qX^xCK9@Q_K5+|z@fOwX+H zXIsYVgB%Tw=WpA+SA1t>Zj_m+hsho3stNMe1ad&W_SccWGJVnhy_&lN*u6I3tMe^B zbgv4Y8@Puwap~vlnZi##_xksS-WRB$?+e)S?0~*aL0|V3FLsb$`@TQp13^rE==}5= zn}989)cX`#4bBJJ{N(=+ooDy5{OFx&J>7c#(gl2EF$);xdt=q&W|LQZN$ec@F%;&Wmf+t=5Vn8~G9@{Gl^&YBqZ zbm_B?ezF12`an&V&Hjyi*~|`mYR&I$)Eax~?`vCpG(NB!ud%qy2U^)&HnGRPl8e_| z(G@o~)}CGu{iDpv)Bdd89$XRdLw@;vTVU>tpw~^7#%ANP|AdT7jE z{Fhv{-^azcVpqOaKE+Jq)5btvr`eq8iBHb^wDn&1ES{3#ovrMV1Mfo9WcK{i)+;Vm zKYZ)$pl8~?UT$wk$&u%UU|+-eHl*S0b2LqM?W^;=DSOye`E-^vxgX*?_QWNuo# zGX1bU{3i3cfj!z{cDbJ_<~t|cpZ>guc9y2uTjy+=O(n07X`e$j;u+)K^E}c#ll^Gr zc~*UiFZ&M!k0d_XwrEc3{JboDk0kbeO|cWL2AqqH!LndWur&~`y}{A$xgmS_F4l|X z`KykA=cPx$!^Wj_@m0JQvxgj?w;pVK#eZ$+j|7^!batHUO@aHMkC&L$vrbIsf{I_A zi&^|9A0@x%(visLbA67S<^PeKsS_fn?#f<{7&z-=?Ra0X=bAwL#i8EM$2;xySra>- zXYhJ|!SAl3ORLW>`072!{1XCk(8xb7*ch-!ldD=U-m-`Ml|fJUcOzM4$BK^cl5Tuy zH-1hxCfhmC*v=;L8}ol*=J+k3hmSsxBhK>5MzmN@tNBb%WXm!8#+cN)^Du3_V{*#ALaG_uuCg>WLz4QjB#)A$(^`s{A5e5xi7p^E)UcV9pX`S z$~LXyLQWr-qQ&*rfUfe9Trt`hkk8I#fkuY8ii>v*ja_7xo$SNw9b_)RFHdS#K8|hl zbJLd&I{R4QAx{p0JbqSQ?L}+WOEwv3>-4gp4)WM3{v{V(zPvhP&6+uDy-$bg`%s+7 zmwP(T3ibxe19!UkiNCzqFE8q{?o;pFn*uTxTa%CSx%R#;b8^M+#rDp!rDT@RV!jkF zT}P{*|NN_c{4ghXo-_6AQ-7bSPqXY-2XfEnX}Pc1s)yb_^aVl1=y@4yRTuj4KDs?W zN0*P{k)w5iR{U3HtRBSNoY4c7Y+f9b-vEYLh7>Mp9@I={ue z=Ex;a9{6`}pc%8vn*6ZITwlx1v|8YM#S0%=%xWJQRpaz61oA-s(dL1kva9NZKm2B! z_{;_3!9M(Kv4y>_5+-luHx_!MJc%Iwl$z{KW*Ip=jyIEfE=YM(BRE^}f>9=i0|&xgu`TGH-5)J^<0yf@$vpBIAi zk8SeenRj|{LNKoLdt;v|Q4?Fmc<~O?5?I)Y=asR%|u^-Q-fQ`i?Pg=!& zZ^k8GJjj=`%D2625MS#x&!?vc8v;J83#{AAR%fqj!q_~YN?!5tY2@qUR(6lEac@-o z#I|B4SLVqa_r5rD4+P>vf7#^BRh;^GklE9G*Z3iRFiY13S?l9vuNdl|+j>5gEVhs* zr^f}_?tlz+>pflD6`0eruXxnkC4t7j{!SJj>lX)fZVu=mvwxQlc~~Bua-;P+>9&7) zFz)Z;O(*;21FiJ%zvR(@M>A)w?36!id@6g{?u?cn#Vs*ZkBXnC&nSBK_r(btDQ z5c;8C{`N2J_4qxwp58ssPY+G6_>m=c$F;eV{dai}sCBmeVdz!qOTRronYntt*1or8 zu4IdM|GtQq41M`^LdNgP@ABDGvh?=qYrpaKfGukASN`JAe^92+@%^{*`;g{*9;yA`o4G#UZy)G44)h%Z?eA5{wV0RP*AF}w5A^2H>?oi4 zhh7_yu`Kxe{IP&qUlqE1(XVOry7c%bISs$HiXVS}tjWNGe)mA%ADZl1|N78;Df(5R z%P;$19D3AoS(`h#+joAOb7z&Tr?k1s5qTTiT%V8CZLYU#d7JBP`=9w`d$!DVIzHa! zDlT;VY@2&x$M>z7>+A6ip?iI|w>_Q@W&iWr+@@}BbDQh+9hbRY_TS}~?AW=r+xNSf z>uc^;2Ks{o{lf$Ou7Q4AXgc_)e`eF=9K1Yhy*)1;_I^cZzT4+s<*$8TIPfhW=)cM@ znDsvVe&{}i|J$(szJY$rK)+_77Y6#8(ENZpZ*{-1oBiI^^**EX!~J+%_8mySHqbvW z@Gf;xpvfJX+XM9i|2h9)#D48h@1qZThjB}8C=oXKi}s0^;`L6^0Lc$ z#BcsrGruZ5JNo$#W!_y<=YLnm_P8(K+hn2T;{MQepX?4z*4G5Ze{0swZ4c_Meon?} ziw*SCH7kyHX3hTUuWa2Sq`#^0eRJ#I*7~=% z{##mq+tA<9=(}3~^{uZwzNyh;U-_;6&5iHdhWn9 zceVaKt*^SPdi1$n+{(|_HF~Vm^0VGAu4sHCeN~&UeC=uU<*k3w&|f{!cQv~7jro36 zTYq)yU)%bxZGGAO4UPWB){psKYJbIP%=eh*H#Yf|&(bsYV|~4&?W?@Kv(eR8zTTVp z^MV6`=03pVIrw9N_P8H<97l za(u8Xu+RG0foIdo;GDqv&OnpPvcny)5PV5+ao~KjeN8~8dzB2e*Y{5keQBVb7O-V) z>(v&U*z?6f`Jjf`%|4BP?A;OkyMRpbX4ATWUFJ3fbb0>rV|8#OGJiaLqfF0%X)-fC ziHrV){x7$pdr>UpPRw2s+!=gl@W;VZlfb(IKNJ4V;53G(?F#kX;UC}>*u3GJCZx#k(|eh*CVa355%@3z0djb**=f26s$Dy@=W*s;rVrL;2!cW;x5uW zlj^=%>VCC+{9=Eoin)pOJH^76pn zm0Cz&&tUxQ+!?Tk-F#yw`qaR4#5!hdRdonIRmSyZ+;(KvJe=v*|>kc z?EZh)yA!ZIi}GIJNLYf{MFqsFkS__45Zq9(Xbo>n*j3y>0R=Sy0>q_S+oG~qacSME zZM9nMY3-uc)~#B#YL5p|w5|KD)w=In>sGhs{C{7bJ4~j}`z;}8&$&8We`fA`X6}9F zdA>LAmxN~9aRK>g^|C&Y7kcRn^sf#o4kf$yNj#>><6CR{ z{tJ-z_C?5JTh#^|_*}Ml&s-76(K`ZmpB;$DX@MFs_m4q4cY0{~B)9VPtc>ZJ3DoK& z(9Q~`ty3S9K(kIP4-drl{D7ZofNYIy_mkYo8Hpt_@nxem`@}>Or>Yk^=yY$&>kWgdV?F=NcfDFWBA|o*SLe@1?PCW$CAVxn zAUrYc?Ic&*5Qr0d*;nrnC1;x574yrphb`^;6`}bg7VPCm*|)QH$wTYkV(rTI?QxW^ z#{|yD!<#!;%~k#KXDA<+fqa!7Jh1kk19ICtlWg+D z&-ozN{4s&rQI}#Zhvbs;&VXI!HU?t8Dp(SjAFJDy;kzf^74$Z=I_xFm-NBd+`JSeO zy>z@MaF@4!ii`Mb&WEP2IEeuq7qCy=*7HDYwmsjreP)2a5F9wH6Mr(;{ocSCXl)Z4 zezBho>jU!9oJIVd{qYK|@F4+nK8 z^8X_ZEsjS7bZ7_W`xta;?~YEjT{c`Y(Bg%9t>;U{T#v8k3t4LW zp3V1a%&|?sZ(t37ZWR0M5xbhJUJPMvK%VAqq)XgB8o0Zj9k^eX1)foF3D~?Pu%BK! zE(uNx4hcN#)Z2lT1`iKBH|%G}(xGRwXW>D1wg1)`lVg9yzUJ;2-b^6AF@5&WeZ=PF0lRA5@flmE(JxM=zhdwtlWFpgSF{|X z$*cE{hhKhu(b1=c<{zE>9y?2Y&C7wB|Cd0`U%|OF&oOt=hTzaZj1LI#P6*VX zdbeDSiRC8(^Tp3_`}r<;$Awq&%#ZO~J$z{8)p|Cl%`sW##9-Q-dYm>Ve$(dEMa{J~ z?iGI7Sam4Rns}&H_Nci>1oUqSlCERbUY%j{=I|~F)FRnpkAGx9Kc1%M)Z;XrasqT6 z6kHIHQ#L&^<67gKof%a9pzjx`BX*(Lb9C^DKwg{;_0Jyj_a6Ftr7vGvzB{UX+B0MM zE1$$x;}dyv`SkG2mrvqa{_w>doev4D`IVvHJ3U`&ZTa4=Z+*WgYsHEzW42Zt#8DhR z8Pwf)Va64Q^D?&Y+@Os^@!L4qBbF71eKOX>fz6u&GFrPghrT$lMxC{>LbvPLq5iCO zR^4m=8nkP~&CgGLEb-cUsdaevi;0+u0noL4=ntNQW{dpyc9Z|>LD@zY-fskD|Ja_V zkL-Ecls)|aRKQpEdN!)brGdFm2mPJz{IzjCG<1LN?EOqIP3~tiw=;6-eL~=_5VN8) z+-~#dGG3_c^RxC2ff#QH>h5{Oz&km;HT2aQKCKVLOAT!a$WR9*5INPH2Y5t*v7A;18ewvNpM_hP(AUp;GVGz_;DLuG>&BtYv%l8t z5uTiso{tPa+Z_>}J@D5*+4lPlCFk{7BNy$OH+O5Emo@65UGueW&114g%;Z+wuLza} zdk5?)U2@@aNfQUxKH00OahHB>|ncitWW&*P2c9&zk6N2 z)Vej{^?5!xyz;l!-8ek8P%)%q@9@f3bzEzIl+RGD<5Sg(_1_F1&su%O-`uCV-%I(> zu+|!DTi@O>%<<1$>*E^-Ih7MOpAeLtdNjVh>_pdkJT#fcVvjC6_5?gy|jb99$jdwF9O%1v4R|U>) z-DUCtWP`g?%~`i3sC9Mb<>Bmrd~58Tw&qIBM%yMqGu z%nZG;XXfd_@<6j@pTHV%Ixe^@*c4cQO5n~FH~!x~pleOQw|~h!NCtf?0&RU@{Yils zl}zjL$&?E*t2o{?Spy>izeS)xN;cti#;Xlu^E%Kci@@+ zrJ&Z+&u`7Unz2|M9I&Ho+MKak(vwY=`)XOBwyo128))L#)(W0|e9()Z7@ZT4ReJ1s zSWs&=Wc<*EJ~?A&#$GwDb>jQ*hPJQr%r1M}tA_-1uL{IXBZCcR2WqWimErdHr6V)8 zSN?im#i?ZQr_P4ht_}_l>;r4rP8U1W47jtIzJ8ay(!urWQk z?Bhr2v&VDsei^V4szi4xGR_zQ}`9rmTzBM7v68h2IyWH&>@HYKDwYir~L2NwetO3G)=y{fS$e{)Ck-8s~r@G zXI~SZ^_mz?s|mScW62PI@glEsNKc#NLqabJ$}eMU*tyvJweKTps^~VSV(_LRr*zOS zhMqU(jt#W4g0hJ{YcSLDtAVrUS8n96?j>{Vr3-&W;2o-B+sZ2ctRt7ta#uMgqvVd| zO+4j|KK6^bR&nohcks69IdkXzu+1GAUkvI@i;cEEz~dJ?*xu(8f1&xNv*NMXe7i3y z$JO__enppSbuspya$)%5e^KE1>^|lf|J>!ysJ_pP+oII|BdF0U7Qs`kZ(6m+q4@ zJ}+R$DS_D9r#&$sUw+OX##R3zXY17-bz*y6p?2QC zTTE}wKc=Ja)Y1M8F8Q%u`^VvPA9?hCD8J_Q^r%(xj|i3oa&UG&cUY3oLzV?gL)ZF> z0om5p-!p=bCk}UwzI_Lpe@BHbU3<`9sFi!9M$~e^+$2`(G8>KJSQnHP!Ba@-S~t z@!4^M@ZCH1u&;Di&kjJ_tFQINFP)yZ=EZ7lAa0u6J112?-rM-_q(Jkm*Vr`^kjIvX z26f)#MI34m8`$6Ov9I=cKFG;Y!Iy)h1N$d|c2>X!a_fwEPHhaxnRf2IJ2>~Xmp-;S zGhYn&tbXvt$9?dHzKfmeTh@qu{mS=$$w1X{@4|^MCI18yQ#OOawmp- zsXU0EJQOW2TIEG-+FZ7I`AX)d<)z(MF)075Cd64T+=b%8mc_)|zxh+~c6Vu~2Bl9P z`0C7Q`Kv~D`26^dq1!Wf(lF0oeN9kmXePsQ8ps@>o|G+(?{de{AjM#QSz+d-X>#tf{8dOYLpPjwdXEk@d;LL#k zO9DQx3Gm;Pv(d*e?AiE;)3Jy&@j5E_T2Q=Jj_+i(^h>%kcv0x~Y@E^2_v+|7g(go< z<+q+`{N}$pSsPSc^3&byY<)dY^S5>ZrELkm6vrQ%Ufo&8mv031j+EhSjNRQg57gfB zfX#Ao(?IQzb$J4JvtdldB+xDjCI)F21QUa_(s6jkD+2kP1X|@~_l%DYx*JuRl+ z%AWE!!`YbLB)xd`F_qWz1M%ehzXkPdeqYA!n)e6n*wu03ABc79v$(uHwYPDYt2kGD z?O}74%+?8CzZi(`@xe^+$Uxm39FVU@s)qUb?}2^K4d`1I@UdcaXvX%aJLj3cTLtRI zz7qrTmj}+Sm=$0CR|FL=_R=YDeO;*!=iu9c{VM~F&+O9L+9C_&<;sA(8b2&!F?eF2 zmF(|i+{@;x#&&hr+J0DQw({LM6 zf>lACF|lE%`kBklI=5_;t2Sn0IA-r+>=RFU>1_*Z*0!1S_Z#M|)5?YmGOl}ZX~r7^ zHhG3z6*%YOe{pbHAQl>*d$|<@`z!wL6!om0+A|b#yA5M`6tkSM?SHPomMa3buu~4m zre|fKKImbeIW_wI;M)m-I^<((-(jIOd8`!9jKZD{!S4~k!Pg)f%)<=^QU^Pg?xw>j-|{=;s5`5b#PwS!N5 z*e@XeS%D`1Y$B)X+8lfFoEJ8g|L$e+M=dwNK+&63;%S+hXV@JjzftZ~Uu&2)XOvZc_d+opb`Toz? zSTS47`QDm+?gDYs>e+Qb#%(Mr{$ldeepWq^VQFeZj`YU{8hf>03feQ|Z0?HtMGUmM zFO9{*Gw8_l>Zf9NM8;|gd~UC==V|RxllCkL+UH)o)|%RPX~xd)K|#C5T~ce>@x#JL zyB|&r*ydcfJo%dm>U>yNJTZJ*P_@+7h8Ww&o>K#@Y`8GvO9JPSE_q@w{^p>6pJNkU zR|n+XDbVJUcfCc(tMgj&E{g2lzTG1aeF&yL-ki37m~RV@KJ4X6TA38{Kc>us+}?|M)O__hp~8 z{L$*Z{-uoPveW&e=GgetyuaHTp}%T`e>J`|V?I_q^)MVab|#iL%D!o_Y;8OxI{9#I;wYBtT0HrqiKnqR-gt=TeqB7jn?LVzW{wZ! z=Y+tS^E@?H*Yah&ci`DsvHFwY&(Qc{zRf!t|JwRBtv>c2{5hcW=d{?=#`eU}ZGGG- zw3w6+{#;P(*v@ADw)?-^{reYJ4|H1}H;D~9Qy&Lr-?aLWvzum~ZSpb`T-#XARU_{1 zQv&Cn?q7;-adIbL9h@HgcHnNg*~r{E!`#hB=59C4-C|^}?yG|`M=u{If#&XEkG$Yl zeacVOr~Q3>Rvz2Ds%f;nYTcO3w`^pynmM!cZv&D0H z_h47*uei`(w$NX;h*xh*J+G`QTdXtYQ^jcSj4MWBQ85yWijf?N5j(`EY#^s>U>h6s zYXa?0^98Jyest)~;X7wv49bU@VXQ9LRrl+XjPIE}){!a4$A;!d(f^h&QP{^;e7>OB z+xF~0TcckLoB?t*aXlb7CO9|-ITO!|p{vs$9>_gA-4$#?R}Jfr3|0(0@xtT(B+ym` z{I;*gC7aw-c%JB2KMi=>X>B(0gB*Y}n&*fnrgZYBVv61r(EFP~*>ge04-Lq+rp=ESdfs0d$o-{3#Vo_^ zaj;Je#PzCxO>&oij%fB=KP6+fh=pb@ud`d9n%-XbP}QxorY2ju&gJ97XH&nvr>kb^ zA>V$uT~IZ#op_2*f~c&P^TsWw0^h%>mtg9;|Eg zK!4>yU1?%V<^e(F%Q{fswVn;mkN(&|b8hHpbJFg;S>`HN7ia7YEDh|bm^oKfLu}#? zUd^|2ZGDkp-4TH?AKo&=LtU{$JlK0iuwQU~aH~Mv)tYA%du9gu#PsOp0b6Q~JX&*R zuqvR>9YQu6)(7REedeuWlUDc31sRjMG9dFegU1FHmrWVhJlW>Sx2E(~4Cny!YKgy( z8v2sKmzien*D~H5ToROhWAfy^mqAa-FJ1G=%a-lmRkfeJ4+-oCdgM82+xp1#WmB!Q zr{#wneePL*aNu0Yv4I*WADlrs<-7Z~&YV1~4VDG+=Kj4R(8OQ8;~yJn@<@+$WR^U2 zUb=3b@v^`^ji2(Pjt>d!tC*{gve(&rOF(wrBS&P+H+%k1Vnn8xki$NpL zYwGu5kI8tSKrLu|7u!~z^>q(EIb-dn0iVgO`|OI0$-hz1?zt?qdcGjNJhJV?fc+~1 zcHy~u@D2_5L`LPpeYN+%XUhkJ{_e4!EOBb@9(I|l;%^F>0e?MP7nO_oY2&!)6+xb$*#|E17)#sw(C(biLosT0jCSMGFw@=R> zXQOI~o%;`{SS`jcGU;gT=Ep+qmSeuN`?SEFMBcPG(KjaBp7PiD9r0IR{?gIMjqhs6 zI{CJCCa73fjg0M+lXjn&@_THLT2<#81J6}DHV1xAHP-5#v}%~2*4S5TREsI(2EcHRzvUo8?E=AK#!)LjgJXdq`>Zz{>~}tI!o#soWVN}(by4f}M(_J8^Vy{0k zaK8AqGO%7w^v*NXnv$XK*KZ1MbHHCP?(JI=Ud7891@V$Y;|;;S!B|ZADZXOKSF*J7 zwdTcEZp>RR2mIl~p@DT{_wATno{Q7$;-6>mX@Oj5J7Y`TlYC-tYX_O)vpi^Hb#Q3s zM2`4JzqsIup`3|>-aOyQkh5ihed277*w`ay_OyB3E3{U&v7yGTon_l?GjB{Mx#W{e zzM3JQUiOaVm_D}IEB1#5`vlq(w{^4ftZ8fUMxm{1{ahK^I{NftQ}gZK)?aJq@{b<= zl^-P!uZ<=9D`#RsuC@GO%QPK)wwFyu2P-4k+3*~EWpEx|uvf4&=yO1i_2jGxmIPnQ zbA`OpU3<*2+aB|^{%ct;KKN`nB#XqZw}BsG-pUI(D{Ce_8RQzfXD$oqb~uGvZ0chCscDIey73yUD*aAjA8Cvq6XW=;f^M*)2xP0)CKNz!zhD`o)QC z@gv*1`DF8R1jAo00=@W_y8MD}y}(zN`)o57e7hb>5#N zwpRT2%DBy~=N@@lgeDSuVWlc8UieslC38)$Ui zCA^}yg#K=z|K89mFtpzK^+Ug5=#LxvFLy~aeb{b2KA&r zVCdB#y843#dfCt~AA0wcb?RB~F3>L<`dW9yK;LTUZ!`2q4*l(iUOep=WBnb6{#S_U@U5HScbyz2x{DNIqr)b%Q64?k={;G5uA?oBwB=2y8oR_e$(4E^6i84ZYYn zRZiu*WEM{zi?>+0i(P-gPf^!mZCl9tEwSG{GZrsr^~hjNkW}qul>cOUwD4E?=^-t)pbcbNWu zL+_mfegC09d*~lH^ba2TO+$a)(96Aj7Y@BVqaQl-44g?%Mk# z`R;OK|MoIl|4l)pc{jQ;cv7%?pawkSPR~5u?C{?0Y@Qfcvm)R}J#U?1ZB;;Q-MQAe zV@t8QJSdB*OT`$k~TuXj8$=r-?;SG(&6+Gl}ulOqRgV>_991?H^1 zIFK`P*lyjDKszf~9jHNb8eL@5J%f>k*FIOu9&+frU)Iyt#_X1%&3nd^^*CW zz4p+n@$3Gb-g?%S4`f^SfUN6d^^ow@V;;&7JeY z_VvN$VNIQ(nSmA~?;heO7Y7GoE$+^cI95#q?y#@rvw3Xoc_VAvS`iP=8G2hkW{cx4!vouY6OZYJn{mjo6I8W#FHZF?-xAWdobEx)0pzj8S83 zYW*<9RyL_+Hq_l#w(|8M*;u~To$vXgwf@b7CLd1?-74VA`2oM$Irm@P0TnO09vWSI zd|3L;=}SKSD*|#h1ZX)^%kHf;LALDnfhLw>Oh10vMD|Re)gIsHsQJ5wU-Q;JJezB- zenwCa8h@_#M?T(wcbgr(c^musraao zy#r_Q5%Jx7#~x9p*2G4B9}|d?y~TH~CxK>-IG=<_J1Z#vt-m~o=-Fmp)$Qtx4-d@2 zLBSruOhD$bfo9x3KQ9ZN@XY#+e@Sp!aA4pajx2F==B^611Y&=2zz;ga^YWl{ix0Wz z{Q~pGj}FMLzjIK$%&8~wRRgaa=;i6@IX)1p;{x_=2&@%Pw0EF20XeT5{BReWlMA-1 z$NH>I4olC2GhP_cw`KfTe@rAc^R(=*jf3nIeB7htF!dYr*mociB+8|KQqh( zbn{Ps#hq_r&CZ(+{pIP!l-<^<5pmM)8|;<;Dn4>>U_kz|U}fN0bz&eN7Y6cqRPbvN zN*3AZM|JeCcl2*`^lx_b#U1_V(ClQh7_vo9#8CVnllhi^Xn0Ek%^qtWJID~5s{^qS zN6q{tBQo{~pFfvoj(=jRmCVb+pUiT$$+&!wAx7dpX2;{QhA-3X_^m-k`AA0D@%YS@ z9qhVdkToqXPZ*Ka#-(z$I?pERs}ZpKRjYwi8$ zKu^+Zo^M*+S#sCjS8Ri2!ODQ1BZAumw-3$_9u<^+H2+)rypG<|(U0ut%4=Mhm49wG z|B#M;ct`(wNB?F+ugO^ReQ`Bb^k0O&AT-<5g>&Y7ZVr0h4Z^dJeUHvQIk#5q@Wp#` z`1_{E_Z%wz>EYY2Zrb(V&byDiJvl<@v_{Ta8!yNjbH@f6z1Gz^uji(od^(+tkL5jz z?B9;;b}!qk**$n|)|5PZTUn)pKWl@%0?m1~_L$&zBHNwv*+9QEaBpeisrK#~xP$nm zwR|%1PYeD%F=}gIb$Evd;;q>?6WlL2J)rA=V12;GNuYUtpA@VL_}I!Jzhc2Z``UPX zE;f|Sa!@wYQR~?A)?u9(Sm#a^^U_5x&|$BB5@?gz|8KKzNycnq2RUm3?VF7q@^e_= zJ}CKY0Q<^b^UH$`LGL>~z=uhou?cGb?ite~SEa|EGlGKy{<*hned%N0`k?C38B+Ul zM83u*^L(sz@~N)K(cDS(EI2b`KA2O(>V&WKTpW;%$7cDS1X|r|`u`Vv5Fb7|Pm@5C zBd9o6UevqBxATK`4gMj4wN*oYr>tbC6>)q@237y)r#7_s+H38rvKLJU9=VSVPyW!_ zg&lonN1xo$2Zwg|RsQ+T@0MpyJ?YKsYu;GBnAg;bu`~Fz814S?XGI&+v;B5~bE$@_ z7Wk%-eNZ6wV)W>MEh_>tpBnJl*dFWE-b|pOj|}SE<9U|S1vd$tC3{OgUG~>IQ9GxW z&8g*+f_Bb%lw13~LtY-3Z`bVV{YOPUeN`*%d7@Y2*UI3I!Au}l<*PM#;^dt3X;V=C zZOm94@ZB%&3;7c}&kytbcHdN<$a`$yS)sPAaZlK1oqA@o+^-Mnp1`xVJ{rTy<+QL?e$(7Uayxg;_Mw)j-5^SlQ^CjI6Er> zKj)kpRNgaOl)Yj|#+3nmV!%eeYNfaQxgxyffzLY4SKJp88}`F|`pD|_eKq>}{o+#g zig_C|c4f=#J7L+#mpVgj4D0;Jfm&Acs{-=WyjZt2uQteWhL?=Y;b~_D);v9er~ke5YT~1TyuU5z?;ZDVn*;LLzcHA0@3603C#U4FLA>}0?g@5QY!1qp>=nVL zpz6Wiy2tvO==C^Pni`y`;c>9^ETEc_cbK8vV za~}E6o_;M~toL(~m@N)c zcL!K=e4uVN3}eq2abxGRBZ$9s4#h@n*oX&wYKz;{hY{l2bGUv zwlW}tz2e44a>%H2XiQeoWRmxXktYxAZDlSCO$K@5&!*ZdCiXse*h_D}mpumtCj{+Y zv^n}p-tife_q;)#nrY>&49ymMjtc%L>nbN_hrT*EJ)lS9Tis`3UcNqm*k{k%g4#po z3o>WV0YQedvAZI@=O6#@*hw$j-0Pb9vQHgji48k94E?(FTGf*JBuBlFRqNPTYpXUl zhNo`SF&_D=gTn)75KY!Y0`fNpmjwLUJE*(T+G7LFU8Avst?alg;HUis^YXwKGEWO` z7kF0`XMFWuXP6)2dR4F`V9&(?ThuyRttFGM>@HjP%6Lh@4(s+C=ynhJ{T_a`dnzV$ zjPV~GK0kc_TWp;ZdkzlD4|_`&9zV+7qci^F7*+hXMwex7k3cQ`udFe*GLXNSfWC^Y zJEV{8H^UQKd23@!KYJ>+=*I_oxfDC{D%SEQKP_)*Xsv9zX~t|)w{H!483%@EPn|Jw zC-*Ude6s!g;8wwy%vXf3jm^Cz{NBD+U&X%FH<$f?5P5Ui^0dsCe^qbtR5p}PVycbV z{MhhIM#Z_6QM{A0PX7O7B>zjoS2uFIJ`hti>fH6UV4Ygv*Rr6uDdJ~yFjtND|E^@8 z&$6ZBy%1Z};I6QxVtHxgsi!uUVvVnvZ&_O@2`&U!ic(~%s|)5Z+l-y!l; z?+6Qt^NokQWL5S#FRO#YgOV-J4+;3OIj96(mZ0__38r-O}wyY_`~s@Apl zsC@HPTpkuoi_N_=CpLUkQ*xj-{%nd|&mC*k7s!G9IkV3AX#xMtIkWwI)$*py@#Ql? z$ WcBkUODsy(9vQdK2D0s|e2<-#Oz-eKu4n6FYTVxo%#M0qwl-C*vhlOQv>YFj zIWerAtuz&GzHT05?_V(83hK3i+)4|jC`=ZOA& zwRZgrLOW-F9_7c*O57Hs`NnK#1DoHP3!s&GM)PNN?k?x_h+(Zby*Ynx?UMAh|AegP z=P3a`d;TJV_f4;^uMV6A`EqvuGIQQrtVO>lbk(wF+R~t8e>Z=Z1UbMK^I)DWzm<8u zwEN`j_<>(?4h?Nh`N{7C!s8prsao*!RmswqZ1$m@6}|gU?>$WK4%Z*l^)sQ>7uz** zoZn-D7Y}iGa>lEJ!vl7~eFG5^BR1Hhv2%Se3ACzFd+^1{-MS%|1lp0op@Ddb_e-)^ zzWUGMS{u&D{7i6u;2lw1z`hd$Hmw+XcQ^g!=~^CCOx^9`BB#}t40$4B5@=NeXJ%Y} zsU>#_zxd}4S4-q?4EPG}t}6rj>WpsoUyacUWU8TvhncF+9r0iAk292ZoriTC<|kLp^^(3O`fGS-|Q zvc#(D$$I-&1Y$}yJ$Ul}*CFJa>{kZo1uFyg^XuTi`J%IxDgO5VP4=rjI$IgbLdyYN zHOH3P_p)K%(#*H}=(f)udt1M2@5?hGHvK*}v(q_zMb=cUu=AA--PX?Yhy00)n5+vl zIb0IR;j6M&4u8V9G;v%#JKAO+TQ>yG=S*-xP(1v~BVS6s*lr%?Ch0Z$CkAP3-#eHD z8hO^Uv-Rt5V;h;`I0>{>LDm1OGq2tc3Dk!6)3RUuCKRSkv;Q@N{c<<4Fs-%!?>hU% z{qP{{?X^|+mb_}>V_wha@}E8UY`JV0tD%bLOvZA!Jg{a=jy01&yj!_rc3qM+Vyz}M zxg-D3fWKwS&e(tR>}RKEqulas%!V!D)5TW4UK;RiWq{ANv3(bXzt}w&?!=x8=Go&c zzcztlJDbI>wZ3YE?A?QDYd2?(O=33_Oag78 z`^$EIv#s`derycJ{4Jf6%xep=QLOs7i3|QD(8y6&)AW|DbH!qs9yYrdr^RWKIjyy! z^s%SLKMmd2M#qE`X_d#xEOm`vJ0p86M>`{@a!@v1*EUY8BXw80)x$#1qcgsc_3kq7 z0I$mi_l@!EGq!hSut(q?^gh04Fm}es7^~%q;k2_hrdr8E*!>h=wjmiW3jSZJL$N#c8V1{-`M2tO(S-0%9^pf&38{!ZTv$c z|9^M#)yA~iolm~{m@A*+GZRb#jXe3KuVlC5X@2gko}HC9iG5nx`?HjDdh8HKZGE5y z_3*gByq{f?*4g)Tw7ROFiM`v~qiqQKyQp1jP5bU3ck(+4$X`gkJ8xq(A&2#IjrTNb zmIv*b3OT!GlD@xF)XCTxu)nvNk4u8G*ZA7xaF0fo@wvg6E%VjsB>Tj>>>}&h*yZfD zvKAX7cVO)oqif^W(nc1)=CVb8_G#ABJ=glN{K|W4`(pRY-$M7ZSG_J|y*tBMS!^uX z1Cv1fN|&)`w|=bVcJ{nYdv;HYquMU}GMv2|ozZLKXUUQO>(a;4vyi&9wqnn&O~F{) zr`Ri zGA)jEUZ%}goUUx*^p=r0ZH$ijWU1k?c!@1c0*xH@Pm9O2_t(1T@6AIEirzZw!l|wZs#_SsVd0_00PMWsw7th7UL4B3)?wYb?k83H5Ev>A@ z`bB^3Cu`dNHjm=h?wM9w(`rI2>fNnk(#mAhG&^c<`@S%j-L<}dKbTAYSpJuGJ}-9v zLf;WqMUPs$E}tQ7{mpe2+MLIvUH+WhnYyWZDSPC8v2v!}ZPRi(Ee?ylv)r{~KR1x? zIo97rd|f~AeFnNBmj@=eV6#uqZ%x<>P-;)Jf)O)}QXuT2?G zv!(Vg$(o8YUVSEwHwiTI*s$0*?Tl}8*}N;`Hx`$Q+kEx1GdA|It@AGaZT&3v?5V4< zvsbb2_11f(x+%SCc(J*y__g(dHwmxP!Ec?P6tDElp;nTqDQ%G1uRLY{8!d8og?8u6z5U%#YQv zXXUhaCh_Zald*o_yDwG*Gr_d@Y{(q>o{c;6`Qrb?@|w>OuWc-+)sy;hCr-NqJ#*_` zUy|`+b5hUjN%pFPlI32SCTrR|zPc9&y}DA1-UZ$p2h{4ypnVSux&2&D^PhcWs^O|{ zGT%3k%=ylovo&_+_%?Rt_yo=!{qLVgzxZtm?CH;G`O@?GYL0$7J}{3C`JSd@EN<(v zUQ<)zvzVCod#CALh;OYdKFnnYd1CRw#G>6dpZ)c2QuSPV_#RPn>a4x<#i?XXJ11-( zt1-F3-w;fKeFApQ1Xbgcj5RvS_OV(btL!Zq)=dKKy7plb9cBL^8SfEH%V))FXKKe; z8G8q&uX1d>tKM5GN4;L>UmdEy(!1w%pttlK*y-67u~V1M)Q55q_@chb7cpF{4)WBT zd+WGh5@?gz|6fz<^-LJkIW2F~o;7ri-P7{c=ghiEAW!AzTshm7I``^yo*R1X9P_7a zoA12${yG19cl&oXhjo{TnLI6Rk7iRs~9XeP3%Ln`F9O)~* zaz9rdrs=C17nfF^xGc7Q>wcMJukT2gZDfgue2&%0mhjm>W}`X#$Iit?;j>xow4Xbu zb?;<7pMB&2`+V-L7JSxCzn>S%X14B3JmrudlR%?uVvtrf?epK6fyQ@lefWCgwK>g( zojK3!svIAd@mxOskNlr)e5#JdYFNE|B=w@U)T>;&lc&|ne6l{e3uS$57s~qhE|m2z zyHM6AcA>0K?m}7rx(j7}Y8T4-^e&Y3nO!LBvm>%L;0vp=TG^U?bL4&jTtV~kIZ`{i?q%_O}xnf?DZS>`@JGDn`d zFO1CLe=&Uhm(thoo7X!{Jr5_D7q@x_Uzh%UdBje!V&hjv=E}dXj?CHfwea;{Pye&> zuin2F`i!5irYG^|fS~drH`9I&rn}b7_pUGR)-Gm!mM?03(y*ZQVo-5dm+{g?>~mHo zLHq8{_i1-XAERmOoLjZ@jX2>w%=nubi`U9P9-R4U`+Gfp|NmRVe)q=ibL=hM|JLaK z_YvLaMh5@;J7n5>Bbzo1d)B9Sp4J8R-4k~4Ynt53QLm3&=XMgXr)r9{N$Q+w~6u$n)>3^EB_(}9tEdDd&T@j0_GqM))oS#--ZO;5f_hsj9 zyZ=`^H$|6P9IJU}$lQit67*+&+TK?G^`f)xm)$%4?w4t2ahh*sYx|j|yWUxE&*fs} zve_9?OG_G?{hOYBZrycz4*Wwh&TyCbQST_b%8$JoKlUE+V_N>E-GlADwKVc3@mrhB z{(oDZ<$)i|gGnH!tv?$>R}S0HQ`D9`?%%BUoLg)jOLku${*J!Zj>XDt>tmnYuc_(l zXFOIP`wsm1>SJ20>n@nYZhzljYx}eqR(|Z!Rs}I*>N9+rZZU*OpphdN)AX{{xw%1< zP10+nd)glJxtbPjTN{_sGnZ|pXPO=4Z3y_gKH$gC#Si!4%Ao$-b&|1Gel7Owl-=b2 z{5Jb~YC2nd#qPLZ5@?gz|8KK{ zUFO-vrX@jp$6OnolgQF0v;V&)Pv?aelfH(gJ?r_w#(upxl4EWXXp`ChZ_~9$#{V5- zI-gC8t*^F@{oOEa{uV21+BsgVoVq6}ALQ29IZ|i4st&4_+Go9*=`aWvo>sqNG}q5k7iNC!E@s=#o|pe0e3*8=#HFvp-NRd~&t&v+>WA(T* z`rBu}{Ex|<%bs?BU&rj>N8KUQX#V&2v2&0|_M+q2-e2~Y?z!%7d+2Y^yg2Z?_8Twu ztXGXxOr0aoMYfb&x-_sn`^%{wch@nwVjOmoMoELZLIsamF;7;+J`?0+I-Ko zr{beuh=0@Go64U4jQG5zU##mXMDx$1XU z*?gnM<{Mu}HalzlZ*BH@(SC!zLo&{A(eY_xzklP$0V95Fiu{Ua{~1f!r4Fa9yC`$= zdXq-aft?<;wAlB!_RiQR`^y$JvshW;;asuvrj4Dy)Y&;#E!G{{KhMMtCV{pp5U*)9 zJxxyWC)ulw$=o>bdmHTS*T=O*+psHrA?v@>JL_U&H?7_)Pkj#BdX4Mb>tL~Z7h5;e zayIRZTo~KD3-tE8pT~Y4;P2RX+G?%m#)@Dju$J8Zch5J3M~2>KWb23C+V;6qbH4xP z&d}_e7^JNV@OM>=g=wF z%$Y!p@TNWI>wdJZzW3hVJ!8-L+OsR3_i{y^yI@)!kKI%3y)J8UTAi?$?n$sTsGoI~ zWW3mOKvw0wjrk<}R`y(VyDDqNZra&lYw76ENX6T8uKZYtuDNRY!YTULG3~6fV?$s~ zTT^}pJUGvSNqX_sYu1=smN~V(GEk?>1Ls{l%AY+mo)(*3ZRva)Z z@fwTE&ep5guZTar%!Sm>rtBR%&(6Z>!9Ibe9!?A7Pg@_T^{Acww@cNswRIPrmGQ=4 zn(SIvbsoEFDv_X$1iJu;?~{<+TD&gdsDU-oDv798kox$^401g zU9B!wr~B>D$Y^bvPw!l{bWvk}>l^u1GcDgatoJxR%>;FSwR`5WNqsNmKFhN0_v*Ab zwefH5bidRcQ*zYhG`*`bcfC30>;AFETKCM()aF8Cs;27MnBjtcMyQ%l+gjP_Jh%R} zV=?OQ!_DFKvE%Qq$^m=E^!BxNNY+)(cGl);y7*YKw6W5@^npnAe@^ ztWB%k>pEXQE4@1t(>8``M*S?d2C6nD*{hWtaWE$*@-+!G^X`RfYwtpGUAm^_r0%J* zOAXDpmhI#&WUVy|T`TqrU8}wqx^~Y+tlet?Yv~n(x#IMY%-3^nA$EFBAC_SCKLe7n z(75=wtM57JU1)slQSbCDG*0&TcX;jD74e!co;5%1TrPBe+Ig$})AITM%e?o=RjIM^ z2fezZ5AWzT9eqSc-?F1`)zP=^=-YJkZ9DqNj=o((&zB$m+`d_lKB}XS?&v!-^fdWn zcjUBM+8mu@?+Ikov!?D(=X#pXHb=kQ*vO}2I{J!h7PDu6uDbi599{byO*?b$hWa_F?f^NN_FS9mE~$5mu{&jF<*{j3%H!K&_Z>h(Dse}d|W@LJJXXu zo9naXpVj)+vFq?4F3rAIAC!KNU?yPu>A@cd+J=Cy>xbUlBLcN+PQA5rYnwT1z2o{l z6!QHW#ZL~zul^1!^)!hgll0nT_W#$&HNS3To=xWNGBW2g9CPbO=KTFz<~EGX;U5>i z{`m9@{oV0>vcC7}gc12=^NAyKW%EfRb7k|%BXev$C4Bu|(=XQMl6|)k*=6tDN9KI? zMdzs_bNKfNUw_Z^3$@8-)Z$pO?=>QuP3~gxs_z2RbMKM0YSY|(M&|HO3txYF`i0u4 zp6mQL12A@eo)o?|c77fl{&b5### zj?B?@R`~k+r(bBymS#Ph%ccj6$S#}C9+@kf&Ka3w%LBvLKPdgq+VtQN*;R)dN9O3; zH0V8d5qkanUa=Uft)R((D!?mghz&)dhWKrPb|J;e9y9qlRd8@ zIBhcf|839qJ7kP+s@@Sj^V>VZn)_sdIE(k`fw4XEcTo%@e`QeLMewX-uQhe&WjL!F zul&Pv$6OFtXIyu~x{Ni?-!VDn$T8R2i)JU=w!{eX&JL~)P759wXjL=M$r#i|jj!uI zs&=Sdf5ORs&k)!@xM?7!w+<=>;(Ae_@$n%+{e%3c_?R_K1c~v(c_BFn)`>6Uav9Gx6+dQD#*sCQ?4Bgc;0UwtPeINgg z;n%a_A*sblXl*k4|7~?&^AF8D-{ri{k#~gU!6eutsN5QB@_1$NWJKD20iAqM^H&8| z1h)+6(Q40S8E;K<_V`8ji9yVm{kt(shja9>Fk9OW4Uf-t?(AuOeRvp?@U+S7|F_vh z)~}AtT^K(5=JR)b*0lHi$)V?i+L~|8V&)^RtDhyaXI4C*t(WDY{rvTa_$(*vue<2< zjQcZsKzM3sLohb)o;QD7@c2OMWuP|(ZLQd&PTeWRXRCGc>UkpHGXXm%fmZkHu3lGl z!!9Tr*j_fUSF3(9OI`EqXl>$4?OUI5yO#W2v38*{|7YDb`E2vDvvD~;`SUw)?yau| zYXa?Cxx4mBU-V}>`U4&PwvK*XNB>nvKfj}&-qDwL^dmZYV@KboqbD7G+m2q*(ffz? zxr2L>&+7UO|G9OmI|1J_13#hK?T^B5WAmuc*AL&{)om?UD?hLL$=0oYMmZuN6JGSO zty{h8x4id-SFwIp_Us@(G?{qqp6_K(SljKh#vN2^=)dvDuaSHIPVTynzD-AO{qZ)x zZZPO5-wq1RR(INQS+j3?aWn6J)*l?ynk_%ty4ADkkwcxmF=OFB$6^f4X1x}$H=(LdkOTfetse7@DupYG`Qb@W?0`qdr%;?SNk zj}JU!JX3#n;9b%19^dVINJrndqt|uxZ9DpA9ldX8c08-m`StJa==-NT`ky-b4ITaJ zj{ftGetJh=+R?w!(GTzFb2@r$N8h@mS9J8xb@WfZvn>WMY+~^Kf%j((?==JO&l}!L z2i{*ayr&PmzifC99e6Klc=sK6FK&422Hr~=-Yo{+Up2fReS4eDFKu|A8F+u)@IEr| z{-)twJ@8)E@LoFbUf%G2ci_FE;axiLUfJ*-HSk{5@HU0lzMq`b(RUv9yr$W+V&MH< z!&@@&Ufb~A|L@y;e_g|SVR)^+XAf)szFBi=x8@PU8t-y-22US&Z)$iOx_!6m=z}_X zua18EzwKz-t2+9H9sPukeppAJ)6u7P^obpPWJlk;qi@jB-^&k9Z7jdg(Vy(-4|Vjr zI{I}T{o;=P!;XGtM{nxrU+(DrI{N$H+|m9|b@V$r`n4VX@{WFSM?b5h@7vMqI{LO9 zeY1|OqyM_2f3Kr23GI%5cT>|38hBr6cqa|K_cpxS54_Jdyh8@w z`y1Xq1MeFRZ|m2$>HTKI``p0$P{Vus!23ja?ELaDmmhg{d+9Luk%8wq`HX@0?S}Vj z1MfQxZ{xuGZo|9h!24dqTRZUnwc)KAc>mGxZZhzG(C~hK;Qg@S{p4%g{QgnH`~1KY z3qJm2nB(J{hPmSL@y`a{e-7*Lo;>jUz+Cs$BL|)rh~k|UUVDB|9oAG_$vS@EwfVnu zw{J~H->{>%esxDZU+(CScJ%8z`cFFg@{T^gqwm(yYdZQy9sT34Y|FzhHnI6!cx`Mx zGOXFVS@U<@n!oDkr*!lq1{wP{GVal>*)Xj6xn|AkZp|$^dhd?@(wBF%{e2yMWoWf^ zP^06e-I`}~^lxqTA(+|J2jkl`deQV&gx%$AsJG@!< z`hmBm;k|g^Ef0^bTMl#1))m9te$D#L1MlX;`a_%brwntqZq~0GcsFTyhYY;iHoWT( zyqh+>?|gBaueWP>pBi{KYj|%Nc02%g!3s9Ng?%JMdP9 zXFdP)cWU-se^_(JX5YVmVVnK6E>pXGc;KyQ)?GR9?%eQRH}H;XcrO`v6?5`_f8gDr zS@(p2x31wma^T&i;XQERt#5dz4!jKwZ|%T4uHoHs;QeyLJ80mY(D3#ecx}yn>GRv- za{H_k$76^7lwqGdyl7a%e`_W~f7fQsdBd98m#N*3A9!udZ!_@L4tuRTaNyBhcmHk! zkFMf<>2up`ZDaYKf!D_Jbpx-B<(~|^HkMBwcx@~nKJboj^xkjawXvKGyc3&ss|Mal z4eu8R-pLK`+n?R$M;ogT4ZMnJmhblZfp@oN@AC)V-5cIz1MlA9$8%bYIrXgc;_~}Cl9>V_KOGJ`OUif z4!q3`@2G)yLBqT8z`L;FefQJbY`&=BeQ4lqX?TA-@E+3eo)cdCOnu6*=HbnnM|Nw@ zAJ#mgS#z&}_sE8K`)=Q=j=pI}-)NBW8;y+Xb!)!)sU7Y8NJqc5qhHn0f6&pt+R^vx z=wm{whszq9W(Hns=Z(63dv)|X|8+;Z-_+4B>gb1d^w}MKVn^Syqp#o5pa0~J`rp~n zuj%L)bo3KC`XL>CUTAUpy(Uf%=+@k`qwg^6c}%ls`M`U6!@J?Ydq%_C`iX7&ez)O$ zcHlj;;k{$vJ*(lpWZ<>7UOe!Azgc%;c8byq7n;^#kuk z4e$1ytX~?|{9&_Z&u+~RKDJHY^O`lE7inQy|UpwZQ%Ld zTs?z-b>RJN!@K*ydv(J*GQ2j&hj#QY4SQbO?D_FWxB2wChWE+vS~+j)=+_N<-q7rM z-oSff!~3mn->-M{+K#?eM<3YHyLa^0KC+{o{}Ng~yrZ$J{(?a_v<_Q&pP_|1{t4eWIS@ zc;J1b;oWcGeY4>$3$Kmq^*j1IAJ}GV8^@1_*Y5d1N56B})5h!7-I^B}uom=5Ea^JNi#M`VTt#cS5g?Om(a68~Bcl@8Vq=_+F9k1<|{7=zWI>UEjB+f$lkY7(K6p~_l;9b`?*-2Z{wVlg!Jh>$3SJt#Joww-wZR*L{~f#~ zxH|Z!;N8LdgAWHE5B@dyZ1BYa-%9_3VD}}-Pq1Hbi(n@3eJ(lM7;FwM72(*t~Z&Am9v?4yH^#|CKo)#|!H^Sc|GdA6{fuY9@7K$kD;8#?0u zTl>Pt@@33cXVm!+8@cG?iYKmT2IQcR4#e9YvA8%8cRV`8&|K-wa5lbU`mJ?`Su4I{ zYt+T5fwj4I=3LAE1B02sdh+Iy-PfJ_Y;*RE)g3!F2IMXc$Q6$`J-M z9OUw+-7Iw7xmi0VkB|EYWpjqxW!D~SJeSAxpBFy4*4$*u z8gX_f@k8CvHC88LQZ}BLv6!z2#Ch7CMmF8ntP3=EntYV3Hm8&DHG4eY<(3T3X?7X+ zcYLqgJ@B{~C!aNEEI#y(**gheYxVN4^ct65xn@VnHpe!4e=9^^uccc(sAu~x3!G`s z1T~6R^VXAbd{FD~jtj(WL%@gi!P-F1H1$lDwVn^g>d=`uH?WufeS)(Cc3%{b)${TA zrzXf-5y=18TIYlxy^MMelEEJ`=yuk~*%*+??z&5zPiM}0xoDs7OF~x;_{7Ikg7&P{ znCu!`C%!E$hAn+$N1xcyckAf7JJ>}29lCk7+sfasqs6qHmz$OrpOzNOmOiPYPwwbj zcl2#KT3lOsM|AWpJNi}~tv1{Jhj;Xvj+U=>{oWnDw4Z|!iQS~cMhHt{L#=G7han2RRgX5oni9rWltN2Nob9|);Vu%s{2QNS{ZCU zJ#fx7_e=5indR&#OMFU}JZ=nHU2@Myb$UgLN_~oC*!Dh^MW5{Fi2Z$nQnAux^1+E=!;aje|PGk;pz^UK;zf%9^~(6{f3`-itIpugY0 z*qG2UEhbN#5|gr#Z#!e7GwuCEKF$v0jL&xq)QI^f1bAvmuElnBaCpFH&DmnR*wmSK zo>m0v`KiIuVQi1}>w}p9Poctz&7$v2;@Xe_=F~h zj|t@tcOU!MX-c)ZU|B#9nN>SzHN)nL1>W+&KJxi(EGEWmuKjAU z_FLmz*WPLC&&?Y8tQYtB){B?5_R#N~v$3}W-QP9tD4!dNTlwftRU`D0&E_%R%YOdN zw?+;sCVOSPkXmnZQnt6xce!L|<@U0S)xVtb<&r>cxijt`kRe}Z2Ui7RRz8@sj|^ka zgoI^wOeZ<{3h`F)AkQ3>PvY&45Xbew1p)c^>jJIr|B5rY=Eb?UrR1s~=l1ErLeFiR z3*!|*om(~=^N}5Foe4Db*tuO2K8W2-f{lULUo`Y;l>O#c27D6NS|=9P&$Vt<=IK}+ z93HR_?i(!0e`pD} zpxbAymCMq5Sor*}ebzm7f$N?&$GVCOpEP$MpXon6pflTNZS@=%OO5T;9Ut5nK~~S&VIJv*NC{VRUF6SQ$C4n`DEPtRO{Hl7W(-<=6}0()3BDU zQ2EGkHi!Br2U`QRyD_*~FcWwdsA)d1r~MhEwNZYoKQ^#dZLSM6&jPKFQ{`0N*|ox= zH1wl_nqQSMnHs;ImHfLa#Tmr3@bkmi``q~fU)%jPHYaW^y-!1DID6(EoW8fi-lak9 z&2ZM{>&l1LPP$5O?;m<+eQ-ayKQ{-S)uqETu=r}iSRPLd)U%w)wYif5&0cdQv));1 zf8C1*XU(~R{p8jDtLBf&_~~(2?Q2H|{#?>I{eyr_D z2P*C<2$lw7^4;%m-MYtrY~6a#A8p-wzu@>EZ{2!Y@GG%rePCVbU>8|x)m~%v ztPScM(68Q)37#Ea#PNN>8NtDUn2NtSZ6+Z1ae>^Er#(J6Fc4$yis0lx-H_=SPUn#U z8F)l)3@T4&X1pp;d!^GFI@Sjl2Xyj7+Yq?->m8X65PR_k^2sEJT>1|Q*rlBntPTzj z%=4Rkww4VU&OYOpr{6sA-C1JI7p?b!zS=+LgZygKd?1@`py{0l-)kV(8Ro0FIE!x! z#74g8lhd-z-a7=oFRJzNbVrc=hYOT_v#jl9i-)+kvQHc6(oKCoFAr)#JlI{n8Pnm6 zJ$C_ik<;4cZljO9@_Ul8CLWsJGg6&e#|Je-FWdQJ{=lH0uUK!)ocf|m6L{Q?^Z)IODGmn1o`3D$7i6zHuHWlCI5!#{f1Gvl(XL}x`7iGDd}oNeILLYB?|_Wu zfQ&-}ajn=y^!Cr#*v!X+f>Q&!eecK}5BOrZEU;F)ETFr5lP7Dg7YmHtLAMClep0Y8 z__g49!OMb=2hQxDM2|R&duBz}G*IZ1LllUMxz-vWzPS zW%pcq*!mX>u=RFXw==f>3E&1YIxnoD=m7VUGlBaf82IR~H@2@qi(mK z&-tzxc)qiVFY1FnI!Yg&ecJc)4#?)0EFeeLZwSWXvO4_31GdoTtg1ol*?PBtp1;Zh zwgCQV!Lp$0^|FlnJLB~5_7BLdT#6fczVF!QvSjjKYi+)5=*p$K|Lg28f6AVkpU#6%LcJ=-ud&Y z5r0;Muaz!(=p^GlLGMR@Pu?|a_~U!9{NZo;Rdy^3j~!w^*WJ_C({Wi}{*&dbR{Y0m z^wkT9srZxG`blr=r&zsa0kLwItPQ5ci=4k(fSlHrKIUZjesLQIx$X1j9w4XqheoWlj%6$C-Wy<5}LG7LI?4Oji>g(?#zrD|#-DSc2XaDB2?>>iQt@s=p zJUDnl;LN`!cxUj*;Ci_b4-EVcyx-;ad(FQd_`ONL%jfscJ{{~CTW%WMGPq;l-{g2; z@R-1#k@&evoP8&}%^RD`?+jRD8_hYjr|!fz&9lcj>Cf!l z!=vvXviC;m`!n0d*8Y8iC4ri{VIcpLVa%3$1N%^8e4Zl)rW! z`Bz@Y^53!m`C=nZV=)-3y{h%AB3s_)tG%7cy*rOR?L9MAdv6_Vm{xlcvHhK<^|PL> zZ7scRO04Lu^P{Hf{HUX<_j_f$EFe!aC#Li1^m`^%qx^Mls!r#t--^+FvZv0cGx7Fa zB(veARYh(g{|oJtXRY&1qG2R>fRupILkp4 z%Rxa4#=gL3N=|120^Stl(&8#)G1uYxtug(bAq!Wp4SER$cH%C@7>~OQ^(xl z+X&FoCl};4ZgYEImc81mZg$f3Z_h)QyLUHT^VrnRUz_4uKS%pUo>jKKFnZPL&&+I9 z_Zz{yrr9V)o~gcb@&r~Rbl(`z;TdcVo%KaP$InK`<>@aC^zvxsfdqcpsUzph@eyeO_Q@00PPtDHjMn1)f%)6$ZE&kk(Egy(2<9&KZ z);5CL&^oS9WT_dpk@JFpoL?Gz>iHXGsn1^y4V!y*?DJ=TP=DrU$2$cYeyA_H#gooo znQZT~xB3obkG@~sL7%#+E%nj4@Q!mnalAD=Z1Fo1#yGw(Ya78{@80-4!}s6z$VVnQWHy)kGiIZ>vC-Yy7>>Ej z*7EGs2DJHg$jfJwJ-O`OO&QCddy{?teUJ9xW1BX{%{tlapT})gj-D4fIr^2#%%;@ zSd(+MjP{TvwsIw2=WB}?jkY}gA=={aNPW0$5yX#FTzaR9X>%kO7fw3GoNm4S=Aw71 z+^xz5|2MOz$@e;%#z?(9B_MaSr8%LSU9fMmO`Wk#Kiby(w|>>e4Z&D1=-o|Y{W>rE zBU{b4?)l4))>HR-4#v8>ICRH@-VuCqH}UDNsi*gu0Y45z7yrPzcaV*sv8|4tC$i|+ z3ebD@kaJPwG)Jps@$2Hy@V|c1wHajjTz>3TC%-lVH2j#qYg`gWy85nB+Ye-ozJu9c zr_X)Ry;0vz?`-JBMNawt^nmY|PIlC9x;KJ(4DoLTzw@qfV0pLVkNX zJ|CSE>*T8$^2svyyR`ZYD$QorHS)SQzAMlv-eFzR(Dl)o%=1`(#8u;e<=vEV^_-rq zJ6Fyu{*Q^=^6X^aD6e|d!Bqi%yzJyZd(`Dv@6HIH_$l7#@t5AY9O=bio>%*H{I1w6 zH_hv_Gu{Yx&+A7m^FlTrwe~>pdBG#W9|-(8{I>_Ia`3S$a!}oT)=mYDC;xiaH{QQ{ z7H|BUfwmRk#V1yctJpVA;=0PVk9!if^_j@FRWdJs5;FUpL;Zb9WHcUfzRq7X=i{&6 zPd7ggJLO_LUr}}LEW3}@)RmDpo@KJcd_2on?ZFo{D}VDiT)hWgeB*a%^SnE+*X&V_ z?;F>}b3A9xN%3*`3`B6F-UGMituI@;wd$fMjl&*acgj^By+ap}SO$zUVc z{qEWRPEVZCdp~|fplt9SFQ^Uf7n?&HZ#`9>)u%RtIqgF|P@uv&^TT8S&2avf#DB7X+S9-x&P);Jbq#41OZ`mB5)hGK&qJ zjp>z+A!^zu0Or#U10s(>zZHw29z8LR5=*rbE( zo~gaN5_bL6U{}b?t-ht29qd(&_bzYO|=b3wy<9%seT*!IW9^|x!$J~t1o<6(AXR!Uvz@D?v zy?17OVKANvx!X;iSnejzpJ$=li@c+Ikmvi#>h#Q5_UG5RozJ$*-Pn4b~PP_o(YUQjom9GR_0 zwMyn@uv4v)y((XG|N7bP1v4G=@1%nre5#IBwRU@Cj7Y??&cWP7PqZSvT5o^^M=Ub;VhhyC4TziJ0wvR}Q!{#^F<^KJXjp*_Rg1xJHt2I_Jv zkVCyXyC<^e^`zF-(@6K4J<{E~N4op=NO%7p=^of4-Dm7TH;-lSpVx-RIUmnW@5%9e zi?N>LS6&|^z z`*pz&1Z1*@4)#4ZjmfrlXTZkKo_I(5#=0nPUPYFl&&ykVWPDC!>=d{9iHF{|2F85H zM~8cr{p6jAJnyulO-C{pvxC9OK>K^K$@AWvj&I6b9B-WF=`Q&3eAw2P<|`(e$~ZZj z|L)oRH}doRWS0JiX7j%>n}73c{-v||n=-#_u;-f{o=UiC#U znf#{Dm^}TeJdL)Z7nix6mC4Qnfq82Ktr)VEjoN#*yQS^>Ge)D{jG?^s5#L^Y^xUgG zb01gvCw`@`{aO03+vvP#V{Y%voZt4&1Y+BLahUJ(=bZt2^m5m;`Mhb|7}`^- zTLGTRM?aUZ4!cjseE-X*eRR&9_d2rWcQYU#dS=kouFEqXdDvGzevfwcY;}K>=iU$- z_3-)(Zb>gLi$GKRY;T;{&^X_xuV$%ojzVNLABWQ@N%lHI*e@N4Y6XgT`eI@wDdv%m4; z>zFfVf*o4(C`ZNZ8F$~AWk>BJ2gF279}V)#^!U;Anz?p$z!x#CFXHmX#HDwU`Pt0n zT};ILmf)eRv1R`L#}2U~x3r%dTJacZ#gxw@-J5ox3+d8MzVhwCfK4wAx|ZR&8m9Zr z0l)9CkybjjwH3U_Vwy8~Wnj%`G-qT^t5(PLOqXXD55JBC2ZF=FoVKznGbBr0ozL^e zuh#{h#c0H6PQyQRdbB?fls3bq{IlsjORJ~rwbxlV6v*eB6Z@{qD?ciKTtAlekS^Qk z`zY)4o`fuZ)K2kwS0K-t`m8NtOYc0V4^A|Ep6`wF&P;UcVhH^Y5I^zhyT6BeVItXY((a&EJ~2`);)H4bz%f)vkN8)^jlW zh1YpTr@o#)lmGPD-0$KY{r`m7{AcsoM(jr#pSwo;9-rR3Zw#H7g7^B)Gri!8GS_zv z&DYInzJH?m=k4(LDV6JBM zC#Ig=?q>Ql`qi4x6mQA7aIgA%E5`#o{L{9-E86}!Rr2iH8`qzgIaqfF_^Nk4$v&8# zT?c}ZSB|rNt|m@pj91^g!~KtcF8ijeRVH86$|(Da%z^w>yy7;>9(AvheJ1qPGsbAt zNf-O&aMZaj4qFrbsBh%6&dyf{o(1-5=g3pLvi*d-sBv|u(N#Otr)RF1Y4*q)*XXf! zC}=)A@4b5 zn55xvUD^A>?0Lt!GjOKgAKVj^zk7?UX(PYAy8?AK@{s#QYjldSI^hpKdEnpt%#!!+ zK+M&;d~OANwD-2ao;CWuIQs03K5S&pSN!zibC1jUmrV5dN1lr^7jv@t`hwuWfc}R9 zdGd^qBea_O;={=I%*^My(P`{y?&{B#S!373v8%q;F8LH|cA!5STpp+uy!8J^?uoZFu$_&$3b)WS8h{Y;nsdG9(DJQmO)F4~>JsNdRdHa!xW zo&4k@8IJ~Z?Zwx5J@NO#RObGP|GG(5V?!<-?2r?UK2037-pObW1+AC%qpWpf@geV2 zAZBznht*@v*me<;fy=O=F z%-OR_-n^b`lNgQld~xO)e@eq{arlZ1*42ypJrt6n{C|Csh z1Ntut&IF}n1Nn10F=c1Zn0>UX;_G`R`}6pcG549x^K+@z9*u#kYK;wedJnp9t_%1V zmSybg=h@7S9}3jk!9bmE1pMZ+=Qx}2k}baMQAcP_26A=Ra3{A8^v$WB&x?Sb%FJ;2 z_w?tg)58 z)}S054m9=9dqdnb`QqErplg*OF4~;Wop2(M6K#Axi2L<{I(aO{t*Vo3ovT&)@$}sI zjzVLzIEg7ea%OB>ZSw<-9I+2SyUpi!20o20ymDw<8RmBfw+2T7ap;+QAmjRL9oQw` z#??t4KlE%Nv*+M-8UH|lPp+?eyi>)|nd|{_}ECP+4;>JD=e{)ee`r3CnqO`ev z?}>ft`$)hJwR=&(uAWDBv}Vp^++1Y1e2+kf=Wsx$GcZ3h`1nCqR6apAU5)YCjGcA- z9|-Kphj?BcYz6e|(UC`Xb>bnvw#W@$zBN9Jj5R)?#b5pG@0cy4T()cmda@RQM$UoY zcyJ=1OWO)cCq9i^ZE0M|+liO#k+=4dy;m9h{7_}EbChvD`qk;kyB8m>3{PWtI^!=5 zn$HZ+)%+r3F_o)B)0k~93FKx~eCM{v&)lDN`Y#QwR@)ZK*|z?p8Pi8Eo6ZDuwVvhS zaG=ikLI;}0!@6^_2sHNqJ@TxTPHm2I>2yxSxjtt&eHXv|_m|ysm#hG~@&0H{v0oea z8dH16gA;)3_BB4$p7PT5j-WLm zj%@IZ`2OI{fp|R}lz+7OzO18XXYW_G9-ijnaDRZ8J#0HNjq%9~+4QrMezf}o?SY{B zx`sy{it*V*CY@v5Ei%{GWsm&oDt&z`-=(2B8EAeUmEE3=*7?THQQoRto|XWZw9MxHY>zBf4oo_A*g z-(6fAXq8iYeRn&TiM};Dr~jcf^nCAUOM31M*rYDlqE!~Z_Xn*hd+sg%jXtk>-~IB? zkm(F-;)eIFfm-O<9OG)8?$!=lSJg@W`tS$E;!J4SHS!+Myl1|0oLg7~+G6?tC-T-N z^3=~`6U~A2^t6T_%(!=4`|e@kOY`kBws-Y8*fL-1JX_1SiR1p@Ra4)5(BE-}OIrHG zncdYre#grvaV3jft#+Erfo83Ft#9q|iV?Jyti32uzv_srivmrJ*>C(Rr|)9Uo;^JJ zYXbCqW~*}}PNxDk^&If;a6pbaV>A2tIHz%+oD4KS6VQFMWSAcb)X6AQJ?#rxH~uVx zp5BG*69cxgxpO@pw2MG%u3DFTJrgt@&N6yF&@-avjt_i&Z1ACRa8HY+xLXs?zDtv9 zO$VJ9Z9Br*l&2M}3>>6_>K6LuNR<8SeqPxC`m%7lz;b71>h!xaE_hY}4YTU`Z zCfEq@F9NxNPYLc1&II=M2O3}TA2La69UaYB>@_;kG#-~`d@SIPRvGK|@$(U#apNwR ze3Fyuw~x-+T%Meko_&o~ZLSRQW$!8<=4)(WhuS$DXzHCT>*y~Ew8o)&_To4B&6WBn znzQy-Wsly@_0J8ya{ubjo8lmk>Pq8t?*sG3`KF9VpX(dDN>lqr-Q!qYjdL|-UK?WK zxxX8h;RWBDb7zlyd7sBntZUPmjL!z-^*!*N8ArtO&tfkd1ven1yg6|LH z>CM4U2cI9jCAcCG8?@?`OyhC=?U|GNf#_m~+~9d*a9!|F@I^uG;mg|sGTOc>gRsAl zjyWItw+3UL#&#sKN^?Bp69FBb3-21nY!Czaxg*f3PpmHZncukRY&y00xq;j@ z*76yXAAezb4bA9_xw^E*wjT}cNb|#)%gK!a+qB#Ab5i=QS-(4Lo!k4|+5F2Up6dRa zk;|X*knz6Ih~>EUOIfprwl>cHKIt8i_0ie)3^+K@U6pmdSs#7i=XLoRuXIoF{Y&z9 zI!8MDuL&KQKn^{%{Bnmu=l-usb$ zBN%nPI=ZrS&ek8w&&Z9o|5ZOTm;JFO=y_fE*7^VYW-{KK`8>{Vo$0-6qT!!*)1=p2 z%%3{VYrC~?p2_g@fAmzwFXd+fAIjXl@PR-(6r2s3x63lFj_(aUU&na`*h zYQvgXyen%x2kd%N=G`~HH}jrl^R3L)Rb@USbMH-^e|+Y0#TWf$Q-4c(H1hw8@qHfC z_e}A?!$v(j^sQs>=47bhZw~FQ59k{8vru?eCrD z56pVcYkEFw>OW`dJqvCR_@#M1JwLcD_^Kq6+{+R~@i-Bv5%9c}ZTTj5Bd~rdxG7L` zThmx=e02!bnRvW6ctda`xHyoj@~VxI@ArjIZs&YzoZ4N`$Mv{ z+4Gv+&Iq1EfjzR=ZtZYjjZfAJ{;~Z)!1f!a@hTnatupvQzM7<8-D~1vk3KSu*&`P!H2#z(X)sD zYs1fnIsaG};`N+>kK)rf&wYD#_JBPd@1-Y)PkeI@*-8ex>1F31nCx_p-XF-H9Qd5@ zb%PIl=Z{=EJK0*&{J{*!`9tYHF8$nJwM-sc_Ui9-q1_AkGSbyw_Wa@4!^fKg^}}xK ze@9wKcD!d&1-Xs~z%TO9YpA#F_teULH7e^1)VX z&emgr);#{n$#(IT*FQDQ*|UoN+ot_=OZq>Z0bO#p6^wEDGc(%%GjnnIvl9=0##kT8 zoXu<%2fpW3?QuMRE<8KM@=R#v=fT+kHoagPH$GdL({IjKbMnzTV^O!PIrp_%vd5l$ z{9C@`vgyxjrs#Y`NbOlUzqskHMfyH`N6{;F_D|U82b5HI-K=0fpuW7 zn&q2Te~h=Ld2|1lBJWjMOShE&mos43Ur9fYHJR!`jL}~eh#mQI&%VE!jd?7NWgY#M z!J~mz`fuNXp1i-d!~XH?p9s_msB>|o|70NV|2nxc=hJ&5OZ@#goBKiBdSk*)i=vY-pXf=G~h^d;8 z3pG-^8VkDVF>j9eWlrCBMxR*ty|mt8&|3c+S)b?qNY?2P1N{7J9pm|%yYR4aUm%}< zE3{%W`q=td*#^LWoj^{qPswq_k@O=zn6a1+29*_^^<>W``XDrKC#!j_T|(0W8;Btzv!v?w=i^|uJYkd3O=;QlXm*OGT&KX&E1|uI^$zr?si>sK6>-R<8 z7{h-s$!E_<_x&@vf0#LYejxoS|HZnwr*oY>b3N~$>G?;Ko`0NvC%;$4`NG_G2cnxT z*91p{GeOU}Sg}n#iV<6k>DdbS_k+>9n}2Be*P8ez;W3`)h%NF&Z+X~dOxHi%g>UYo z{LtI_=^1rz*<-goKG{QiWl(+pEc#ZR6E-?08b3z9W0~7;3^QEX{(nW5dujCf`po&f z%5HWv4t)Q=!_UT%e{-Ud7e4j8{#?!_I^WHxF*eato96nq&)oLkS5gC8ftr6?@M!SW z0bA}2_$nr7S`$4t_QVwIi}6K)bM!;|pLmXbICFme^Yp7??5v9MhpP8SW_tg{r1xL$ zL9e*BW)>N1o|p2=_J0)_yVdb1LyjH^#HIB^&cBWvF&uNNHk?cTi|ggVR=^%S|0X=E z&YgJ6IX=2aUbd2f|3_EoJd$<%)r*$R-mzLkL{djO9 z;2Yc%Y)oS|wg%|7#|}+A>HF!(7o*JpzjbqddtdT?Fh7rKNUMy0JIQF?dsdyDpUK|b zZ~4gb@@)O=4*MZF_nqFMjKygco;|IOqTh?&Z=wH zVGnxewfSh|YIK|l#ya`;k+-T&&|Ver*;wwxMb7?1c-Fl)$k|+fzmMYI9AZ3Qo6nt( zt$=<#8-6i1I0y5ZVXK^<2}VEvW9V1;ndRl572cEH`M5eb6_{TUTov$rtQ9|7-ng_@ z*z|!27Zx1&kgY>mrVZqdlX}i|4Qc0Fg`%AW%w=*51;#7>hq_3 ze!s5gQ_n=@kG=hIzG^H^@+Y6hVs6ft(U0GrelL_bj5c-dnR;`;C(ob8rT*&4zcC=2 zfBs&A`11W|Kt^Ma2H4Zwqq`?~N?=b7{CaAjva9QG*74Z?FWKMeT_q$-y5Cq)kJo39 z&2yX7L3M6rECzb9?2XpneuJidw3q3?avU~f6jYF=;TeDwu1W1?o+|&_y3IEopMka zY+yGTn%uL8?f)w>i+f{rarRgFB!6>xa^Q@SEf*&P&A&l5&VM>{u{a#C;gaZB z7Yq4cSL1jO?qdI?=V3p2AGM3T%g#gI_H*cCm(L?(aPM}!m;R2>i|47JXHMMJ!B!wQ z_Qc*fZ(ct-cDhS$4%Dnz%d>Nehp!(KnpJm``9e3x`)&ye=46`{#1r@PS(6O#rncXd};a-?C4#?&lk@2M_OZN?{`N* z?*O)bT;}RmY{l(Jzy@(V6O6Q%??6lTQ?ftOU$G1Ql{5OQcA>v|Mt{u?^o^~!>=svX zboSjH&kjC0xHEWVaDVV%@Rs0R!MlTR48A*ffAFJ$&vSAs{@MdU>rafYjh%9wzmB*3 z^V>|%-5*cQWT*RMl=JbS72omR?R|&tRPgHHuLtG3EaSf0G!ETk+b8TIvo-yRd!&2X z9_g;zBi+Ux=?;Z%U5pQBZ>Jb14Cm_hXvX`4#^|Ap)zG0p9GweevD@55?tP)5S8X(o zN5Z4t#vE>DuFm?bAe#+xhp+Dl?mOq~Xk^$s6}&D`hw|<@W&c?A=XE0Y?9k@*dHo9d zv94EMdsRRJF~be|c>m4@!K z12W~3EzgcE^LVi3;(_L-9cUT@^4x*)kGDDGfA72f8LI()Yz4jR*eia|S)u1x*2&Wz z2+-Xex;}sTax##EpGy6Zb>lQocfkkp!?N}@-?Q59{LPu;=f7CGbL~a^1+Sd;s%I|u zqWrSSQO{E|uiTB)^{D6LGM7`a7}xjB=zcvf4QxTjE52YqJn?m(T^_VTk&oW47H$g6BNp%DZ9RRLXcswV$YDfS=~#Yc9s-{4}@jK57gvjt||}`&Zs-|hA{C-UG^-SyFbKHEsf`y4Er|(bZE{l-KPV3=uqqU^fv|M-w~k0ONKF8 zI!c2dpT290jH^>W_n9Al-hgd~0pEd4DFK%Z7HN_se>RS2G*H$%RUrne-x@z~gWHJXk@xCm8J!^La;>_-MM}PiX%GpYfkB`>`TG!|yW1XJX(dD6W-l}Vnu~wVK zlfL#{=L=o+g`JCFf56TMCOhxU7_C~YZ{o_n#y-d9TaJF*}@T^#o+lD;~ghwiurY>U(?i@}l+r7w4tD4=7EAD*tGx8Hiz?*{oPO@_<7&gGyPA@AdSKCVw8Kn%?%&qKpbkHn7Zr4YB%63O@>Pu?08zhW-`@N^|3|$t4+4HR@F%9$NP?aK8S1U zxw6o+ojyL9*VnTdvuhD(;=C|O6K66j2QN9z3w!0{xJcy8iM@du{N(fW2&dX`t1Q`eqIPT>*KmJ#p5y0x~O)EcIy39{p@wcVD7^ zc|f*S{bC|FowLWe6~A$>btqP7#0HH!V;&cF91iFdXYGc-nUD)Hdi69X<8<(zK*LuW zHNiGCd>reh`WqLqXkO5h)7Z#s_xNc~YdzQ>?c^&NY!-{-!HK{cI6taJEW~>=u+9%Y zi%0c0N41?DtDdWDXzuRFSfgJo$mS>6-qpxvyY-P~H~skNA&U;O%U>U@f!M!s8lzW_ z+kS8VT|c(S4VnBg1`WL$d9g`a`T72q{oC>nWvq6@M=w{4Kr?42A2svFS!}NlhvRVluZ+%vw+CR7@9vCa($gj0&-TJA9k+FiCW~ho?X>l+tmGL&~tB{5Bjd*WBb0KzW2`2STRkSx}Js+(fA8F}cMcaHSJq!# zAxj*^k1TzC=<}k_)!MZxuIlijKs(r5vJZ`KGTHhHi^Ti*nb^FGQ z(bIAFus*Nn`8$UFzGJ8by2P_OSG{AX-CF{+&M&m%JBEFB?GLmE0x_4n-d*d?2RgiD zc(1rMM)7@ouORoqfbLZ?$NQr3X&lG}_1^l`13mm@!)7qAjk#QQ>?F7RdYH>^%{^JU z<=4Yp{wld=2D%K-@yy2~@1@yvwzMBljg51^k8Yg*x!L?1r}>TH6<6&Ac{uCIw03W3 z-kd(&xj)Bnr*!}Btjl%hpOm?MF|AxVeQ+jsW5)Nr`EyS7S2^#=ymGvs@uTwO_H*(g zlx`VY`?bm5Cxw?y&WgR-XYb=?dVV{9&V;Ude<^d{Uv&NxnUhgj#^BBy?fK%#9zO7$ z40P<)t6{x6Lw{|6-?=^*{ABn~Mb~}7cLZ5l@~9p3d>G~M*Sx6w(qA?0xpUB5H}!|6 zesk)NPW|=i)fGQAcQ6}o3qC1Ex|@GtDiXEq^C}z2)7aN_akjn)v{mQa{c&65x~rZy z_0OOBPfmX}>*RS4t30$XnD*>H6zKW92sA$QInd|GI$5_*vMQ&to)#HmHu^B?V8;u? zyGXAsmjB=OWwBzt@<$n~>?HS&!M`_Wp6SxZRX!}Tr+p;$M*CLDXX}e5TkBurw_sEn znynS_uzqUAdgbgEr*-z6p6s!|S6TAhvvq04JulAjW?uM`-96UXJg&PRtoPoiAA0MJLD$W#(=*C3Cfgp` zb$h*!DsSXtz<8s{U53Py5pn~fg z{_-{JpR#8C6>HXCxn})S*Q|fqn)Od#v;L|T>*~zi)!O?1``p>7ug3g!Kd(AJ>g|8i z?;M}j%gMy*!eDE`<5^o3TX)_0-Vf# zf6bcpd)KVrw`TqRHR}(oS^tbR>#tq2{<<~mpSfoJvsSE&nfI!mDbJ-JZAKH6nI+Qt@sXwQoup1(dXv+3~E(@zJ!%GV#6=EtV~hN*8( zZk*=NnEGc;{Y_JU^VBddXgRV7je46va`qQWWnN$DlsejJY zd)GjB>(uktd{qt6Ee@L6RA1;nJ7>f937?otkbXXUZGn3Nx{TGGSe^>3t7q%#)BP#7 zuM5Q1e#9=DSo(Zrj#vEO8Q?L7n}Q<&8hP9ojAwDLa_6$=a-GG>eIVod%N9`kpf0_e z)+V0==d^rOFZjg9`@eVarv?0|Z>KU=x6Uh>@^DF@i6>p<`OJ*PN?h^TYpnPpf6kP3 zIv0VqSpI)IuVN?W`r1q$-{q+1BE#i-so0Xo7Ip&L)jZ$$@_l(Wk|8!^@cUp;`RE=D z-W-JV+;^1ZiZ@%xo$FRB*3_UFkFlBiKn95W9n-im5{uTR9u0lf+Zb9C$IWSTF^I7>wKTrgWU2-kB5v!pe>gF-_Efb5ug3j8Xi82 z;Z?!A0)C;<%l*5iao3tVzMcu{)7fFn{?^;cjM0w&hR3Cu9}YBiA)o9XYv&K89u8!U zTp-hZhnGz4r$RH%-!#-vYwDKJeNF_)z4lN*9zOSM>8!DVEn_{Y3;M+4`H@fFnaHc( z_G>qq@5wtHvlYegF&WPk$mHU-RshMR{b; z_Ix|jNkK3mcw{_Hvxn3H{fa6?eJ_}I7=JRIB;xWCa>7MeqWJ+$K< zIriLddUqN5ac%i$Pk0+g_o}8Rqk5emw$k^@fjzR=zU}w+@4x1+#@71$(HZj(@A&6z zc+u@<3mP)mvR6CY(Vnk!-<$!qkOyQt$9i>*Z>KyzJ^S*b;c1@9qN_fSdA=g+Vz-yP zszwg1&3EJ9ye+b)iDm1!xt#mk7`Es$=m+czuK}YpYlYf7=Sq4 z5wLj?XzUcPRXIX8ue;U?y+FQq8*v@?tncQJ9Iw)w<)y8Si)RISaw5-iavHu$qecA@XwzC7p`fwo&6I+yz=l%8DAGcj_%sBd7O`;(5wtoIxq&qeZj zp8Nb_zxrYeU7EV@*{FWcvloWYoGy9Te%@^V9bwPyHwAwv_@3aGgQtX^?&=f^^-P9( z7K=NAkS%G%94dQXqU+oN+dI~?+xvhX-Wib7bA{%*K%AU)bF!OLIqO)wHUe^bPHMBe zXAx+N<^O*tZ>D0wueVKp;hXzOM*XZ^>|AHp$4xTS5uY}L+S-06o5vbkgjZ{=?KK~@ zQ=Hfdjh`_)^o@JxPsT3iQWHzI?=^}PbU96+5W<% zVH*x~2>hwdcPw_e%ECTI@AZb~C zCiFZQYrvhuhDD&6*N^eTtD|o?TkL%nfW~Si>ztt%ido6c^QT@cW0l;_4Q=d*!k{! zb|&w(pmt=qO-g^o@bf z;(Qowlsmj1j(T`W}Y(+r@MEUI@*4YY=75wH1mf8&usU)#^#UY`1Z(Gui6W@yQSUxrg8J}k+fm- zakPhBYE&Jy_QdRLAePqk_BN*8eshk$KH=%Ob*9$k!~HPUJ(=>SZ@u<@ac-lq2z?Lhf-e)LtcbndQ$49)c$g`5p-wf#F-(2Twv-ZBA_Ud5~Xzbye z=K>w#B!_ngY^FyZ+~?wRN1&m3d0cfab2&U)LEmr8PX#vx#{zN2=ZvfQel)lJzVv&q-zDIUS%a@7WNE{b&Z#*J#@b@}|Ly(WUF@kIwOl>&OrHC$-xreGcPX;#zju_lxumzRk<&QJ zm$>s|W9sp*(Z}?3V?6-VAyti--8}4ZU{-@1N+uHU^IRy}y~? zAKVc19MAn{gEc>s$=^eP_CO#mm5u*sz$UFV+IrwCeRl@z!si|M6NAG+?Z7YgwP!2i zhl6_p{yjH%D1y+4%OcR&qv>1wF?pF6y4gbyo>KvzleQ<&W_r$UvBrmXr##DtJB7W~ z%Llr*@2KrRqe1t~fIs&J&c{~-8eR0L5k88I+A(IcdH}rk)SI}<1;362AwPG2tdoal zH+k&bt30vXO`iJOt2}YuO_w)U*sDxA+lx%kh*9QPbM65- zIS{mlGF*NJcIMQ|Mqt0^KuzG2ck61b_lG@vtxG-qdcNt!O^;Wu$vGLQ-4_h+@?>rV z)jhr=+v_uLkue=&{PKVen)7PC{yJaUc*f-V>VQA!pB+3eK-;q{&U_S$>jU<$+ULhk z`+VJLzcJa3hW_1X#CkWHO9q<8DA&Z&x850ay zBGAN^-PN-%V-Q=Y9Orp{KmBi>4`19CiLbcJ&FNq~^YS@9GdxewZVq(4Z`}p*hW@TV zzVY7~jQLYH&7U&^^x}68{Z0_)2GpKre}4APX00`%)|^NE9RVBp;a%1E&@}hC+5AYr zK6QI0P>Xc!X4f?nonAW?u#4`|9)4TX?`BU(mgmy>9Br{Kjt2wwiIcW&jW2V$Rcp@N zoNm4*XCuvgE+6Cmd@e5I{(LSrY*r6Gqclh2V@@_XY!lygpB2OpZDrAMDDXK#jK@84?BUV3 z&eQ-px}39Bame!WGY7ifC+hJ!!y4J&!?{N9tza_Zgu61tjhbUwJSr*j+X`ELB~~r zHQzN@I~s_EbFMDrTXBFMqY0rB# z->SzQvk|aq8VZl`#qTW``jcy8v&o`k()yP;P!wHtu(cHjEl8{f%tTPk@3D@ z9*-=Y`|~j8!Dlo&4hI@N-ToA@`@xLW4Bb$OGMlL4Ooj>FqBmixm&{j^{C z;ywD)`pojV_kH!kHa6Z7@MrEvmY#41=@73s#c(kdzeS*lQ~fC2n|Gn3lf2JcLuc4ERd^-Qu%tt@I zVK(>g2(60Kqcgg9tfBioGrET|Ulq^KoYB1|^Tuhk?`1Q(t<3p9kNYRh=$@H*<2k3@ zoY6jYqNNutJ~0zpv4k&6T*XlPrTm*gqmAD;%}bBw8$+)rhyQ%Dk1tot1;_I5Ic)|0 zov0rRek=Hd{2NL42VWX|Yv61^bN8O;VH+8G^6m~ab9Cl&zBf&LqpbU~)-%q(7tiLm z&gREv^DAfb1DUg{G5Ur49!56t`?BCr(7Bj&?hL87aV}ot9L+c{+Y7X6ik|%>B8Q{<^7GPvo=f6DIlgz0+CW z7rY_=E|xXV6>D_gvtsR8)7mEwbVsMP>htU%Ycchw)03&@z9PQxPfV)&^RtHjRG=UI zV$WxXaU=a^Fy{9&!Z*&Z8{}LTTC!deH13}J*5-LBZF{*z_u{F)dg`y8dhaFn=W%ZS z*=fJ|@Lp-|-A%tS^(UrYuB|^~>Yp|BH%-02vtr+ShrWK)K0aFiw5fmj)W2ftKXvLq zed@h8q5q7jf8Er7*3^H_Z2k4q{Ebup%&Gsv^m1*kc@{YP-qGHgoV_ajH!GwxxfPG2 zfqK)n0=aliaA7iQ>>P@>G1{jG-i2N;&G~#LxFI0t%77fX(=P&zF1D1;n*Eysc^diH zwg|MH_|#(GKaXV`7ncn`xqI37xlhfG{I%<3)`jak^RBZ_R%yj%f1uH?CfR;Cn8!j4 z$UPpMn8xO0t%|>Tv;Nt^7YAP#e0%Wz;3ordCzF0-^(b$r180pre7rAk&fRNtsX6Pl zv+s-dXHBhqY@o(34(h|h8Q&9#^_c)2y_)xKHOCiqh(@bz#`Lm5e#EABv4LG|XV<}i z{k4$~UGG>-YJ2w=&QQ@R%cpH|7w@-pvik*{k5wumo&v898q&MVimlTY;_!*k!2+>x>P%yqJZ{Kk1F z|JYvtoH4XF4QFhOpW2)2qGzx2*X2d6ov&Om6C*M6Olpky!lyBA;-rRG=@`#_NS5cJ zwc{CfED%pkeUCm^KN|2~qZdur&P?;W(`)Xb-edVESD$c?9nN0w-Ln~!Q$Bg5W0gGi z?1iuQiF|sdUO3_P`Fxe(6W%%e8^i7x=c+aF&$5QM_P;N4_l3Fk?bH4!`!7$jWA5>at2XDoYZ$1^?=paply zGpF%ZdNDdR^<=0idabExe>TexvK!m}dl1)T&G{ymzKa5lJ&!F%+c^{qddX$GUK}f* zjr5LkjMdU2(Bz*SdK$mxy>iraZU6F&>7-BN5Bp1dRmN`(`2UiCzOA4>wtilowN=8o6%|*zo*-zMdz~C2fqc*c}Sa1`h}L#&|ZrS$;wdmWJ*1%{d{9FRu;W z7mzD9FAcOl=gBRf^Ck~k*T^92-hfT=t+5^N(ZE{sFE^u1IXpJd*q_(rUh?>c@M&Yr z#8eLX^^!namBUwLeU59g_OxN0O=!p@gWa$Qw8irO+xPL^8T0qRw1!@M`CVUaoemxf ztRD`vJA+lUPd0y*FGtPUUh=3$H1QnmvCcPjbz!hd{yeAqL#KIGweHl4yl8w=M|4>; zm-9OU&3T}6Rc%xzdVKiF`LckH=LO@r>;BuPeX*bKH%`}QuX(ABugRLTuRi8*rsr#& zXKR^na>R$;F()6JIbEJx{5%u%3}(2zFXlXrb8}Ju7Z}pm(^}l0@$uk9AaBsveNx7~ zm*(+NqZ-+dEl1mTHvZB!)(5lJ^~w}OHP6PrQ_T5p%-)m9!R6tbgU|D|&c&2&K8eed zjkQ`7PpvVW*WWv`_v+x%VD6jx>>Yj}V|KN^Gdy=5T5H}#3jTGxs`uWi@$prGoM`fA zKI-E`^OWJTE;}D<|EBC64dk#jq(;FVN#>z|ZS&mzV%9YJo$>ngBN@+u|3$&sVejjw zak`}p_W8XObkpfB6KiMvdxHA{cQjkQud~mX{=wBl#w8&UnEdRfKpLP7ewANldhz+@VzL2F^gSp@QsNe1ZHi%z+V>93O z2WWv$@=AxhWnZ8sK7TfUbLJYmDv$qs!~00U#?}%UPc{y{u~RE-=-K9*b~=z}I;{1qt4;SEJNY}`b56SV+>C!u zgwuhpI`{_U917}thUe~(w`WYh`b0awTRt~y^SiZj8pDt*b1e70dp<4WLfnk69oD+n zK3mJPAcw%e%|H{QuHTd~z2c>v3N8)YN%DJ1ptf3bzO$9P!@*sF9Jp_sr>lcof{TOs zox^6aB>QBb{n>n0=KE~{U&$nge9c|cnmn5^d)R(=Ko%YD%YMhfN3z-UjzKnG`A7%8 z(RVrvDBXpy73& z$;%k$`cJ;b5BX5T`qu8MIX%vAZKH$Ud428AnnuRKVC12XzxMRi*SZoN}J3rh( zT4l=R(dEjv59}TD%P;fhOw7qS5@?mvI=wt=YC)}P&HHG>T$Vd()xI3ib?Iz>%%}ZN z4Q>rqok6jvjp8bPJ;yusjVl_B47&Iy2Igv|wZMLL%Qo>+H|X&2w><7dHB*1jW=zK- z(8O+Gkk%Tm4)MU-Soco2E^F+i!&zjbm^~D<#>GaQHv;yMp?=vxuDrNxW0F|MC{SOi-6yl;I$gf%Yqjt2Z2^^4c&!&pa^_4?4r4SqJsOLL_jPF)my9MN^Xbv<8! z-{f`PGiq%SXm}O|X^Z9mf9I@<^K}86_Xqfm=lxAt+X%$l*_+${C0W}G*#60ZMuz;( zKRe3bSi|V#t??A=v1ZweM_!HDr@rf(y5yVn#z!yjdN$RL@&1(`xu;LQojviUORJrD z)hK%PqjzRc2I}Rq;a$Eo^s=?Ok7V5Yl%3YuEsvG+EBSM{>O!*_n2)^p>i1X|Vu+_c z^M?)kn}Usie~UmZSw9f;T&Zg^YOkEBEB>P8Cw+GZ`+^$+{%Ow5@!&*24n6fF!)316 zHeVah>6z?{=_1g`yeg`r;{H1&V22uKJinGHyMNcO<*f;kEAUlBp(~BRL|AoL2{GLLRKKV=plX*$3r7yjOvL<9g@o;>bRJ zd9MKVun08sRWVbu>OoD3`!;mSI0-q^-}dWv;A#EK5Ftqx=DRL~qX)(abHc=*&> z-`as;t!`F8~wKUgxHfxpX{H>Bn78&y0vvDG0w%cnB&-a|c z3xoRu@3i=D3Fv9;9?qCQ>vU&p=~rd-z9RF6Kn<*u$u|3PLU-#`eCXH2Y?aTg4fexp zmi@lvea+UZ1AJ^yJ7~57a>Zf%GmoBYG}C_)~b_^wNTcVLfg@?9InrQcQmLdGu%^zhbU+_m=EI`_=} z#Ej=)-+Zm}i?gS$<(FSa1GT7*_%`mNv-X@|Gf;>BE?7lF)<%HNzB##KIMS=9%0Dwaf z!hjyN+k86jaxj7~<9rf!sjj!R~pUoXz^Br+>`T%QGM4n(qtvDt_v5+&`N+ zU)Jq^*0j&po`LyUCD;A1KR6wrxe&eVm`nTze$o*G8Z{w%sk?-{qk7#Xdf41e<|9b3PxM=4k6f>FYyft+Jhe z;~A1~{LcyKVmH5fuk)2|`ovZqdf$03(AXi4<2%VBbFI9KxXZCPkd5c#1M=A@ zjz2fpcx~qN)JL*?R&Y037fbRQ6XRO~d1A{L6S017@Oxtn8gX9)+UT?T=w~i67J*hj zciV40^Lbyu2KMXa1>PQr3p?f1zC4IAze?A2^}HFNw|T)djr89Zd{^*O!OIdv>+pt*-xah@*;qT>iC+^M_CFHv=PRc9ww~CP`TnebdHOTy z@w_u*wrmA_sZGZ00_U&eb$xSB=7W(r&Mz8t^bUAk=zbt@jy)@G4SZkF+_3+ZL6*+F zcOS|a@Z23}jqkYkqO7}5NVhkRPRgT%ORK4ocVYoKDQ)&Y(KQjb6O#_Q-i8 z;E%gQ>s(DX5B4q$(91=2+?es<1(R;|x%slRGVUimCv^68A)KNN_KGtfA{IOA2Ich!29mp+kES^Rd- zY1a5`-@5x;vp(8U{qmJ8-H$_>G>B~duG;l1D$AgstRyYpUk{>Bwcix%S+>iJv%+abDQy? zS+_5jz^>AW!T#V22mkmj24q!UZEmi-->C&Lue{P^X&H00?hAA&@h9Z@b24{69tqql z_fGT2(rb8}2|jwi+?QVddtT|}uQ^}(K9=EfZVf&A%cFOn(TASxWQd7+!y^xTFOSaz z_DY9FEo}yxbu_ipdBx9nKJ&xp!`e~0r)Q0QqYY{To%oZ>$Lg-1)jg-H+*SH_Iu{3` zLp<&bYNInkU++g77E-nl$`E=8zF4!gxtJdpJxWv)r;9uXZ}Xb1G09)_Y&MUplVdBU$4kzenBIW-j+)D9^R!&Wy=X zPvXiRdtyJvy*%i>C$j@x^;=ViqaLvxY3ME=Irj$E=zcJukB@X&Gw)d#*U<3K*>9ck zjV?AU0*yan!6$MSfwoxw|AX&B{LMex4+Z$@BU`TsG&Z0)71Rd4jkPWorIEwRK9(`? zp){|}_Jdgj=|E8>wFwzvCc>L9UtktGN6NxV)L_m z@DW}0$;-500@HNsakw*}tM+3vZ-k2?bGf#8-vJjmgfd^!v2j(wh|KnVy1ay-{CtJpM z9B~vgyki|$M@tW#Cj;%D4tc|ax6fVlBkkWhV#h!x`s#ERLH`+-i-|q~%Up{MO z)#n$)XY%oP?W3|b#_oUQ@3*T3{(HCP7rXc}$`>>8(K%yeuA(EWboOi8sPpd+f2ZEP zBOc`PO-vsO&IWQ|uXDbcF9L0`{QvedxnpOLPIic+d_Edzc)Q0&{_%J8g&o%f=tiH( z6GQE*rkIHldUWJ89@faLuG*n)j!)}&x_&lecNjj;sZn=xFqiM{seHcN8=z%F?R@pj z&eqasr}$J~?U4umI;Y0sZrmD{f3YNo9e^IKHU8Wluvv2^$goeBUf%U&^$h6A(X-3D z7GKoPH|6^#^yF*>Zd=CcNsX#72E70&*t1Pm6*Z9uG->H9PdWfoJ z!y^~?D*xFT?+e&z4~=-!Emvm(F<%6lv!r>hYwgu;ZBfsB5Pz{HhtB5vNX9n@-ZjwS zyDgA2^ZSF|r{cn%y914Wb+Ru&V|-!oXrS@oxxp77*yiKc+%9}-X_Paclh60c$1`7J z=M6#YMx9jG(=(P2Jl4tKgFLClIUOHbYoo8nvwkA554{hJ#Z=toOwaem@|uhf2hAgT zal9!w7RbrCh8F)K&>9>5@qv%@pi%oz4XzIo=5y~A#`}Z%#@9oEywBIvADbTz*oarW z>2ogF);cEBx%-wt8`uA82>CMdqH#ApW{~!0LPH+g=k*{Kmj?F#ANKAAT=VlR3w>u+ zS|_{Up{D5sl&rO8lFT73?KDjd)bt-_&4fUY&_fOogcaxtRthR;g0u|@P@r0%9OSGb z2Z1U@DW}2~lor^4iin$yz?KanA{&peajWtEed~Wu-ud@ilSwP?eeG*MSMPbx&*6Ta z_x-*#hxBaFd-0<5i8+3bHu;C&a-=rCFbeQA>Y$fYhrHhu{F~H0?&O1xjew2^2OSS* zOqO-|Y1t!QZ-LKdHpS#~vHAD5sGIGecaYCJLEk!i>x+Hzv%G_Hfsefa2X_Qyc?bR7 zg8c72I1;b;tcmZ#=6(2(^TyWo4@rm3BY`>l$^*X5iDBK@(^;esFL=ibpV#GEOru|a zBxlF*(Tv$*pANMoS8U_Ce77d<%-lwRCvAP+OrK9npRdRqKK^T<&(0WA*MB?n^46Hl z%ip?~T1!3qYuQ)bt?5&l!!6J$?@tNnqxYct!HqN4cY@XsE?PsU(--@158vbDfsMYC ze8kbZTEY`fzBgd6y7hmbN^Dj*eganu>C-QZ}YpsiNHMF=K{LKsea|g z7+?GVXFoVlBi7uVZ=-}d76 z!GJAuR|MmHYrOt>m-!}7?69fr=k(b6+z=1F;^e>YE86-)FaP*^&>CAe26!NMq+SlE z#XmT&Ra^8Ji>u!=*x;jeac%@+FmJy#d0VdCnmK&1JH|QgGvAo$S+1?q!4L6|Z*GPw zKln4QU7xXh@6PR%mdN|b;8cK%`iMh(<3N0JsrByk?~C&hK6q|BUe~hgyWCcQ)3Go1 z@+U`)HQm+cy)$g%M}6X$e>goB5NnNBto#-Wy;DF=1oA~1k2`d4@UDR0PY<3SEdL(Y zGcxzQ;LpeCc*cD)CbiFBpieyfI2Wib{!annj~edXz|rzfHa8ntgT_t&L3#O@tgVB4 zyqxD7pXh2%@z+e@Ub|P{_#L8&Wro; za<;T{P~PZXf-lQCV|MX~i!pclxWO5pTQA4bC*zw@zQyTI70%$OapIYr4e(hk_p!Z> z4|A;vTucEG8{3b!-aCME5JPim>^xoaxDoJ+&$!|1IOe0Zb?4>$uHYL}fOMS=oY(Su zeEU8<<68qQynN_)uI-Vmf%;_I`=Z{-8-jc#U;SQ!Jv)KVQTNJt-21e7&Yt@JQR&Oo zxTepJxV>A)f^pBde$|@w-nG^TU+!@!BM$}QxXB>$d4Z*82iF8w2l!G;?07Ty@$`Tn zbbWXZ$h$aR8OReUzkWY^3GpoFI(D|Y)CS>$Gg|R1|BmGqncEHcb3FdYJ%4*wy(8N} z<0zk_VVUycu|GxnYmd+JPW@xwix0>THtnYZ%xpzqV&={x`1A@An2a>}k4TMxgH zHF5C^7gIp!?0Z1(`QTU(S1#g;zUG0Bn}VN;PWSgqgTE8}V(@5S9{l~kDNwIsQXlk; zwc9$kE?2E_ypQ|3-gw?N>*aIT#3B!4eY4#?>+1KfMh|%?;NMrwW1kCrG3W0KE!e^8q(@4+cP?hW1*sCoB6+{^D7ADlVT7`D;}XHEoMTeoJw9aZT=Pb_XkQ4P}{K7aoj&I|5q?|rK;}Lir$ICwdo}Dur zY1O-0(DLu>F4Ib~sr)Nx; zTA|y$qXw;k|REaSd6uGu&8 zHDy1UR=@7^>@DxOt@qv?x+C!U=}p6xJ0^d0;tN-DrM13n&tz^hz^@t|_4YH?=Mo>r zwG1!({-fIRuBeeQpU&+D&f#DRh@Z2^ea@54SC6~ceSGoe(^-Au5@SCf@l9|pe&Z=1 z)9Tm9&UVZu(Vh%W1?+-%?UsOS1@tZF`gu9Vsy_vUUb>te@tlm01=VNmhCuGf?SXS* zJRgYXTp$lSf&F4PwuTe?w*&QnH~F@Y&enk1w3muHb|(?6SkQoa4xxz0J$m`W*0YG&a++N%+c7XXstF z&&^!VvDN%Ke>!mHlcTfs=008@u-m#nls>V?&t%T>pWWpguFUuD;b1p75$MzPQ1GgN zuf~rAgny*#>Wl0JOPF)nBoTQyue9jZXoQL;0i28C>v< z|Msa{z8w$jq2r0}&yiKG>yJEa1#F!Qmh+e56(@M~S=;|soBezz7HJa_s-oypJt@voZSjPcv?9 z&{sbnPM;hL*xU(xpLj_y+Wm-(Hv(X@1CCznnU;K`oO-?&$nef z+PyJjcD1!T=4P~|F9y6XZEa_c9`Uty*X6+-F#qy3_g~(}+ zo2xTN4}awNQ-d)Mb#G10EcvoFp8fcFFPnH_ukXU0>0c4>!yA8gZsm=BVvn&r>;~@e z6cBe_Jl^1Q!CpZBtpUCALGS3}_B?OymVj&pav{Wb2=L<^ z9efm%xr1~xw?DP`^S9d8O*9UU* zX98lb`>sy^b%DJf5s)ic;9Gws3pTEZR-x|mb zVYhYFyIg%@so(O(M(d%iIPt(Ab8<=eawZsaN*_J^I}vOI&aqF#GwDRE)Ae}kts^=? ztmO}9&eJ7cV|R=le)Z0Ej0=9RJAWkecLl$mVA(kvu%&f=thGOv@raLJjK{SsU3jnd z3?h&0H>-DzT~Kp>BH)8R4>2d7;<+jik2x{)&ElJW^LR`8_RHgg0iEh`H!y!?Fa^ZB zdv_qe-<+6lPK!ga(p!$)Wp+Eyp0SoMQ$VKGulw^j?j6~f=h zJmX*qdY5w@J6m0NBjRvItIn6d&#PW`1O9wc{K1vDoWYmax97GzkMlS&*7AQjKB(T< z^Jiyrt;YDFR;Pfl1$6VJcb+fJ*&oaKgL3xFtclB6TucF>vv zmj&|oy5L8He-&JvKpqOz-XV%3kL)*3^51n)J7Tu}yBXua&#UHr zCW!f}U@K@ou1;SL`Hxe%d~a+0mt*rF-uTtpX3tm+OaYlzzwY~?mLIRi-yK`zp+LMp zFpuv~zxVS8Gp8QjvDo{a^Z4_!hDLu!^_sNomJ7KZbE+?&^nJ^GzIpt*j0-t!|DZNo z-lHbe#l6A10(Vxvo*yj#?CZIiBmHdIN*|oLG2q&|wd*qPGg^&$gWYHRYsDu1gW5A$ z+YG#6bf_6R&INR64?5fVQ3np4$2b0sUmVBB@k<2~DaYqB9)ag^yzKMy)|}Z$+j?tm zpOHC!t!weS8Hkl%&s_L%EaN5kvYhKUOBdyO-COzlqm#c+OUqw5aX*@yb$-_WrN4(3 z{{Bw%tOK9d&GX~m1W%N=n{wugU^6IpznDIGb>Q#A{Y=_}z@OzBUw$&6PrQ9Uo-vQt zwd?%wvjnLh-}|C zn02v3w>5FRE^znQ?HhNwcmEYR^Krp{FCTsOvCTLBh}HL~(*b$e@biz)rtN^wVjB0| zx@OQNFdE?}fPJXIIIn!=lqCGRO%YDCF_}pcC zw3Xq7-+vnC`LYqf_sqK#bKVKC!AJpRaf) zty|;CL}Xh1`qeya$TJdPr zh*mtlvuy^gn-g>Y1JW+@!Uo}!^ZZw@fR|eXe!&L@TS52ntys5j$~u`=zrN@1ZpKOe&#ac(bAOWr~J61nWW`j&^? zfFJfu0TCbJV{P+~59`|JX1;#VHRkp7d}eRW@3+%^GH^!@1w?H=-k-PO@u5Hr^6l&+ z0l^#TI<86A`R^@Zo7jh=jlewLaiSilfZ)TNn!FKDOm>3C zcO?C-fDU%*BNM+0*>md`H@NMrw^^kKtf zgpHp4{MF3Fg2zA6WAqE$fzl&E;U*3|Eq@ADaZRYZ&cA-mp9`|tJmN$>%Lm`e&l{4{+Qku`?+O~5{D{YVV`_Z3-iZh2=IO3JpD}!KpQhl7xlOa$Gmh0N(JuWK>+OO4Z1Eev zwexs>;|#}3zulWl`HlCp!4%*@OV~Te_vXpEIR0h8e{VbnaVRIB5vaLe2*krTv1!HD zep@*?6Kn>2c}4J30o{DGPi||+JYDSdeQ@Uc7vpcrn0;sIDMxbWj;I6erRK{=_l@Iq zZwdd^Mc4SQM%p^hC#^WN>T|p&e{S(M(ns%3;QgUX&9{9#o$Q>Lb@ndZp1JypLq6c} zP%v`(+Kl-N<^N^re|&)dt~F1_`u7I!3cOq1OZDQ7Qy1Q4`@|ro#xeFgr#8yfX8L?~ zXZb3B>uTTG-9TQeQw@}Be7-Q?{}hmNIITvHeFt}E%Lm_21bnCaT)@_{-?_c4oe4Gr ze)IWgK+n~|Iz2txR{TpH@+rP`KI4Xu>~+2M-8W4Q$+O(3O@b$RfhjmVw`nfunG7O0 zA=;C{sery~0x{9Wrq86-8?Nv!56fB*PxIv7==0sYR&8pp%Y1`LFiITCU#u|GvEA_>_z780Rb|Sew-<1NQ+xTi8Lf`Vo(FV(PoH>@Q-6>PvR!vSeSUlAd~RrW1N?|tpAP-DQ~HMkEm;@)-I?bjf4km$_CV&?I_UGt zJWRpk*~yj*pIdag!$d6sztvy=8w$8yf~|3`WABYRI}=tf+-;NZ;VsiegF9`AIAdoX9IWRQ?g)8{PIJV0|J9yP%q?f4G)9C-OW_Z?|}J9v6X zcunxS_yccC|6E!+z06Bv8ro*^?FBeUohU?ejfFWrV9^h#6JE$ z5U_br9k!O#`EG!(DIj>FvwqWQPiqS=pB#)nIYTF3N8b<9ebD?y&hv#1apGf)W1XKp zGi5K~$F%`&L;tGQ)GdG8x^L}!m)bv*{$|koRz0{l7ud&#buG?1Kk89CJM%eh?+4$+ zXZ=k95i{8fyd7r)_ee`O8~V2f&Xa!MomQj${PA%&z`+!d6M^}SxqV+aZk?5DzVdD4 zn7_vB_{C@IUi{^OPxkljy(xWCUii=EX_JxnAHGXhkN4(Ku#Ol0;032sK=5Lo$d5jb z%XfYFdP*bC^3y(kt55$e1iW^wzSyUh#6ut7&Dm$p*qh-0iwr01I@`DAMVVg*Jgl3S z1Mdc({&>!^&7OCFJ>LtSpZOcprdi47=(fyt{F<;t7ZF&}ZIJwLZ> zP625gWBi?KYWuuuKRnahcoZHG2WfU!Md?rjO%#xT|wK= zGjFFo)rmuUJ}W%o4>walx|cn+y(@g(m|OQ0#IQHdU6t0G<2yiOJDNUD>DUb9m7S4i zWBaw`nm_A+>vi*)eh;qw9bi)3^~rr*$2T8|ob@f6Ohj;Aj?14tBj;Ujj+Wy~<-{30 zitmnKH^5O+bKx%f9CnAt?}bywq&c#O-Nq_s^vKm#VCckm)ZV!^)3*Q6!ePG%01($T&e>$M!8}b)<_;^czFLfn8`__F|xGM7m-(sYP zym`>$d}FOHF_@bI(wb_1=$kA=J5p znAhJ5#{4@o1%z&K+h;$!_RF2T^Yt?W=kd%pv5Fs@vDcZguIO|(*s`y8!q|RobE+?w zo54Z%!g-?3`rbH)hbhg|XFk?!ZKdT1@OgYPLI?EGHT96sc6Ss!>&r~Jev{`lCpE!~yx-VDO``-9g9_yDoX zv9t7OTffWJzB9q;K%Bpm|D(OWN$fVCd~%jO`f$W2IXOJ{d+#5~n6Qmc`{|kjaw1@t zylKB#<=$TRRUNqFw+HUyUO)$1tr>HCvX@Wv@n0O|ht|Y#Yv$cq^2q_N@Xyw|x?^j+ zcj~OMJYIVydpCoF-UvA&c-)y=`lsMXu+ASG;>g)4ASVLz&kNodGH#y7Q(EE;J{g<} znSG&rj%n z`GzSV)9Tm9Y65@91G?pzh)3S&Q>$XGzSh>1IWnz&Jy;(d^=~)*-eb0=fLO=P#ZF0sAh{@-_HTUon=Kgs0 zs>~5{eA3E;KHwdfV~tE16E&nhniu(GkFV^VpU1T?j{5#c`sCSxIUGIFc%C(%{T~&N zS{wOPZ=}5Qe*$vc)J$D7( zJM-hcqEj4NwRn5rPHoR)di!0Go|^+Ts4m4*d;cNMv&RR%O#xZzR|Cfau{v+Rwsr2$ z%l=Uo56!UtVDJ^eJA=+^pPWMZj6l7d3+&wq)E%8#xuA2bVKr{=$Iq?)68)a6Zof9R z#_`X^;6~=z6f2wV1Dp6VcW>~nK)#cdh zpfApjwRqL~?3@BJt$uxM-ExQ z3l6_89Fpeek&Jh;r;rc-=C$Kx%QrE#4x4j6ns58u^y`xxF)Lp8%Z%W_U z=8b;RTKV1dzc&Gl@c+#+j`i8n=6@IRG5!p}X7e=8i^F>X`=l08!ePgcKGp`ksR*VPb+ZyqCCJ#FSow#7rJ$z<>%jWl>+IMaVwaQoL z)&7|n8ONWpSpS-NFF)9p2l4QQul!;|T;|%INgr400ssHK{Po`u9{v5W=pM(Pn(;NW z&HAQ3PY2}Vhg{3Yb|5D4jr(4@X5Yx=l>KB{{rVUm9k*>Q+>w1ggVY}WT9a(@6K}1P zu4(bO8Q>A$qrMDR-&f?HJQVa^7(e2d$VMR7?+!xWg}S*e{UyY>oa@+GzOu&;E&kZ7 z|Kh=?wa(cqZhOty)AmgItrL4l>-r1RUxI(jxsIJZ$Uj`-xBeNAe%0Sg`8INQU(PSV zx8+>N@g42PupC0~<9dE}2_T{Ah z&H2^_q;|@ywr}-`^uc|!f5g>` zv9;#~4<$hF1U*wg`n`v)jn&Nl_sKKqi-pgvH{6x$#(^{Xt$jeif3>J$)Tb%5LB0pIXD+Rkw0U-zBPcq91r;eO%o ziN=>BE1z+6(BIQ#2YN?ek^V;qM7(l~(>nq(&h___#Mru;Y>JGr9M1ShhFIj{Sb(?Y zFWptWz9B7M*R6eK=J|r(-Jte+kLj&GJgZOd$l0LvPPdr6HRpqJBOmxB{fxu~-|@4Y zGrydpdz>@o6Z=y@)Qz)a{_RsATS5Ktmf!&2uMfoiy8-E*qv<_|@|drBCNG1M+Yn{$~Um0sq`Ddrk-PXl@D! z{gY0l`S*Tb8I%_sZwKTdj*x{xz* zj=u4cotFoMk3BEG+BA>14+{7vXU_if;ona4Z9CA)lRf0yhCSl9XI%fvVg0&!T`imo z?B|c~>(#%P{&@b=hx5)I#KT6`)Uy1EMPDp^Bh;Ml0QmHtcuV?TsvmrqFNe3B#2lV@oSkDI9ewPp%8*TNM5KHIO96RDA^mW{Nq@Q2) z(OLNsPv`jAI=}-?@P`L_F8G(h`z?|6R|ez!o9D5!jS=tc`MJ+LAG{5?xhrrF*zLWP zBX`0+bK+=icFw)Frj?6h0srxFcOZAi12tw3Umgh9Wy{^x_U*VQeWJw^Kk3ll4Z07X z{A2sb(DH$A;vDN)K5q*S2czB}%9sth_$Efa@tJh4Eqm_8Iv%gcJRkXMU-kA(+cQ~P z=OccmfHY3Njy`u@JbaQ0aQApRFbN zQOCr*+8A^2(HV=eKFYyX&=}X<9dU@uT6N1CTf0GZ;esxFumSRSZGboH_Xo{Q`_{~r z+wJtL)7)kt4!(Nh+UJ8>C;S6?8pHDLc}wKzV}o}Fdx1K5aX=?2SGW_mSk#(xowLWB zR!sKr%^vS5sF5)abH?nI!xQPVaWXg+;0wGzG}CSExq+W@?FTA__;*a`iebR|5w#2v*)c@||lYQc0TMKNP=l9v* zw!qoyNq4os^&zIM03Ues_W|$)>=OE|s~0?zan5_o-KK}GIMy@4a7(IDKC2g z|EGY+H+?>HuL$V3_k2*_<@WkOzSNR9)e^sroncGt)|Pd`KfdFX&&}7-^!X`XwyQ&* z9($*N=<~Du`7>d)ayekvK0-(15)Z%VG_R)cc{*VKEyK@Lxm zdB^Z?pPDFFI0X4|Ze32D!A;Mw0rKjMxW+r?^S`{x7kfTiAI{{>X~jJSy`NL&i2dq$U7qkn$H=EUw-Nly`Ofvf6LNdzo)V}leDbrr)^_WSO*)7?w0`Wn zE>Pcu?Qw0aKX+`@u`W*M-8a6Bw#7@9{P4XtdPg3QuPbuquHc^qM`p0+-2vRM)BCi{ zt699!p-+$f^x$sHKV5`wXXT`A>$cx}TC>NpXIcAqXU-d=X1pzO))*g1-(6}Py<7a- z4f-!5b?=1WB>U=*#H_~TIj;l*85qYQ&VsgH%*z9xut;0Lt{7jiAeDgC9 zVVgdBn}7On*ml(Wx;1*$i#nlK+dK9|_~QdUACEsi@sq#u?p=9uK=y*(fveKrG8s7= zbRMUzTe(ngC1i7aPLjP z{fPiK2h}dl#a3?0*`Nd0yf;is{^&#JB;6B!9lsGE&H0Ev0nJR5&T~Gj9(Bp z`*LqQ`gC2!>^IJyaR;^ncj@fhy05;o-I8_*HM*SZI7=%X>Vq%r`;J4{Ft%4d_}F`K zU;54IUFqW-_x-&J@4EeJ_DEoT3dotj+E^DjU|&2B1huo9K09=idxFlnpXKJT#mM-1 za%09gv+p}{FNC!hxT}3%r}PPqt`FE5b<(@!`{B$H{#w_vdnvxMyo!S_zON0$ zZU6b8wR>*vUzwI(HSSz%eKY+lg1ZCUu=N2!eQ!NqlQ}|1@0Fa2eK{5{e>+dVeYM^D zCAYT)#N8lTww@9kbiTfi_vLi&k#Jx<#;dX$CLBo;oELdy?3OK&wgh0O;+RP zaM^ZBpG>P?_kaI~o+H6#P_CEuvb3rTd&R1?7bo}^kNF=+Jo19W#&9To{^EJbkvTft zC3;4Fm*=fFR_EAw?cCm(TW2=baSueL;QE zr$cRx{?f4%RL}ABuL$HlgGU0o#YEl^q4uBS}*dWem4WY-yNI?@PTRuff5bQi#5%5~fZVg+tlH84r)Qqd=GOP&?Vz85bk;9@d)e}tJq4ue)q6N| zc-ac*=dZVojsEO+E`4^~O>s7l-cMrg;egF61KiomHom5Sydq%Fdf(!5xskb>1N)bJ z(rH~?(dqmY5b@xS;H`1-h48I;5R<y7)JqH=Y90^P?@_fj=h`cyw2$fV7_Yz+Y#@MDWw` z6XA~j`n}AL@f48eT>hGKcScQ#r*&q%b=G>$)XFz868pt4#>RK+^&Z}cN^-k92R}6m!Kl-_>WuHIZ+ZP9XGN%8QfY8e)Z~Jnd?|gkQpqHK9K<@OX zfK01j_c?Z^WA6Z)M}ykX%I7$~CS&<=wt3Pz>+XtKzE2G?%N>5zgIwF|KG5qPX`R*5 z-}$}t=@!Fgpccf0=h3Y@5$g)pf1ciTVDVF&(DkB z*Ck(f&3s*v*1M+OaV($P0p6P*xsu;yZq$%9bt`AyV0)&3$k)cI_y7Foly~R8pfRWu z-xp4&6)!*kM|_6i>ovji0yU3++<6;tuV3HNz3@HS+8u%Yy;u0>yH@V#6DM7xj-Hj% zgU-_7{E@(UZ_YR_Z|=SI<(OV`<6Gq&FxNQM*|FfzJjWlpta}@(*Ld9;AMw+Av(HA2O-Di)z8v(f|=v$$6me0Ls>8{>BHFPpK71XZ$ z-7$}yS%MCAUKdhnor@W7t<+g_Qzd*NLsuMNb=hB)0f`}t4r6~Sh} z_I&}4P6X!pz2wI{U+ihU;)d)5&alyQ9Z#7f&K+9y_Wj`#-~0R6a&sx*XIyVigRgf7;&z|-+1&Qdln;A0 z0-`3$Az$j>b?Nhuh(+BI_UUGi-#B5%xm$vxL3yh^=f&@PU-wVxlin45YkL8Id#3#1 zdpGEP;VZlDM{}}~{y!aZBChL$-tV4u4jKpDjoVz~=Fid(HoR%pdM4eq-v#7`ZTgxg z{qY<=)eEl1{jCLjdPkc7BSYUD9$p*Zq4{9Ln)i!Nx!Vl*a$j(F@V?XuTlG8L6-WGP zu9|mTHa0am!ujI?pS&xi+>1kgc7o3e+(ADV61?vPt!X?xKk$8#ydg*lJlgZG&)9i( zGxH_NWUn(qk|1*_+8vzejHTs>e(3PuUnjVmbRzs=$65W+)=tL90zTXk5H|Tn@X|P`Zk&8ND9+ui z(IMuZm4Ea2V8>XlK`r2v&hBRmF13Hm0eyI&OYAsqUv0C~+Td4xlw;@42KGG^xC8hm zkL)+AI+wenfiw8>o?RKV29KrRHN1A++cB=;-`n7>YzJeW#kH zy{qigNzW7zIV4)KRtLXvj(c&G`@`vr)!dlp#!-J0!phFlUpx~2Houqh$zJ}-Te)x#^qDS3|zg*yps3kt$7?=~ge+!K#eB!BZmVV=C zT)UYYd82R18@}mXp1m(~y-(?0bSLW{o~n;Oc$Y7BaBr@@OzD$p_3Qq*aj&xn?X4dp zKVowR%G2re#WH^P;e%Rh&iKpDxqy#%2K0+*)Nf4hR#0x%)dzm<6$?J>S2z43=6YVu zjGwDG_Wk3IKu(_-s5icz4dk}>y#A_lcauHws+%8AO&H%EI3q4TTosJ^#O{4K5_G@! z%zip+i_gdAF<HKh$5q9wK z>R|l4L^!|Yad2JMab_jODbWA>QiOMNqEj~uYg*Q3GNpzjl#<(*yrxC1u^^vdyv z&F_lObh_-LLmv5St~Q$-t^_JZ%O^Y|IGn^oH-jb$L#R`M6eN%b-8s0*L{ngnf?;EUe0yQ2maXu z^ffki#dc*Ncl_s9hC}v3!G-%HKlag!TlR42T{ORrOXqjz zJsW9>e6_}n<(Gf8i9<2>-nP!nH-BuZtAp+Z|E>;NV{DSqcI(xB*~-{pvBs zt+qb)JBj`A{#{Q#T5mh0PZ|sV zUmW0yG$+=@AWrWxuI=giy7A$x%dXd&S+)X*{TL_T+M1jbEzP>RM#RmrBm3KAij4|J>YgtnfAzA(&TRoHe`CD6nYV8Wh_j7#G7)iZo z`osrgUHbd&my6bAYkldP_0EY4XWlz?iYr`*)BP_m{3)l6f$yya>;3uk+&q70T6*P^ zjC;;!>@1GtNImeEjx)hlP#>>M-`>8Lcc)(;y@B#Z5B(1WY+e%_4%8IB#YSh}D7CkY ziBHFZjesxedz~-x#wNKZz!Upyu;=cuS$^25&+6qMpY6XouwQ)qCv1#0V$PmV4jM0i z=;jCeeB@8{ye56z%AK>guy-#|56$hd^w;fGi(+%0{u=}K*m!yBny>Vo4$S|Pq1Kx} z^VMPBM)3CR<0Cy}C!oLn@pTG_eRL4-H4SulFP~)?QG3l9f2yyw)cYxBx^D}}sN1}K zbd5S1+t0>l`o_QKhyU%MdK*Lat2@54)4U$!>(-#hdHd_%SO-3*ng_bSFMes+UdF4I z`9}BNyzcjf`&pBzi#|KpQ;)S*pV#T8cip@@Rvs>8(>`$$c5zv|;vwtw*X|REsdXmD z^=-`YlDBn!^U0YhAbbv$D_Q5~IvqAUH}ZO^IJ$S_g&)1Q&bnLTYCQhz@Rh-p!SjRu z8DZD^cBoD7Y4z*Az4q_PTy{obENa59yVKlYL8AnYz1;W)`7j{PTiai z*!cOm9_%&muBcU_=Bl6G^0D;cQgPG6mp>*zEu`-bRNpv1_W3dHIhS#HqsRNIPQ=UC z*4MS^-xaXItUTCrcTgVrTt0eEJ>dioX9JwFX}lBM8q8s=?!%NZY3*pM|9Rp}TQBBmL_FcZLprj656jiQi&rOzw}nX-?lB{*HR}<@d^9JD^KE;~wXU zJ!*segP}Hh7O&3@!~mmD)ps=W^x?|8AdgzP(wb*uBlv*A{q;;8<0J~-d?+RxOA``)V)8M9AXN9WR~@47%e z5cyi#xIS|@yer@*f3&r!ru0W%?4e(+ygC^F|G%D=@owO~6(gZft;yG+;1|~9%YHRS zmivF=fcITb|9-d*q{>%g1;J?d|z> z+{%Nuo&WVsY(2BgpSx)9xGvWFg2uy_b@BL)GRCt`x3f##xKeW)0TH7)=kEx}{Q>{^ zC!VvxUNG*VgMKl~y*Lkwc^MPG*Tv+GS;pjSeP)mFxp`q%EbiDj@_Rw>6AV=2R4?3Ky-nO@8j!dgxAKTkAzUv+j=%Sm?wPg=m^d1S= z80}R@Tj!^MEcMdged}8Kr+{>QspD|g+!wXu?YJV42R!nt^WLrPps}k7_MJay?>fE9 z^Udv{=(#b_l1K8E(5-g10=nAYOTS>dT#I+qN0*%UeUR%P3;0eqX&u`~|8+sv6KZtm;Cd^JG$;Xf1UNN`+F$fs3mZQ zpXI#q=(j$<$9Tn5yT0FiK>`p{|2x-s+6c5u;TF0c-KTsKdb`kMk`Uq44D z6OoP&^4<3azJFnSzd0>`rhs@?Nd0XdMxWXAdsFLx*X6u=!yDhp`M`a{mHhMN%?J46 z?Y%Le1AZ!Uw^@c@79U)Jc78{eDOL47Uf@5>z9JAs(C z=W*|eS_AittmE!49pI~Xo6hp*{{F+6zsB%;#ot>F@M(E3*!TMd;`es^#enF4S`am> zH5}Wcrt9;$d2Aks=GT3$t=p$g>GJmVbI#99M*?q-^(i1eBaGLzbeM1Jyz$uHnsM_t zrBBWT#{==XFV^di^Ws-8^oadZ{#Yw+OP@@uUmx>%X|Hjzg}dc`^LSXc2kEzu4`+fg zF7fRI{k^yGvs8`S>yB>+t<9zW*6g9^>|ILtN&Y?O z;j|-vdl?t(i%%@x+))o*d{mpx?*!sk!|KHua8KP~Z-6l|J{_?AuZPb>=dYXRm$sbQ z3e-~X&#Tk-8M%Cu#xdW{pD~A{iK zJ^iu3UU4r!7ySD;dU4OE?O^$4T$wq%k$*As_LBYKYX3C%+1Qx-<&6*Yl{0U~I>c7vtFG|oir=@oaNI!pZiPzT#9~*pXP%g}WN! zj@``nJA`;ZKJktZHHM#YADz=Y-#zx*V|+GH%W9x!ov}8~t=pR|Yjqqn-&ojxe&GKX z_L{VOcxCY90B;WmBxzX1Hs)QPdCFIQdfNyc-WvbD#@bf!iU3Chuf|6LIsW1(Uzg*( ztkJ8k|9j;#~ta6q56Hw4af&u;qe^Qi9` z8Qa_U)P6DAH_p@B`P#ECe;x0nUt9I1`ptL0b_&R}`t>ot>iejNPw$PMH|CtPe0g7W z9OPG2U&O)E@7HAg17qBs{*B;y!Ivb_y>Dvet&8!OF2-NB7=QU<{1wA^FZ!x`?B9RD z{J6&(t?o|;^8I6ZGu62{-=)oO1b;L0_Imex4>%HZ?aQ;~Gr@jqR}O2Rl{LD0M(Zu? zS^r&y<@!^H^^eHB7nH%G)Eo=W_{_ocK{d8k%bc=~UbpA^Auwj1W z<$ujQUd%)H|3v2TVoc}X%NQ5SecwILci*>WT>Z{{RmSS#FDI{f+zQ-JzGmtIr|CZF z_1W8)jsH}}V&UHu5WkNo9y(qWh>1>ZeYh>>oay*@#{3@Ve&N4dZ0ox-=J$;Ozu~2S z`_V^z_BcCo`E&U{Q)~^{_qiF{)7mlj?0K&7n0xYk&fd<8<+uLteP3!jQ&0Nn*w)(H zJlOlAYxcf6d&NrLk#*ekyTMlaW37DEn)CPOyu19B!`*8Q;k$mZ|EAfma=G&VKkeuE ztA_K-S`~+PZ`AdxYjpi&bg`}0#=S53JNtaJw%GlG?3MR1H_x1X`Rc)!>MQSBp9$Iz znp-^KP`=;#yBF8ShcCt-nz6Ij23mZNzTQ0hYRx>o{5_U)V=kVNG5@WrkN@<4?dv_3 zzOyd~M!l~a^gcUl)%y=}uK9AN^FN$<`swnHcK#i+og3!0DeY+ITVh8opADSh+c)G) z-{RUjm3g}PqP=}?KQe9g`M&bggWvRZ4JSYUU60lI^E0MrXKr7V*8ZgONiUv#Ru}c@ z>^%3(%sF>{UZeMSf9E~#)C=G7=%c$?YaDIG^L_yxXXe(=W5)Q@+FQTX$Sa~N%>`es zi@m1~<3F4+o%Qv1fBWM1^p`RoWBGxMTif{l+KknezY9kA=({r;_?ZIIKUZ14hvQlO z&t2_)?5z~jhXjoYXAgY$eoXx4n>~L#5Q7{%IX-!}dM4c`eQVBeaokJSOY)a{mv6wR zSA99t&sMc&{1J2e;x$pLV*xcTcmXB)fSO3FfcVXOTou6;Xy0ae_n8WpF zXKt(o>y6*hU9XFp4Khmt$w$j>%AA6e@ z@ivy&5{_5w)WX@Uk-~Mm*{lf?SelF-VWS!=Cq4tnSUP{MKW4 zt8sak?VINIPtNTZq;>8o!NbEjpT&0sy>EE256^!p`>NO7@BBTPXXDyHd)wUp>A6)e z=HDEMnQk@wIq$kSrq^c9zMfNq#yA_#{bJ5#YPGgKw>xv&v*o=!vnkdWynFvF-_8Be z`2N(i9skn*xgX2bnPYovZu_00`oDNSBaW}mnby-Y=KX$Vb^ede?a8@a)=l;O*?GNw zyBp4b=G;CqxAJZNYXY3GFGqJLuIJ<*%zth0TfqbQ3lmpl-rheFG*^Fc@b%oh-uu`Z z{gQe9E9Y}~``+K&=cPG$D09t;+IZeiUd-#)%=@1;>%jHrW)4s97x1h2>h$@?-)GL} z#NC{{|9sB=V}VwkYHym`*Ujyx&FyE+?HlLz;ko^sx&2FX`;BSKBfq}vCm((EJMsrS zH~gb;7<|i5KlZ)i#C+zn=k~9qt>2%K-$a%NKFM|Y{u7zMIpeQQaLdny?mso3tKRzf zdGoxxO7GtY%DK;!yZ-S$=jF3+TfZxO)O_ww&g~oKcB%Kx^L#n^qIt|7yWbIr$J_g? z{KIqh^sVtn+xo2T&!6Y3``hNd>VWTG^E3Ot)6?$}&q|-JC+g?l${GGWHF#zI5t6sK zTwgh_rFqhA`9I$p#~-{HZ_Z;e@soT<{-KAuq~F|s{D>C9Hvgu%{nEL07tDX%+I+|{^r<7 zvs(MhbNkoQI?tak&L40%_o2aPOHR7yRr4NxRJS^LcXadNqXK7}SAO>FnfdHB^Pc+f zRr45E)u{#_`QP{bb)Jo%`qh2^T1(~jTe8OH_Xp$ozmUKDk*Sq^=f61TpPF{8nXmkn zi+^6cBV#qK)~jn(Tfe-oOMduc?q~jweSPk8=l)XW_|iJ+d&|Bv&&qn53qE~%#=S%R zK36`LHPr7mZ^?N!zGQB@-yA%BZa;2r#bUniPT$LZ=5NmHH_Yv`=l1z?+s~Y79)H-} z?#ylP%FE{Q?%aO#+%{i#&f|}n+k58r!A0B8vNz20y?gy!c=J5pI$ze&lDEGy@9!P_ z=6U?Kx&2#n`}Vp0_PKq>+w#Pv`dM=Jx03_7~>%m*)1D z=k{0T_Sfe2*XQ;(=Jq$|_P6Ht-_7lRoZJ62xBq!=|LfcyO3}&t#@rsB+o#O!k-7Z? zbNh$p_7BhP)93aXb9+tNTcht)0a1@X65JAeT`ue^(*Apskv|sn_nNoTKO3m?R|oz7 zf$|Q#U!X1AFZJ1R+xs$iB5;QYeP@E}f{lQj55_rl*fS^7KNTc|75L$#v+mso2G;1k zIr#d-!#8oLi%$yNk0%HA?F82CXVaO#k~8kwc;;5Jo{I3R_x2OPsyBj zl`MUJ=Kl0bk8|UnFTOBiT#27u!d`RG*q@d;@Md@$?Wrzyw*&be{U3F+(YTx!+g30I z=F5M&E6%!JTOCg}MC$LQ@^xkQJtv@_zjS>-aD5OOFU&7vy*g_}?XQc~nz(iXdHriq zDqmx6)Pme}pEF{y{~Hd-r8>ZA`Lcgm2Y>y5vtu2IRo$~q_{q0}{#}RMk#m7MFIOAs zAH;X{#hq0?aoIU_FUMMOo4+ME8f*uz3dBnONWfQP{@OnUr1z(J>bqbb+y}lM51ti# zO7N!OEy0%s-qGDa4EQ0qa2B_GA>!_w8j%B{b~-Pf#-YB(eWT8U_NgoSS|{uH5P$iQ z6a0&hPMq;;)H7vF@HPcx%-`)9v)BAREq#1^ zP>`@z`sfk^5f46_2lg7n$Uhw)8@w~v3-J7r0r8P+eW^nX=J3=UvW17!fiwR6dbHPE z@oUNR$;_Ra&pFG72ZIyA;ea@2Y@IB}?3Z7BZUubv+2`NfJSA=1UbXk7t?u2SpYBC9 zSUr20uRrY9U%vVL<4g0X&c5l2{TS{||J}hW1G-3kvu9^Q>dtezm}M z*PN$|AC1|Y`238Q!2NQr<1DS>r-NVDnuzQK#_F#%!B^|fetaA_nwD-p@T>pdtnyxN z(p{~q6SZxP9`!itU5=M_%h9*Q?s#szkJYbEM|*0^+i+WOC{PE^`My~HM-I)sG#lwV z9^4!_>t`18aCiEj5cs}ZJ@#(}?k62uwzc$&eVY4xI2y&-Upm>c~%k}F3duK0lUcyKmIN27mZZ zmj3Yb`XFguiS^d}?@J%QxH%uFG4T=m=*9{8pN7vKeu}Yo&AR>cjAwphc)xl^4D9<1 zBkZr6dm!_CaZklYH~(H7klNGw9L9+l>9g;)fRxkbapbPK@;RVi4%lLo9vl(pr(h$H z7e1>sK8`w_#SNdF=hJS0D>~>KIr_SRqn=ee#F%ev@y$K-`zMWQO8-z`{?>pkd-=yN z_xf;PzOflQb7#OmabGG9y2tohGtFUrW^Y}*Y>)BYdl~UI7j%{j-$$1*vQ2gZajOL_ zKTZeYY_0QS>9g~X1cXid$5@||@%2G#z#CW{Vv=X#o$7q~kn5!``}sEo*5!!}vfRtA zHJ@XDBhJ%5e&8^&zNxv?5ESO3{* zob_Lv?$Q{iePgYDd;WeL|9iG?Sasi#HSrtMWiP$<9S(5!a6q0OjC1;8=y^Oi-*LIy z%N)O~O#vx~yXlMjx&Uv>dSKt#oj?rgK#u5=i&qEzx75bw>131r+XBL#d=NVA6(@e} z=Yx4;zc;WQOaY-wY@;suAHQ?ZPpbRj{oyJXhtlW2dRv~ubJzL6CoSQN`r*s{^LX?D zUu4|JSL5YAFh@H(TAk*sCi}&`NCG|G`OuLt{IO(`D zI31Au(cFcfao9K(@NwLezn*Z>-|yU>_t>vCyuWJUhQM20&iD^(wr2TAI_G@X=pfd5 zU(`L`)Nt!b9L|mPPKQ0tdJoEXYla_e9|^qa-x|eijBh&M)lJ_&969&xiJu;Jn?v@E z*_#6P=wH4AnOf!AdAjZ23myp60GodP@HUXv=Y#3f$NrK}=fr4@KC$!1S-$75%&lsD z^e@vZe(b{&sQ+U@&v!pxr+`eWUmuIDF*x&3z!$p6{Qy^am&NE zE%Jch-a$5SH3bA8*}nRH8aDV#)L(g3L)*a=*y{|RN&D=6dlsFypUo*C-J`!3R397H z1&0H&6O^yXM5Jfwf7`6z8{xC5Yw51;^CLQun}ef4$8th$52E6td-$)0yLwgD#EA!f zk#%SMw+q$zEdf5A(fTgcdm_fuf!OlbkKSW{&mYga^ZmXx{+|1kc_L1Fc7x`-Kf88( z+q{Qfb#K2MjC}KP|MT(vSHAJDP;c#Ds?D|w_k%94YRs*m{#s}1(f1m4vJ;dSy3PIB zHJm&(^J;Dih`8yN`@fmQm4^&3#KFepLX6!@2fyg#4;z1LwqZ=p1@gG8QFG0oH~sp6 zpM6uD-wnikB-jefiOrn*Yfe6ly>FvF^+2rQblqC>Ojp-ii_SfHnCBy%YT|rgpBn$f zfbh#)b%uru{&h{R{oc`w(q0buWgnrVy2aDj-7S9BpJ%5}>>us2jH8Vi&Zw`=fY>Xq z;$+7i!n>HosV2p~{Qb-qXO1q?x^3gM;$u9+BGWoqO4E=UNlBM^`^{=vtnA!J4zqj6ASI zj%F`k)Bv6RxrR-9aQN2zJY$`m&g06@IrduA64fy$RoJ-WHIaKbiiifG%*RZ{kM!gnpl2 zTS3?4lJwq-!#W#$c`!K0#`wANg6w-JV4EF&@` z^opU}neSZV!neKk%XboS@we9G6^`W&#k8@gQ$+Y@)|ExHBmcL|qc3RC|e2xv$9E)o!U~4Z} zcW3I`cxP_T-mea<;h=Rh-W7b(+q!wYyTX5QT^YzR8NUaQwck3&Z|nbt^yO1b&4IeH zcRT2tCs$&g0wNdcK`i`j%`G`H-#T<&?aL48-rkws1)NTSv;7>lhaG1wRr}8Nb4^@q z;&SBYjl&(F_gK(#I2iYS(wcifuQU8}-e;dP;`F}A177@pbn(~SubtL5pL$L$=$oU1 zuI*rXmc7ok27TU50edF`cJ#&3`#`5$;Sc}(_r3Z%qJ+(RgLensUTcIMwTHjvjZNaM z%F;^5+h-l?_P;cH_|i4!>Eef2`rY-W^p_CFa<1bnt>U9YJnjtH35>tBJo-n^XxDu)?j4=dC)4WJ z$69{Zx4mI~jEB!ZF`pZ4EPdzK3xbyi_XVF8{MCT3<*~e$PdRHnOzD&QbYuF?lDFsm zkuT@Bg7U!!Jk!Uwz7tdWWLo|DSZ$onn9eUB-ZMJ3gZei5s>a=mDIk0^UKbPo#B)VJ zUt?U>%#^jmftEDhbvmDub@5(G7kg7cE~TqF+yVYg0U6K8^|b+C@QE99PYcL6hX-QL z`(i9Fhv%_eG*9C?-Rs8A?FMW%2g|(T*WFn9j{|z^>(c*&e0^ViIdXt6IHmh!aBA+? zKlQG!Zf^?w8OK&yaf^3dy||;zQ+1jHG5ZYEAM^99jLF%c-+kod&cGSIJNLIkp6?m# zzCHM)0Kf7`oS0v}E&V>FM(DKPIXc8^K}6o<=k2J`KCVwgsqLB_HpxFImmCerhweD->f*4KSEFa zdFE{Lx>wUV#00b;@V31ZJp2qQ$VKGulw!sd5lr_0}M-J_!UFzM)T;F)yo(*cBo#TPlo|D0;z!~4S{I|7whuj}r+!5RroDaN7 z^5pYEeprB85FKPM9rbNpMj^lk?H_qO7g9XgK$&eYEG zY{#RH`?9|=(#QYS$hz_2tjp8gf!O$g+v-U7qW_jNUV&eHgzi6{K6_UNWGA2pNA{l$ zrhu@O)Lh6HyZq>WYyHePoxZXEU*2Wy%2n&7cI3-j=nNm4&yP!A-qnGccD8jg z&atuSV#dF;EUuLkI}|5$+In}hETNqcFnrMtSj z_S028&WLNQnP+5d-#UBazN6X0&i6#Q{o)iuKU+4_m&f~pa-g>O()!`c{lj{?tNLjT zdYivD2iU>Y6p(v@lfkKABal0BloxjW4AH;0|6A#QNT7u~=JpN4+*{{mD*bd@={!4N2{ZEjCzZ-p{ z51*DXc__fK_nJJi->m$@-FF4*?47YERy^DrygPVh;2p5fn3Utcp8i4bZgh=K{cE9a-@@j?HceKjUlLa#HbF zd!Hd6mw)!c9^P6LAC~^*fDiVO>Zty{C%0$K_o|0&ir|zi_w8j)%=U|i?!GJM(zo7x z@?Ra}0!P&)FWZ67GydEfs6W!T_=V~7&0DZMs~+v|-oxq3OUzxU1#`gH2Lk-p2A}1C z9x>Zj->fx{%Q*yuVE^qk+{d|AfMc^_(9uGkTS_U7P6vv+ylk7u55_AhI>wbFa_ zV>wSB-`*a4Qs8{1S2~vG?R#Dp#ffV^{P<<+XdF1?$9909>SUA7^0>5J-<|InIqDhb zAMeca?;|-Q*L>^QC+cU8Uf|+?i9-I#?Yjb>e^&-i57cvg_veFrH;0EigQXwp8pJ2w z-e3J&0{L}zFZiH9PSgzXS=W8++b6D_fDiVok#XLBwdeDQp6@u@i+eUhu? znM_@H*IM)DMm_8{&-mf5b$-1(t#xsi6Z5z=-+fol448)HvBwxRmS4)z3=y7 z-!bkFaOBN67ML@3Puc35G}e=QbZdYww&WAX?`>W699~X-7jO6B zv}&pPt9K)FV9mS!liBOsy}`Q!clO4BPdfp9?tkAMK0g%LXU}fX&#(K^?>&>Vz8UM@ zL3hi$*zZ8b{Lq#=I&kWZD!=Is3k*^FOyjsIcBm&39ARL4JB==kZ3%l}^XiLaci`|_?n z{&DuY2d%B~`-3;e{&K(MVJBc7A5|2`8fsZ>zjjx4H)YRA=i<-RFNR z-RfTaJtu#J{_)*#mM?Uv6|wWXwQ@Kb#Rz<9UrU^&^Yuv(8+7zO?55vb(Z`l^w*_=9 zd3#@CV;k4yr1qBaPT9i_+j02@XhlXI(t~j>@1A+{@n36(pnb30>pee*`+45?`~GXKS%L1;=Eu5y;=kNCt|g;7c3MmJ zc5B%Ut71KS?+I|$vvhjy<6fc5yD9s+x7=iC zrRR~<+J!3;;GOlPfi5<&z~W^@N*>3jrvI5$j^93@U!uIAZ_yZ z1kEM#r$FIz`DWj^ru?xDfAw>3+O=c3UXJVw#AeieL;Ce?N?T!Lb@Sy|;QX=!nm@h6 ztS9$m@K2Hho||lH9v@0O!>iA3l~s;#;GIRE9ghVH*>?u`Q}}u&Xk5hU*}?x8!HuE* z&kg-_FW9=7c4PBk+PE%9-l@u=&n|pG`Pa4;~4Oy)aPN?#{kBczr-t?fUYxtvwXT zS^LQz*Zlr@>|@banRuk1ysrzc3>3cZ3UFmkZk0Ff@;v5-z2uJXf8y}-iLYER*Zk@| zd27b1^P2o!-?9H0>7U5Fl0Q4T`kTMM5Lwk>-~PZE?LK2K$v(Aw>^NV(KI437EY1&Y zGM*aHXRUvqCnxmD`ug;(kt1F6@I2NvFHQgIc|O$@cg*wb=$@x#Y}C75o34H?=-%I$ z|9wpL{Yv^vn|?ZDqYeHaKJ|^fJ+s^!QVC9_=f z*44)Q=JCM9rR9rDFg?Yyepi)v>L7vd)VKOet; zJ^!DAEAsz%U?-dK{*nA*+vxv?(zl=duK9_@nje|hjQhTNvE~i)n#Ph$^5}l?Jl8RH z_48%{QkB0t8K1)c|Xz@GxdSFwom`I zxps%?e@;-D?E6#UFV%(IJd`%u@cjDNW)B_4=zhuUhxo|_^PU&#qjPPo{xjyfHh32> zNAKVHZ%>TVkEQ?AjFVa4j-^dbeR<~GzkRNslbSsFaB?B_g_k1K8^RvpUfDY<=DPA z&gwBy7%m|-?Mc4yzW_Z-7|z|@|NSL=kd+CzGtq_&h?At z`o6h-#aw$2Bk!TPe)C+vWv;(suHTya?tmYPcPX-P`r%v<-oM@_fl_e6-e1hP`-aUQ z2woS+zYMRqJ(l`-(A>kny||Z0`Clwt_`D&8M*@47`|i)!b%DFUUh@16f~TfF6Ob!z zII3;G6hUIQw9PrB%YDKIGVSBfKg}L8$35;#Ha$D|XKBzi&a-(V80Gx)OUU`i4sz)E z7nhj-k!ev`krx;J=r@V4Mvg6|5xKlpROj|Tr&@KeD* z4EXe~w$Yj4)%?HSVP4FYe~_4qUHksu!R`$4J0FOPT-}%YV8G6QlfE@$%nqfW;nkfi zm(I-d_U=u)GAqv*S-+ZjJS=6&DbI=8^_>elzv(jU{I$s5$x>q`>#8!>v?on;pm<~o~W-0?hE9ea({qJ=j}Hl^XS}9bCu(AS1id=ppPq5QnL*FE_ikLY72n_vbj!0X(<>OqFHRl|_)cy) z#e?r7x~~od^n2!Odlq-Eb3v|H;{MS<9LXZvIyx24@{vb2*yo*uT)x*n8}OT7WEeX$*QZj~ejG3D=Hs6a=&YVC+qeGR zpm&x}2woPveQxV-1kF2jb@OQol=`a8p8Bi4C*ae_vA7=z*!zNj|L24H-TW3)zuU|P zT=EPrbFB^Q^zsSUmx?ET%B4Ntr}2ZADX49@p@&aTR(5lwvT??5 zvX_2av(r6i?`F{bX|8NLpSn4Y^FsmodxGk)7v$b|&+XHx@jKp0_P!@@KHogI-;r85 zGoyR_-2Uo}fn0A}O~2e$0~vVjS?~GebMw`CJQP?@$ISs*;(aD?1`2EU1=cR(%`ao) z86IOkWlq6k?;!HoVlSO^-x%Of-~6?6yS}tP*4FE*+2Hv&-Z%R)#%AY(FY;<>Yxg%t z$GgVbLjjrY^K#9;=0Iy>{4O7C8SeseGPJFX+cUS_nsQKG%eA;A`&e*1aE{=fKx}&l zZlv9{-ZA(mCb%ho)*J}R%bB#rO6|ExmOVHJdAEP)zaVY4oDZHCC}gn%H*Mpajr6X2 zmUZ3Pc~5OHE}mqqd#?3ehz%zLXQjC|z6+VhMRRg|7rHXzFy6uLio^3b-TZlaKt3Nl zPwc@Rj@WopKtBEDR}NWY{`Np#S%VAqM9fMK9rpEJ$0hmJSgWwldSD0H=K?WtjyLBv zUtc@7$)Nk}T(f~ay>n}qG5N-hQ^9Co^NcLu?~l)I>&ZAX*Okwg@$S1h{m%|w8oVm_ z=HPn+^6a%9Du-Nr^F=K1={^6R)CYqpP-^qE>RlXftjQ;fY<#i9na3Yp@@r3UK9Dcw z*6Ee!`vS4!?-Y=&R;o|Ce5{kh{sRGj?h53UzId>63U=Ust3 z*lN9Etx{jtarnZ_9}Gs$*f<4Beb?Se&b^sm%3;S8D3zmTzasZ>shkep5Iif$k5pEF ztF}JdgZpE_@xXq4d3bBE5g7ZWe8xPUz5Wd@AI=A2bR^glSZkm1#wbx6tGqv)u^$gk zm`KV09`OmEdB1Z03_I@mlKh9)NEJd{qCSKlLI)B&;Kof zbsv3o3>&0jal=H!|k6SW5N1mVhP>|+IUuBUCjd}gf|MqkhZ+~Z-o#M>S?qh?(w+Djz zf{nnqG53c2P|gI)HOAKY)&1q|m09<}fV}?uReQ^`d3U*a@3A)q^z%m!O@ZQ!ts8$N z<2&)R&c;#4l>N#me_D-P{JqXg#emN{`OQD`qu<^U=w!Q?;r?gW#7yj#K3EIn^?rIZ zZ5;k`ARln&URHZ%zcVnuJ2)4}+ZPAy^4{bBhv00GyFXAmekyI_YK30$QM3O*KsKI~ z(}8)l=QiM=e*SL@KM!V(J^WOv*Enn#OyNuOV$`dxjCPHA<$h952RqsI`PAknqbcicG#ny0;PATFe-i^I$?pwPV*vIB`L%TAJ<3vtBB{&_Fb6l{wJosIe zeF3>*_1u8IGePeVce1nRdpUv0r}*}HVm}_)>dul+pOp>lKM)w70y5MJS>~re5!0IjV@vsT zDrbU^R|h$Cjr`z9-eBu1S6{by+m&|5t#MZN&-3iW0Y3SHg9CwaxIH)&@EPBujyKHx z*5p)P_dhFR_HHLbOo3cD6I6!0a^~6OUNJZ3(K0^mXW4~ZyDjZ~0UIh$pD+6EMDmwy zdDin{zBW|{P7em%yR5AnzXv+nAurw;xSQCaw9n4XK(2O9Y^LDKpyRkQUVGTrxEYuG zy^rPN=+Brp{2+JC56=ZKH;x}pAB>+4=uxx5_uLdV@N4wL)KV6{pt5ix|Kuhaqi^Z1 z_{ZU)fNc5TUVA*9ld0VUQ=lyUqk~O%2GwW1cd7jW-CKTc{p`j4xpzj}YCN5pVZCPu zJHh?jwwfMy7(3f$xAr>%vg9&(>Jd0S6)5f@YjAuto9sIn&~bYp#&XxV+`#p*;P~9u z=li?oK3RPq!@<*n{ed>UWI2zo3FM9EiI|Kw@ZmtvJ>n==M-FkycRb1&ZLrQh+#DbJ z){p1SIzGF9>$5#RS5?MNd)SC4d)U8j&vyE7*1dG&#y?(P@sa zxH}an)9UM%O}D4LFNlk)=MlYqPLUwYzzl_O72M~*mIj~6vLfCqNtZeKtj8R8^A#klt40r2vg*rSbq z@>-9%{skF-Tku1{F9aLeb9<2gR)F8Wb?|<$5y;uI+03Uifj#QxA^xo6i}A*o zZQAaJ)_fG(eF1ruRhxGDH^_95LvQQb)4nATkL~6UX0A4f!`Wa8lxg*K>#kzMI*xF& z9Zw@izm;|3T|RK3trpkvK@a=Y&6|B`Y`>ImOaDgSzAXFshQHA_zHFB>cVuo~uw6`U$=s##g-u0sd$jA` z%s-iYk<)W6x#iz(YB{E^VBQyc;9y>d5N(8gmxs&csffc+PHT zZ|CUv#LKi-Y}shfHQCcRj&`lfhkLS~uYO;8Begs@8+5-saObd9tZ-AG$2oeR8ojvY z`!W}e$-9x0%hBzOZ>PI+bpM{q(B1RNPvB$y^vqEBPwt^0B3I|T`&s+C0oAB3r$7ttf`n8qs>uhC{`%&HJ>uAsQ8RuJle0$pW1!Ac1 z@qA$X{y>cG3=RciI?5#L>jHe@PtC@z;S-;6M!xfKBCzhmd9I4bU4eB6g3&*^%vW#i zZA|z#+Cx81l=}OMRqx{Wtq!JtTfn~03%c%f+PJ1~{Qc1SLH86W^w6v9w2zNZW*^y4 zW*^_5%)Z@Ea-VoU8GYimZr`zt9}n;*XT*bTeV=e{nw2fRzB^;&?+K8x@g7`f z6Z^Ka313gfCOW4;c``QPV4Y3B9S1ft$0i){2S@xACvAL*E1U|fp8{oR%TBRsKB#XF z@I+SmZ!Jz@$hKXn_XX^_T>I>q0_9_|Puvd#?32^%qnBOAM!OovhcaHSYIBBGoSjbH z{FZOHB$FJ#B{@@|ENwL==bjz>-W-sg4Y52C*z0d0iBJ3QPoIwVzdC)o+kaX5?)Ucn zPM|aSN!!T(gv|5ZdgVJ7KQnzx`s|^TTshJ>s?Dj*tF2LYo%XGP{I>S5tct5$Ee?{kV7Md}iu%ZSaWJ~)$ zF|X-99RF~}Mh^bZ*fPf8d*{AAdxQE&4_l4f?|$Kf;vLA^yMj*+_b*TV1(Gl2>$j>W zoJDph?+6l-$8S%)KNxdH9$I%SI6k*it)6@Mmyg#3p0hr`eM%MsUvO|ZV2|AYTfr{{ z=AF^*r}s!uKPv0DGggrIyzE=znHf{qQF*USn{Kv?nNpemD(&LC+(51>M^g>_FK~i{w?hu`}TJaJ1zx#Hv%^CNe<%n zzMwHShv()eKiDh|ihXi;oIjWTc56oYS+K9Flpe!G9H|K1EVrpC2z3HZzAPmRsi`JHIx za3H?5*)XtWC!6I;^Ciud&A4HY{k4%CzKM6gCp6kv&e_1e>(g9tAeD<>K@Uz&OU48{nek| zz>8u`Kc+q59r@<;cLzAe3!X=Q?ct*}w*~yWbsPVz;h(eP+`K%%`Pko>`~0?sY;unT zY`YXU&&!%6__`d+&=YughJh43lp8t~W9zs%lyN>SxnZ;1v&R`waOauUwdLwF;*`5) z-TfdRoVAgk%i&AzPCjFsoW!x59BuPEH%r^hgP87{+jKRay%YOfFiyAgg%f>#=g%;% zxO(Osce=;BPfm$3`xSe;k4@%|2F^*(!f2bd`lD^Q(PyJPWD7rT40Z>`#ri-%pSx+a zolL*)U=EkJ&9<{~o$c=PrCe((N1L46XF2R!%E{Eq&ZV#J1>lE$y%Wg>W6l;It_$`C zWat}L>}3NV8|O4v@PwS{`f!?0D8T zcF-p;ra)=#jP}*0Lz&m6yLrJj_PQ%}1@cYo#E@OqlJBf}p4SKcYlA(3c<}4g+`l{Z z?m%Hr+vHm7%!`k+fOqBLt!kyu9(F2t!B@}Gi_!*TYBsXthTxfV|8r6+_PT?nKw0+r zX8yS*Q}pq{_wpk@_=Y2XYzFMx2o&S;Mj^j(C)d8Q&v(T-&ptV<`1|>CY|P<1(mxzj zk3G2GAKVwf6F#7rJJL*=iz z!M{U+nB%2q0>AQspJUFZyVCvM)a0_`Tjw_W_|Uq!@p%~ob0-H}H?(g~o31kf8_1Xf zMSkLmJ@r{GbX|R6i}q%K0~}T+-SvG+Tfr;2{1!WF6zkYA1xnY^FQ>?UO0X-i*7J=n za;&wN&E}e?OP;OkUb5`1k95>-a>Q+^gYU+ywU_PuKNKkE13LX&P_cGTa4>ivuvVWB z-b2jeR&I@)uv2La_`{wP0nu+5&WL#8$Qi;B+qRQGuCqoivBBP+ndY5&VDtCR?bE6G z+`75;l8gcU=GVa)!|#%Rcjp*8_VDpQu#BIz-H$hGjNuN)_#%r8Ht-kUTPNYZn{DnBC1wdYW(S;%oJZkz&2r z$scx*u`BRwGA9?z(aZlnU&>eI)qeN1J?v-GwE^8?hu=>P%vndK!cY3T#vGg0+0kd_ zD2okzW#1S#<8+-59u4?Mrh?~}qWI zNe}zf;!|DvZ0GA3hw5S1W}wub#;R+Y$F;>;y2J!Gdjp@L$;S=udzU+Jp1TUW-W-o`bDJEze9PSL{oM0{yY0@) zt21XEj>;3e>j(RLzv9K;9U<$HK%QHRzk>lA_5^sh1~2BdanEl&%XRDQD~HaLzV-Cr zxMQtv&)B|zP37{~+^=rj;Iy{U&9=?p!GMqUBIY2%-*VnmjGJ#)sN z4Ixl|j6V}=j33VUI-Br8-pB`eBOm%pK8)c*y^fFSWv94Lfl{B2rj1|4owX4d!-=+h z$HlnboI)n~eYR->J#DY6ugp9hcu>e;`{962Whwi{i~)IVFKhXwtdn;p3G0acxN!?*1OVIaB?mnlMj468<1zcd{NlpUC!O2u+@3Ov3wVQ z`AUYh^3$5exHWnE0($9?-(uD0IG^skgimZ-+WEB^Q|Kgj%s2gxzankFr^Gk7a{+5R zc756kJ{p7GarUyg+_`5IdiZaTHT+hLjpMkAn=3oD@z{GttuMFAOV`TLaV?&gYj?1u31ECranZITzpnhnoRAra&3* zY4ZwSF14omtW&B_KG4w|p3+v<>8VZT+vXenII9kMW4t=VpgQEv6e#vA&(x^bTHMm5 zJ?gsDzUGTP3LE7~ZM|^6Wx@Ty_hk+jHwW@v|7F3O=XRxb1N)ubzqRO#`#67N`qf2-yc<6k;A1(~_r=DF^WgThj|6NbODsBfP1oZG6ZXI>?~&1;NK__sPf@ z?ZzdU>}Hqe^EiJzee>+YUwv4Y5AGr0f7{Et&yMDd)jr}k1OnPcuYUmuMTfal)La^u~>-i+Tl&udEsn*dFJ3H!5-Nr8Rb7KeYWCL% z`o$)Di_J8J~S*6E90{I_#t4rx*P{yXZfbzO`opys&xP|5wvD zj{~_ja>yUH;=tUJM}ET5;HqGh`@@U=_oT1X*LS83^u2!p@iq3{fx@=t9{=e)5QvFb zi4PmC5hJ#YaS_KWgZfw-?1SJr~7I2lfE$qFP!_e{kiEY^`AVjukCeprdQnI+c`NBu#McxDrY;@ z_RA+6iJ{W{Vz6BtMw#~G=S)DJnBEb%r|}_|D_>jQT5Hd8?M)dYyXSiOJ+KEe_w0bL zVsKj^9_~zYJ`e8+=nx*R32NTOp4=^(aril>f?W{!f`xrq$Pr^6VM)TaPc_ z*Q`BL+RC*0dU3Dr(O_4Av$l_=eS98EwTjPEQtuD=CSL8k7yRz#t*OZXzu%)~hxJDS zb}r@OaoxLSuNUt+c91dpt53e~F=&2QK z>{sgB4QY?}i#2p9*6dxio@k%EH793l7hCXw3wE}i(pIL`*R7arq}}JhX4*UP<4kPF z55Idq%RzSS1o309*t6AsXN9djAD(@O0(p2K;G=o+ac7LLa(GXmkl}miWOhz|EB1=% z6e#1_ERT%|9>kiz&4DRxg&mb$y<*U3G9Bcpjmz8Kt?uaBBQ}jUeH+1Mpp6^F8hv&s zm0hl#HK0$;Ho9&M@Th-FpxDc9+|#8PW0Nt3K7IV13r1V4b*G*Pl>R>??n;|}@wg*c z%BPb&@6$L{=oxLPp3RK6O=jioPFumJI4bP%?Ab{+9?ReB(-w=KQTg>}Lae?V+6dO& z3vbDImR&eY^ftcd)3$#K6#RJJKR?(rLkxOX(21|+c<*a9Zg6P*crKdHW8TyM&Hx|1 z7v7b&B47E6GdXD=TktgcOqW<+8_?ae)mWP2o5JTY_J4l(`Gs+^d2} z+}{-7p)$*1?NYNzEvMA@7AyP3_tt=1a^4ue*l<3;1^ew=XWM4R8-KoE7my{Fo&vUY8eI<(2Bvww_-dYpmD;<^4q3w*RLg|L}7lXbwcpDwcQ=kH*HDa`t6u-yF!Nji8)4 zo67#c^TFBJGt}a;FA(d>`ogpoGCFqeYGjK8ys)YKI~y;Y=k1ZR?hN@NFTE#<$+rax zTgWx`fk18>vrfG6#y57dxo2K}jy{_ghv&u^TvbQc)xIl-Ic>U@XPZAKgU?B$``GAt zhEKfli;mv0Y}pKs2G({TKJa-iFz4K}^X|yDf6Ny?(2djj^Slg*<953E*L>m+u5m=p zBY~K*?RuanRb{*K9M_ zXFdPGzP6V&U)XRakPBli=JZX0GOfN|tmW0=0AFmk*B&)q)b1|8xBe6;)9UNRdR%uo zI>mB#P#t)0UgPG5Kxyt*|5*3#J&<*HITTzU=ud$%t-fx>ke^EZmUqqb&9uc?zKpq( z?nmA4xO&fgzsm<4@*Sg1?vAb1rL|uk~qH#_-v@<4D?k82#io z-rb$rjSGM5>)sP-llQA@?qmCLY`;9hGhO4DJedMzoY$}2qg}>t4akIlxOlD}$k_RS zT)Ld``fdGE7907Z$TxZ886ak4shz3Dlnh*49q?WGmBDxG=@tK_uF==}#y0w=Krv2- z!Zx}UypKBn<3cA}$zhv%T>Fc|TIXedP(RspOMoYL?v%#K)clwN#r-wI%ctR619rjB#P`}*{oBRo zomtN>_ki-)R<(+WXVl(+tghQL_q)y=sniy0%ZYmFi)W=WuHQ~Jo5&m2wta3GPxGVl zn7|9&(+Cb@C>pq*Fn>nzr?PdM@GPgVEGo?8*WlZT^ zjz{uO8BCd0U!QnS@5OH#%GlL;GcE- zgZinq)>%FfEc4(}ev6m$P}zsmmJiPBscp_{V?3VQEMNQV`r4ckeBy*`dX%%lIyrnF z@0b5P+%MwKN3w9!vzF$LdAYoM$DCycx$+QKidf5^)?*y;J;t05{KMDtx8W;OPssOm zdMdZ|WK&A>bkuWt2R)bTD-MhsIv%l{k z??{`PK6~V;b@v3GDQ5%vJzH={pS`%bCDYsLQ2zL)L5k64O}x;Z9KmESGf+0CEJ zvHj(ju$|BUvuv;3muvfdm$2R0+R65PnJ?r_+sisrJLb%2_tJKKMb3P2;H-?fbN>!L z$oWITb%DE!FYW5tv8cj@b;{Qc|EIr{s+HvYao>y8KH z^ZSK?av-R`tw-P9k$HZ0YQ4yeD(cvgdB~ zdp;it;@;|eYwoZ<>#QT2ooaiRcQ*U{{(&M_yu&;gh?6`%6SyzU^*QuV+WaQ(WWX;r zTjQBkpUvCfcL?&7hlA^ba%aq5p!av`eqxh6Sz@RAX(Q{!>cMUDB~!m6_HAd|GOxu| z!A&`5-$Ogt*L-TsN1or2y<^^{yNcJV45o~6SjIza3hx5iKNa{p;M%9=`i8XW#HB)x zn2H4dlM4A zftoMQ#jODv*!_F5Hr2}3j+1vs#y3;HDX?I9e%ZPln=+Nd9OpVFE7iNqt?*B1Q-NWpUS*zS_-@SSy*c03t^l!M3;cqd! z@8p9#_b%`g0sc25$QpmQSlJ&uZ`Hc^ykOUh=ds?KQ~GrFS<*ZlbK|%23xG=>$T}Ms z_u0rkI{AnL_X3%CApd6~!=BRt`{gB{&CC1m7<8CB7?5>;V4ZR%s0^PeE8qUNE%x7% zG5g)G=fVw+^rt}a+_G=<^96$pYYzl!Tzi&}_X?l(XZ>bsHXRP!SvLen1F@GIQN5Zk ze>bL2F28W5kd3=OTiLZYkZ*E?E?naUuhuqR<`lewakh|gEI1ypp?2V#ZR77gjK2Eb z1K@o0*Z#kg`;xx;i#z_ZlU-*6Hrm(tok^R2F9`6{HhFE6NuRtaPie0FG;ST=?heWs zjyHn($S1`*{y3-p4gGUcFJXQ;mZ8;NK0O%lhc5cr&R)D|v)6omH16}iy?nKjK0F%8kv)MNer*h}Zv6a;Pvzmjn%AvaL;jK@@uKH!AYNwz z-0QPne(`$>?8m!WVYA#)dKco8|LkYS>tn~s)W)YkVdJ@={?X(4k);>T%Q%nU<$V31 ze={KKm4Wkley-c^J#6koV2}5Y=9gF<2*|P5`ga6bvU;}S#rw>C0b9N(kYjkEgS-a< zF(OOfp5D1r+KSIz=IphO4()OL?dj9=FQc11a>O2O`Yy*V_Fu{_dZ$1c^?$5(*)I>8 ze>iY1l+!cBUR&L>sJ#Tcmt*zcd*y9`LYBO3&TXU(?BJI<{5OXWq%GF3N#e>)xuX9S zHl>)yIbC-K*4>bLyLC9~y1m=1lMn2Ps8#H=soM-{XPT??#+LDWis#dJ=GjEo^#NN> z2iD#d+!!1Q$gI3$X&(=8pqvT1Pwwk4b>SP2S0>BIlHYX7IUG)bLWlFI;PtUpYwN7= zi5|RHK3ni=Zk?RUmoIw)KDs+k2cwT#hv|Kt0f- zAD!E^VQI&h!*W`j$ict%pAD?({V%uQA1GvrhbN9_j&BQF zBFLkzJ2$jV*KTp!(s}V+);Up}WpNi@ZTj9ExQmuLtIPV@r_DY&bs|vy$Z+@aPmIYw z8#I6TyFb7m&dn*c!P%G$r0}Em(f3F&1xoLHXX36wubey>&@V3fcz7Tn`>H^^NB`Z; zY?MOOn{!)SpB+3B0<9n4EzHT^;{iK?&Rgd;{@6`7KGphS z;@N&6u>OX?UiR7Jyn`6KcdVoPP~bk$p9006Nh4)ieZA6=0fnu!VjThU2AM0XejIHBc@0@J}?C)9F zE*^X_huX~;&yAm zFM8ZpsaA9Jng!f)4yTQ) z<_!Psd9pbpu4Ia9?J%}KzzNw?posZKP~F{Y%$)JYJxtaH zbTNj5F%QTFV{I?%8#6}_yUWc}(4px?O|pPSbXHsHE? z)jdN8(%$abiEnl*qt52mX2u(n@lLc}4)z?14?EwNSnW#PSjn+*U*kCPNWMMex^yp` zm!9AEXRPN{+k23+_Bp|q2HzZ*cZa?qPVss9u2S3R?{mSP#`&JKad$Qlck8^5@r|zs zgDFth&A-Yd<8o!XqsX2DGPaYQsg-SV-FpvR+W6J3-L*4AE17C{n4H1K8^g!R)O?)+ z<>7#g^T8A-+i_7&)O2|_Q=bat&rbGRhf6ju`5_PI_!v3YcmJLUl(!_W#M8T~xr2eY zI3MeDvx#qX(!bQpp6z1oooJoR#u}$npvZxZV9Z@PPAB^x46J7lyXmYgIP5ulDDBD; zCw|p-pPj^9Z1}`B_D_K_t-fB&M_sX9+C;`9LG2^Y*lPlX&Bj{y+`TMgK&N^3t6|?< zJA-)O17C5~+*IR$+$m6|)z_`F=H59H;GJ!KPd%JA9u#}!iaTw8U=1B?kt4f;@jZmT zg8|NK2kx84d|BpC?bwq!^6cw=v9QP36e!c`>sFl1t@F?RQ7)UwU`NO6cjKR_6_0Ef zV|Y{g_^9u_-{r%t0q$`BuK9Uso%Q%?TpQEIvT+>iaV}d|wy=96C=UnH9^*u>(wxOL zyIvKT;~V?jVb)B6(s6CM_~{xcxP%u3bdz-=AmiW7cfs+r#hEQ+Lf8Dla9=ow)+p`} z`;5siKDi&?6eE|kNf4Y!iO&o#JGI4|H_Q99f$Jn~RLmhxTaOQuf`MhnFls{y3KIN_ORv`N3eF zz48_AS_5)BzMa3$9#qbk|wBOIa*nc=s*IxXw%k#)MPS|CS9N}B<^>y~~7hh_8StD=o z#aD6s@|nvsX_rsuv$p^K*><`VwvYB1V~_8Tdp_(B=)oDDH}dp1zJ%B=$J!t5CEM@Y z(0?STU0;!gx#efhrET=ozB|&!SNrs_xA7fqZVrq!Sz~`}XKLklHCcbVsiInS*ly>pPS(8Zo5cRT&g;K8h?bBycz^P!4ewa?!}7-RDN zi~hH#PX^BHVe6O9V{9b5KKzNu-t~)*KkkltYc3?8hm=wNUtIjI=wsgUTd zkDJkl=VqSH`f&3sqkX@BN~V2sR&LnuZo}uRv;Y6j2cu8=r;k7WMZsgipA9|~$cf7N z$p6@q)BaDVKl<{K{7&H5|LcqXUre7J?hl{y$zk`mXWZD{K>hTfbN9`2a=3brXN)gm z(Dmy5L3!cVKaTx-Qrl~O-&`L^-F0&4v;NuE&tQ6IS<4Ugp}Cf)^yA|n{P!(CDwD!uU?~dFvAG!EN&-voGk_)w8ed|IEMN`u*ef|6KaGX#d;NA9Lnw7W2P< zp06$0dc_U@V$0vk_`=1WGi&zj%O2~M>lf=kabDl~U(GkfMw|X#`lHQ%BmJjFPWAtl z^zqPhiklyt$Bw0K?wNu0^6r~5H_E>{{ZamJ|Jx_de{j+N(MA7U`u5i*I!?}Go(tpI zrk6d}%(Z#_-eaKN1e(o*YV-iS=WBLSG+rYzIadI%h{mue)X*9 zsq@@4*UwK~8SMP_$VheJIcY!t|62ZNfw);qxALp>=MOosxiMrX-OCvEKExB5p1pf# zndRc~$QpC<-!J+fNx$;ldG+nD&*N-Z=Fl={nk%)({mkA+W_jd)!z{1&SNS|Ouf2D! zn}@wGd!L=3=ie~bZ<_0UbA4d0eQu?@@BD9_`)`};N9VeFPtSdEweNKS+vr!E7dqY7 zZ%gjHJoUFAC4~-LC}#qG8pD@j?Dk-PAV=t$0_B=u>>o{E4v2f(X|CGFjs?d9Z6MpT z$-6h%`vdPk&SR}a9?V^QaTGJW zSffw=D^~TcE8KHzR2#RqaivEw#{bHl(pHSIVKeZYRd5OTn*v2&jwM7Z9de8=xkcBy z{f}gPyFGY#cJP&P{A6k}ra%#s%HB1%*@6%C(*t&hrTjTG_peTUEEsbRN3xWhuMEgN z8_;imbA*57?g{WACf?P=$Q_~2M*M%q+&5o7*Tv~z=IO1yY{mD1pzF!hx5iyK%Hx+@ z80XoxVUm+7Kh98 zWG^|tH_+zOk^|f{-&)J1jX+*J8sYYjF|R(d*nl6l;*jn1Xs^>{od4tZ4UKh=Jn_B5 z8&WTU-{n~QnObqcPO_#z8GXXRW*{coat^nT2KNWX6m~cN_#$ zak7p+dXLU+b_1Ku$)$C1&F}@j*yUbk&;Ecsb|{^bQ|4;(n3H0;Q{SG5U)j|BUT0G| z#hpFuz@fqpccsD(`Hpk3@=Pc9Q-bD`n$2ow`$WLbZ_W1&D$AZ*0=kX`#{;nf92&3x z^w29;9}K*6kc;2SGuF7W<(0ut2K=yJF+K(I#{IF52X>dwhtd{XXX9i*Ct2)k&ao4} zWWp3E)9UNie!eU2W6vKlYWK})v-^R7t>h_kNP9aw*@dfe#|GTo8Sp_|s-xWSADjm| z+2OrMoI8eNHrc-!xI3mmIUg9G0!5#F^tcb6pL$<_FTU`bY<{?t8V9kT=6>}r?>;f$ z)8)p1PPUHrPU$O0gE0o>41av&$0KvCU4QycVyxUvX)Dv}>(;YEUMOOQ`|fAU;ea2? znV|W@-!Tv5#eo2Cd|?~To;$b69KY9!Q+I9u-4Pq;*%jD#YoMGCtR-OV!yFGlZjM1K>8Q%zSQ(N(HS0G36^+53PoEy5G z8#&1zF_PosGsBrW7&I4g+!&{MA*Q_(#9bi^r~8BE20eT+CmyE)<>9UBLVZvAjoWSW zoPE`MUE1UtYc6>18e4+S<=74LnD?UQB-#C$9d3Pok-vCRs(<;sGQSx#Ufw(8V{?da z>&C`&CY$J~mVH$9}wK$%?ne)P2+OG*^00rha=C;^vh>pJ{v2Ca>dvGwnA8uL_!n zI8?~^s>q<{P(aUtKz!t?{+U3|p9&N)6B9D{%GT3?wdC9t^tn>|@wPu`oa~`nE;Pq# z+tuN0cgEdeYPdC^^Y70!U3&w1*+I|I?87Vjx6@1Cc6!ON-~3l^!%3!A_x(Cf%$1wp z4f~u&ajkFc#c9t0E^yg6;3NO7&PUhWo4(>a$`hqFlP8|We; z<}N2j{8?wST(8ZepWCgkkJ+}0DL)l4RT|shjeK;*`6{=>fbY$-a($^>6dQb6Kfa%l zW4tjqnl@jR(KmfD>^rvS(!oG(oDIl?j-OB4ob_y@_wE4iikQeZdkzO|P^=qu^p3eJ z<9ye5XUe~&40oNvPP)kwCuhQ5I?9u0EIs7OH}6f({dW0gKb_U>T+y?SOshlr?-|qdDv3uUZ^V z1Z4i5{0zH$aCR`*6*LcPI~n9PN64|?c;mze?@iVHaj%4!XW39rhjy%(GXV6nS}LU_HOA|JpU{JtxSU0=zWG+4PQieSg0WU*@eV zw|HX1cn|S!8M~3UU70U$pO*G^ypdropZGzi9N^ETa*v&OQ{4YOlg$mX`CU7kN888TV=CPzd3K***%^b|K`ovFaNvmP}=qx=hN~& zVcRS6yD44Y`$S&K0sQtIi#~EHZ@fdCTjP!2-n46Dnk(ISeKfc~V5@Q_crtegf5}rj z4?dTEN9uK;YaBm3_fxH8)Xp2y$0Z-#M{f*jFYay%oJ)F}A5+>2Ud`Pb>WJ!?~uDzjWxAQ)6sWdq2XFLT)+Hwx;$b%`V(IIKMLZ z;@~F&HaN471$e^eW`O_7;Uhi9mv-RnMS(J&{pMiT<3pav33uMtg~XGo>6ikg?~ii0 zvB1xR!H>)}uK6GaxM4pT^xPHn^KH+~>oP_U`z!O&w8fFWy#YBrlRJG@tu9=N_dNmI z>}8XCqBh9`Hti&@HsWJD8*jB;W+Oh?XswvoM<&is z1Uxg%F`Ne51>xzuwnOIAMemkmb)IksIK-;=q`pf>j28pnFJ*~jnG0XysW zcHcLk_l?1$!F_?gSoe&aPy6iwU*)~pJR9gBe+m@3jf=VZ4FS3K_3YuwKJmfpPC2)c zdA!=w`u4OB2Fp12PNb(idC#}@cRJ2&znnO44z}#O>V7ld`*NH+G|!D= z$1-M*7%RR1&ZcdQee66PoDat5L)$n!5h#BpzZ)vH<#~MmotuBRw06rccHb2!?0zH= zYclAS7mW#f$n9AiYw@J()&Mv5e>lIFDi7IBR&{BMCs}M~4?Vcl=WBHtAANXwe5f32 z4+IJw_*QU8Ti{v`*)_R7#GtTiz%+3VMI}9hr@%y4c={-%x zcF$}w*;QWH$u>p2aMv9Cjr?A5xgt}H_*34;cJty;=C5C@y*K^Z%Wt?nI2f?Ma;zI| z!&7amz4}0&_|nTKc8~e>-of_f3m@vw?zG7 z8-aY^3~J zzF2S0*c2$^{@UtX(OWy@pxh$!YXdxgL7;Ta-n8ve$j50vFVTNFV4HOc8I|30MP|q3 zD1FwwA?UMM-YPE$#GriO1|Mewob#ozCadT4`yT)3bIPXPX}t@`x;IedQSBo8NMJp_ z$2oh(&+vtH z=00p=iaqbiBu>XYhtjv?s-W__51;n^q088JHtUw>sB$v3lJkv`BZrpy>E07mKb_x{ zwI8d0-+UQ%;%{l!AHKxC=K7<_b$K`D|C=%3Ydn9t<~!##8yR!{zbk!b)LQz#JN=#fJC-%Qk2cfxJjazb zPP`+GF>8#Umbrt0e%Fb?$g{or9Xp!#M(|+3#!RoC56<+NfXvEbJNZ6u*>`2oxinX~ zbvkvQLvl?ar_YSWj8CUbru4Io`o@4x^UfDu|4GggJ$D82>`1`oB~SL<8{8TAJgj&Y z8ruw>9`H}!^cw>97#BOfbqzo0yp)_QS@BkT+4a-0m)t2(a7FKE@5tTqUBe#S;qC3g zeSsWS*!8YeYfC0Mjp1w4wy*waPl3`kqYaxGFK622VSn2CjqR9gZ_Ic(W7EOl{IGUU z+V(5muMc8-I*9gS=7XH=dVX)td&HB@E9ZWFNOxubl$x#N zjPK~R8Bd1;a>|)pB!A?r`DKpn_Xq5=&OKrLTu{!;)!x%-+pnfquI=PomOLRw`bPtM z6rAx{sb9wUQQPaE^KET;9&^PQE*0|aRl2wN%5L}MD*`_gAoFs853#BI&9se8LF3}C za!;~IfhJYR8_nO#yAb2RKe0P_8wa5D2QS7ze{QDAYJ{}5;li}V{*oK!= zIw=otRjayok;AS#0{8wOkGxMw{mS4c1G&LBzIOa?rv0YiRl#TzTiNs{wy_B>e3px& zO+91e^F>avi!Xd)Lqx7VQ`fip($D+l4d-lF$D6hMXil(Yf6#o!^B9wuvC8|NmvmRL zVT)25#HKQxZ8DWJLGw~f$-6$V{(R6q;$+VhC|x_+$~J4p=fqOB^&Qj3vole7;`==@ zz8vD|dxw6x&+vsc?CkpO+LzkLKe0a%i0l8GyA#j)IQd}uV&DE>PT%|4o?+~V=CP|Y zW)2@}eA~AXym(&Ye4C@!9Gy33&R%`xH}mfRtg+S@JN`w+thsgWr@G=u{ur8?tfgLk z`Ke~VT8^p3SuMB8V*}aWlz(6T6Z!essN<9J^VLjUu;a((zioiCQMNlw|Au+3Jp6{N zy(V?-XuZx3dvBWedbXU%-mVu9^93E_db&Q8-+?F(_LbW|xcHk155=FxfIf2MqI${G zvX3w8*2UR4y>|!fQ1~h5?+U&zMtXkzKSA@~nUS9_Pk`+|9o!$-C+6ndoz6(tejx2< z%zfMf9i69(eMbVk*ekw0+k7S0y2HVNz}e~9O!LB?V`(1`*urM(@17qyr1PFYe&C00HaJUccjx^;WXYq^-b3k=Mdv6l-3zfN zvw47ja*e4yFUd6iu0YwnRjv4o%2iz0V2`?c@N3@PzRXiLDb>rT2Ld_FR_Bx~IXVT( z^4>RQ4Lj+=k+ZAhM-Z$3A7Sr!_Os9YuHfe~-@bi6wzx;XKYe?wH~)F_dR$b-bLKUb zL+;*;U6WdF^21!)&Ud+!$L5`-9}G$I`L~{#FDZPgKaCmLAhzDcoQM4Z8?9G6Ti*RX zC-oBSSdO*7kvTS#L;m>h6v!2u%J27lpPsRvMS1zIKylBJ*Y^#!-jV)+dCd6j!7Txq z3cXhccvb#tIAjNItT_^xcP9T-xRUF}r$Bi)F!w{-%xz|_youl80GG=7pmXSFC)sie zCw%9txbah4?sm+&w)t^)V6Ec)N`4;<=p*Z~Krwbx5R)(54g9@1V1sjD@47XgKCfXP zuuFXDb4Ki6-Vf{S5(Cdmw(Z12WtS)XvtJqcslSzL9w+#$jrbx@%|`R1ZS3dwkpPd) ze`gRXPp<0_pL{rX#b{O%%s zr(b)os1ps=Os%_OqkD#;lb-<8*dk?I^e2s{qI4 zgwEd+PWbwQV0YkLka2u&^OugJ0lO5rYh8J&O>~lP51IUL-+I2>6LijgHrYSsa=BvX z!GK-P^|#J#>)mS)2ITIUYx>zf-op>2?-}9Fb^iEl4;haJe|4$*oO)5(mjgUor?8g{ z^2eX!^ZzpgMGiQZY;8X9!PyjZ?b_G;Qj;xyJLPbF6gN4*Uu`vgazUHTl_&0saXd92 z#FL$k$GSd_H|I6hHiyO99Dj}m8-Zsp8+wP{l6H0D$GE~q>(~d{fRp7j2-k}EYm;F= zALM`{r`UCSa5$ioO~w>Dn&)Kf4aOYDl{{;X-;lQaU6e|mtIbv9-Aqw;-> z{WCL9Z*3DB&s%!ghg zFs|;L_^?l*d(ub|4?HRSYJ85ReLTP^h?N*^JzuX`cH_gmSa^2Sc5A2L%3z)SY*T8# z*vkhx%TGB-IM&K|O2(DSz=8dIaQ<=5SNxFA_Y;Bgmf_u_>+sFqa=^EB_H1N)olms~ z2lTP4XOa#+^NoDZL~GdBGkAU4+uaxTv#mBZ7N3@}Q-R|CQq;YR`F?+34IbG)D2Ha@Ea|G*>Zxduq1GVP!c_p1pDcmuzgluZscycFITceWpB-dVkQE z&~t4dZ}7!;^RU)NXMuA5+@OwEDWWruQHn>>`_;)!j2(Jvd^Y z_;gG>_dEq{1o5ElF#QN5NU2^K@*8ID(>aO4XqOUp8xRP}u;KQ#(j`fW{y==9I z4~;)r2LgWDcPX36yFD0ls4{T9v=xWImfFe2jo^K;v3AH$b{Mzb_-m4IxUVkxeQfUY zgFk#}jMmxCC+{NSfpfCUJwNDVSLgZH{=I3lhaUE?TQ7$4cI3H!9?ba7^Bg&BmLqIX z+e^0f;vX`1{}~&kA3*I58q^(!`EA~Sq|~ZI-H&g$i6!uTj{$6ISM`+S9{q< zKKsb^efG+=r|ZX<@)ghcHeVT2+6sTn;q=PjXn=FY`f{PRmY!PzdldGtTaF(IHUhbD zJRlF~+&{O;BxCD&boGim{25c@jjTh#XU_fSq*m-LA9Rg&cATCucgJ;XeX{G^lj1hY z8|^ufIk6ajA7Q8U;;D=_RrY4a#bLvO6nbzYuiTmL=&J(7etaDc=(i8&ihW~$xwdOA z#^Y(Le-GvT44e`5?ZJ=C_@dP3f;R#efZ?Z zhlckz&v(3y{^P}Z{^M&Y>k~6(efh=-7<)=EzGJ*GeLBsPxj(S3?+R=aQ?@C8da#Wi zI_?OXe`GhN>|)=j@AK1Fs&Bb(_tx|UPIj87w;YTz%j25|TiLMWk#D1nk;mG%lz(6L zxD(C=<9f12{+g?2GrpY;dw`FgCofBl|Mvt+hMu5jGyPHLm=o;1Enx4i;9Ov>*ed45 zt9Q^d(*|R0ud6eCVJ|y8D* z#&@mf#P}{jM47cV`Yd_RT}PW9#ZH zTlv^~_(=MEP|gPI6HA}p6*kKY>udiy?r+Ha=DhBcQ{zyM|<=>9ZU?=WoY^Ot-DPkqlNmp#Uu`BQ=7bGoA53@TSX9uC-bEI1x) z%)n#UxiiI#&W?-a-gz8v#>o~7`^=Mz_bE{L)j0A+F1Q2z3|5Q^dfMKu&XU!6<%9L) zO@U&J9aEs_%a20=o9JzBoKG94*6d`r{8#8{%)N)+6!7UxV6JlBv9WdcpUoKV?D0Nh zK2s~(%P;QnBz|loi{ET>SL_Sejbl2*TbWj0FP_Wh&aRBhIW~6>9~&pWlW|?(`AIgN z+vQAi!#*JMm4RFqQ~Jg=>8|W-zVQ8o!Ib=O10LU>x?HmXKWyW>!nPX&zOS>3J~m8& z!Umk$W86O6@#j#$KQXF}_Va^IG1S+#RvX7a7TgomUOEm0*7I*%&u%_!XEz)9Pug##o)%M1KezDUhi?8fiXXl=bE9T!3*h9~epyzQp$49o|VG5Mq|7_y7 zVxIlR$aN3u&RcUDC*6B8 z?Sp}0jTmh=k57D**HMPpTou%xG*^Dg@dpF8^-kzr;Cry-vHhXIbLfVEO=Oj;b!QaM z{IRa~oJw1Hc&mEC_hCm~zu}e(wOWtNs-?}zK7yjLl_uz6aukprKcJPO+ z|DU-#fwuHI%LDDITarqcB-qi2jdX9_s!~;5c~DuFEe827YLFE$lPy^T7B*KlRSba+ z4j>VR#7ZCu$zrjx0xY`ewbEVz(l`m3Xb5v08)!&Ehaq$mOacicBpo1uK+?heKBvxm zwe|a)TO}>R%3gYF?|<)af8YBJd;jO28f5=mw|imKeK^l}guCdiO07_dG~ssYzFMX{egX-9FW29fuL*Z z1J5S|eB`_NaL=)4-+py@A?xbpd{FMqU(Z+XnEN7wkEVVmgR~O?ZW=wF#a$bp={*%# z1GTAU-@JH!>Eho{d0EDPCwPDGE5UCD9~a@z3%)VyX6bgi}!f1@KG)3>Fiz7dKk~?_&urh=AeA&5U+!=P8VBxvOCLhTwT~u18T|| zKIHH>J`-r}C-QRKdqZ7*+clT#;b_L>@uyEyC+^GoWxYO48GFC(u`bF`r**!XMD z!G?MpZRGJ;Hlk{AE^wIwtsGY6PmZmpY!>(ZiS%*ls_y%U?Hf<)z4z6I9O5nxa=|v9 z@*(cxdLUTE^H}EjrqR_L>D9#D%YHjOJLiMSoX%L@$eFX&yO3QR=rpGu4hHKuxZ`(& z-VyflgC4jT;3CgzMl9`luJ1K`_)+fc&EH+tM=osQqVcgDk7aEBKp@s*%<$V@&Rs~~ z*mbYFs{Yw4hPaLKF=wCk#+#aZ(YXUZn`EJ~^ zNuGXju5D7dR|*!^|OBK<&;lHmp#53|LiY^(;3&#`S0b9K7Pc~$5Dn)axur8uXQ!k zI&AGtnbW4lub1P{JTx}d)%dk0J@eCEJlDmr=ZL@j=085w+nAawKe-lLJP!~3t1`YV zII`@Gfey7m_TT02%*Y2@Y>c&2ecf|s)(->+gFlje#(ctsj_p7^e13a%VBMIlRds>4 zePYBGAIKgGzHZ5j|8W0uzC2Im*_dy)2lm=mJ@y#$6~Er+n;Da9?7TPm^QJ&N@c!RZ z$lmGrO@Zbeh$mhBj4F?Gv1P6C%WzSn{mgwl&uonK`G)vcd3N|AmN@fEFE(O-bFdwl zZw|!vmSqlb;y)d9@vS=ee=cYa&t$Civl33VO9xqYTdVZl7w}V~hp)#1@|r#DiG#hT z16=5SB%niG)5+)O^Yf|r@k>w7I-jz%@U5Sh*cKmlSN(k1`r{X$#MwQ@A2#GcT^NsN z*!sG-kk|f4kIVUR6r0vFpBiVm-7n6&S#M0`b}P^>1)YCo#_B*0*lLaF)uq^~kumnp zvYg04HzQBTE)qF^RjAxV}z&uy#uer?{H)_ zG2yfLwjP=fx_i;>sJ7q|Ulw2H5}=fXGQ zA5y3Iiu*dgt7>4C9T34_+09Y zuGZa!jPY&_cU~UFSIt^q7wgs`|I14~+V9yJ|IWY}H^;WQw*;El^L5pqJ>!!-<+M&t zo_r4a$UuDRPh;Y934YswJk-~78E*xG@d4V&5+ zk15YL1?-9qJGTX7opa55N7L7)=hh%Q&LJJnx!(R&^)_W*qbD>Mygx0ydu;yw2%Y?| zPknb}YN1O%aq>OPk7e9k^|{Ht8&_&NH2O`iE}PVcN-$$vSL zH+7~}AKhZpT9KD4={gXZ=7!Fn4(M0UKfD~Ph1T7?rsci$GM>THnLiTXWWU-tx*U^h zTyDr%tjOT|=HNgo^6~V(yVd`GfX{pZ9DKk0ap^~>E6-vkK7Q`g$oumFccq_$PxHAx z)5C8uVwY^=pckVr+{iC!V##K6Ze6{|i@j5z$;AV~ZeYDNE4OM*uKBv^`QtNxD6kKg z=7@gw)zXUs`Eob0O}<>zp*zBU=>B^$-VS=-93R#)+^e77H|{*KVV6Jp`l9ds>b|-= z&$yXq|GogHTLN>9?QI$3dnV9U-Az3Q`i%ew_NPEIPq)~Kk4ER|00*}CKi@-7&jIfC z@~OS^Acp0h;j=zh_k7#yzFYShweMMStImC6$zC}do5$Neyv*@y3dC?7FXutChYmi- z`TQQ;?>@%4T==Q3{Qj0W(Y z*!$O?!(P5Lr|o;^zcXti`0jbkC2r?~c`k3r99}mE_`07~?!y9wd$<)%+NExJH>f7s0}*hQ|sKZjOTM| z(H!0KqgUfTr{MmUtAzR)?YCYpW*)aGz^Posi(Pfmxz^x3Uai-NJ}dUljHV{oz+eAR zz}Jny8vXNl$>(bVf9_nf@2S9EF;EZRk$S*IPO9fy4_uZ#lDP~Q{P|cPUXk&3Kz^(f z_O!~?S270!wIx36{;k+uSBGSA!WWFilD(e$vF_ck_=`1L+;wlC2yiN&3>W&&rXTNa z^6KDxFa>PM8GCfIc_z@t&q|)@x;}U$5L5QZv+0iZIYJ!!9=R!Fev{+d$i=gGJ16$h zb0rRqKig#W7nZ#|ySozVJzI@Mb0fBLVlThh#c2whn^kc>mU(-`4Og*m{j7`E7^g3a zeB;zRq4C0ByheZOmow`#2fqq>I?iyx{aprWa&~)w+o1r5RsPF88?Cd88Q&f7aWk;j z8cvnHC*!}Jz|wa#kSn~``D4HQlJ}WaPF8Vgo$H$$yy@5T>84;+UbZqno;A7m^FB`A zSLMLhRe7qcykALne$K>5Os-VdbYD$fM{MD*T!@=J<-C*e!Qh|d52K2qca8J99rP^n zmp?fDon@ZppPA&>`rlo#K4o6(xy5^(e{4Px^k;_hlq+q#Gsg2OpK>wQdTab;nI9pp zp0(CR`_^jhijVr55+8AE-HB7rSNEzjJjQ&BW!LeuJ_YLOzCf-u_MEL_0UPf1zZb*e z#Lg6G^`9R3Y~ACgX6wKCKe}=G9x}fhnDaeLzqi5-r`AL7D`&61o?njbmGjN?+d=J= z16%a5RZimUIZJ!C)rmQ4bo2Fez-H@>9&(=XASX7}D<(L!o?bGnWw_9JHhteqbQ}oi zX)dOW?HhB|oS(_O)>!LXYj}ZJjeBv%5!j~VmSDdeyHDwPP4Ikw_I8Jg%es4z?{bWv zyX)3q9j9xurr}R-^I|Md;#XVqT%XLEyw2@?Wajp>r_R4KhF8@&ou>l1gE7yq%Cnlm zRV_N}{S5ksj6u#iUf1tN<_|0(XWEHiV=;QBMr()v^S^uOEaT_=UkZGeAm+Wp?C~>O zV-=qAk4EOkKx~|?>w_ua z$9>B_-JVW9PbSi)#jlrpd`I~cc@`7#Z#`wWsAcz-wiV#77Uaw4c8w46I0c#<&;1x} z(LrX^G42^pf-tZROb^F5w0JXyOS?@$LI0j{Q({y z2sG!j=MUdiKd0_y-kRL>U9acEUBQuH)n0nXy@&HG9~!&Wc`W13)A`~+oZ71w<2wU! zj!Q52i}^E<#`K6GTX@)aE~w9|c+usq>(AcK!&8B{*f*}xTb^=@C;jAmPuV~Equ$B! zg)Dn~mxJ-Vj38nDlKqr-Wi*BV~d^k5wivD#ijd`<*-jI!=ld+5Wj=V;`% zO5a9gpANJ`!CXIm&a`>|-Z~xP$%eb*?C2sWKaZ_NO4xo2_{&CjWV2?leh$~L^h@*Af=I@UanPX#=pYp7A&HYP< z&u`8$U3exed+$Sb#B?)gjNMb0f_@gpYd7c_X}r8oaN`TT_IuB42U>Zk`%}Tj5_~-z z;-1e2^Ycu9dDdp%3zdI!Wcu0dZ5e|a>Udqh8=2~?A7U_{<9}n`o}XeNr}qW?)w)-$ zZ3SvbP0xK$liPtNFOxxo0fQ(uuq$7!Q_t*KdtrdDwJE??{KeIIITL7) z1#b`V6@yjl&aE}MAtx7&PtSweWPd+B^0yH*k2ub2L7njFiNHG4KX&Oq6u2v#@tr`N ze|h;1;3pr{p1x0|YnUkGp% z4{}>U_q|&H()eQUPQbVSEkCcY*?mVcwom*z=NZPcLl0i&-V(4smv>KC$Cp0ietz@J zPyQL>}T%>m+>G&m%Ge<>&~8BsWUwrM+0`r zh!1&rxGy*qX!YySjQRGl0iVPPAM#HI@^V+emOX0ax%ly5L1@W0!@zipf?o8sF>VR>mL>;;7+*)4IBPckcey75jM0 z<3E`Bi32~ibvoIQGw(iiD?eX0=*OeEKcDfLK;x(QHNS7ncwK&9pEZ6zz3lH!FJI2H zJ?{-~@whj*J-}IB)d@LqA@>hg$cfu#!2kDUoj=~GV&6Je!}N%|IkE8EzCKNv)9A4N zKp-C8F=E4C|9`A8_HxSh``6gs%^ExEpndJ_S3Bn;-*ciDJ59`Ra~7QyI_0^2bx)bo zYNLBbU7@_tW&bFLYu`oe^n93W{N$fa`f7X1Seq8VKJ&Rp3_mikN3D65H_vjzzGu3v z$rBFsf67>#J9{Z8vqsB3b`!JUDRy<5w^Ii&N>0B_u0n!kJbn)Kt(kz)Az z05`sNFCJs8U;qs~>Y> zd@}!zbNv-l9N!%HGw6ROz4wp)_X9DrcaN0E_~%W{T|1!hc~j>8Y~alQXbOp6e1XRU z_kvuhv2o9z$TQ!`TmPcr+1`7C|8vl{O4q^2uzx9_%lVMk(OzZVnt2?5EIQ?f?D;?q zjQ3#II1u!Z+`n{Tm+f_M zH?LcJzVlJJ;L&(LlxG|@@!%t$EyPOtppMeq3gVEpUcPR6*%mE5%+tj~X6jZdRK zwQH|deaDt#e&VR^Mtj!nxhCLW_o-v^&Cz&1rp&W-U(md$NnE?f7`orOyJ9epX;-8 z{kA0c=JdGH$L9R+u8Aqvth-OtjM}shFZY%@s6Mjg-m_Of`DVXb?0aCWJ9^as|H$H{ zH!qLdfu;t;P{WHHy?U{84xKad^f|BA@bpaQ`GBl_7lYHmW^gDlPo9i(WnXz)Yb?%W z%->Z$9LqdgTDg_0JM@bJd)W|UbDtk*ADbVNX@Y`oB4W&cJn1zNe_*KzyP znL8SYgSqC({)YlS8sjQ=>JfSdri``bj}5YTJQ9e38mC)MYPV-gza8|mm%Uxfa1m2; zea|?bhXeNLVyE)GV;Woin*;aCE$It2(($_fKxE`?3cN$uvQIvpV?K$q=5t=-$EIBP z>@o$n2K`Jj-y_xs199C5G`gAty4Y(>#r(Cw_jBAAaQNY<%=nun~-V`Nx-Ifq0d>__kKr!?Aae{;uF? zAZC2k$dK(BqF3Im^99NWN6&ma9c%_{^MO43wMS?9>(}w8PvbWo_~_+;J@Gcjruc}P zKc}v32Xfz7s$a3}IdZ;wZ_Q=!EX33Mc_-k{JM#TZxzOLc=Wxbs$UP3YoDJ+1C;OfG zpGoY^fw;LNH-lwL7N76Q&+Bkq{^`9^EO6onzu4ug9?!W?ygY|OStchap>HALZ0s`?Jumh}`cb z+;>;f$Da!UKIemS=7X3{fpa)=Cu3ggIiP3NJQ;c$n`0S+c&n%R_bk_DPF^ZM-ivah zhUHa$js)V@d3%lP3mr!Tbwt))G7ki+Y+D~~AI`HpYVM<*#VFrh=Pao+IyLcA52K&% z0DEy!17d^Q7)S3eanRVlCZNZdk7{c>AVY_>DbRX$d)L@Ia+f>yF9xp*G-saKIVG4z>8ocXI3#DyL@$jbd|2U)i9uIxh@+pn1uOR->^erNrL^!Cs@ z@~RCnxMi?G2R<7CU7m5#K5T`Y{pF#inh$%+v;O13N1W?_hKqP!O8;a)7oFm6Ki`Di(~IJy89lxBjalV?QAgDA-;U8AH6SE-EWP?*I-QLm9!+92OjZQY`6wj|6 zbe8{k*UF9DjXrh_XAn$*}&;s z;10lT3N(9vK4io|?aXVq>pnMGXY&`Lw{fUXV!n}%URSv}iuU}cSUR(d>3hV#&3hTeR&$_(Jck`Ix!modqJ?s3+(t`KD-$(Bl zd+~pBu#umlod-EN9lSnJuTKPjEO{@_=G+foc49Xt|zR`ACIasPkU@NZuJ!xh$lZN>VL=%xGD z_gVXm6>Dmr-Oyc`kN=oG>+<1Dt=spXp69;byo!D2W7oMk7vQ$4j(#h8+_CfXfwOmj zGpzYDO?354`*TZlR(I=jD|1H!v7)2&G~Qd9{bPX z-g{xZe=@yi$LH(O?uS1QyFQ2Bu(XS>JNEKzI+WYMlyjz#Qvtmu{ z@yXu*vd_9$oeM^P{T-7RX0G{>6EPM?zE~UMFX!&f{~9|lO24Wu_&?@F-ZcCEzwE2N z=HzJRiH!B|CE+Drt1 zR-K`kTAZQkW&c2AuVlZrBff~~!R*;Drqw^+xA7eJ)t^IGu}_`Vo_+YqW#=+naK9$H zR>daM9}=5uGkK-hh~aftki(7K;mDO&{a5(b zV$adY(!Jll8?UfWeQH0MFK)!D_4>X%<9IG8S1}aR(eBASp9=8a4aCInW#L7(bKjf^ z_p~{(?n>`LHFhzukBnH7(fs^itWM=cbABpo4Scq@PqW^f)3=@H*71pqH-d7Olkyum zo2LVCXl}-Rk1W^4etxdmm1nje4QjW%Gqv#lZ2EqGARgMe!1tG8)%fFZCeR)Wd|$xE zf%Nu`dfYjhI9Q`^3h1i7=16^ydh@u@Uq9)G>MH;K-i`fi>-(9f_Y6g9tW}p>;Qdaj|P0=%dLTU;PK@_ z&$oHJ*co}8$TOXqHL-p?cyB<@yMkkZ9FzNsW$))y^9jkb=GjogY7D25I}V2fGUe9z zm)EG%9J?bQ_J1KYfZNvuVs=g7_Yv`XQ{e8?oEz^9@GgdN+_|yudi(Af_4A?62Qwah z#>HIYWKFEZ!`eI^{9hLjIh@CXjxiqc^BI9Sm5bVtgF6EHJAY|5Kj$Kr>$s@#ITy7% z=W;4@zVp&>dwC$1TDgv#@N8`6aocb0?(Cyy-CpbJ??|9l&IQi)+f1gZEjhF<&S!%u z(42`?wd;;p7oQhrZ5|)zY>dxW<@uF?TxowM_~^j7P`8a6xt#z%O)dRYYF<6dzj?a# zo{i_RtN&wsa5pa=i&G}rP zxj7&8dTmfXqrFuzC3_@TS5tCf{c3B9@9TUpKlefGMju)m_&}R^L$q; zYNq!jx$${Cr)1{xbX1-l{8rW3)znkA?%k2MWh`D>LE~zUe($g4kzJe-@z>;+3{K)r z_DW~?mZjX6r>D2N=#hsp)_%|I@!-7yPJH^n@ZK5EV&nN;k?y>-K+1@YaBR^0lqEKI*9bZe<+NRiDPr(>O=w zBZ9jEGOc~JJeQl-Hodn5&Oy)HlNs~-aPXR-?>aJU91n0C{d|3%y?@NF;yB-{*4=TR zAJi_sFAcOODOlald-?t#jk#q$Evl6t=+e=&l=lv zdvl&-P7vit>;@ee`$y#9`iV=X-yp21o>gR zJmt~df&1v==!-F#12Y+QP(5^#8*7KHlfkI~Kke?o@9DSRTQhpG(ep!3zu5Hb+?g>M zcK&d_pL;C$rr`U7UkhH5@AW@1VAomld9=MbXCF_k`sF|jo@);3mzeAZ^g{1K>+0s7 z;HF$G_oe5LRvEchgYq)!qw_7n4+R&4%J+V~+Bv@WEcxur-iwxS7g@vUdzN*CKN!SH?u4nWapAIh8|3cQx zy*ju#3hDJc1)9AY8|L5TA+7q(W&B|9#y~tTET2C)J)O5ir#zT%EYvLjaFo{r0X_8d zfgJAD^~#L3a%fGom$Oy+-3Rpf9>UoE)`WfvG%+kk^@&?^Azz;BFV6D8w_D@es(6jE z_V4$M*SLN(&*GtW8f*91!QlQte#Kj@?*@&5ID)g*JAlmZ9VhXZyGzUQlwOkueEeGoa**BM^Q{$6Z@o9`_{jsL0>5oj}=s6nDe#*Z5)&TXgc-^ECmP>x1TS{Jz>ed7m4;V&k$M{dHGeSuI4`!I z@n{|oXAJT%_Gj{}i4C6oCR0vP|AId?)D@ZSz`Z5s_MHplnoaxN?bR`!hZC76&mX_H zpn0AQ(yW_qZk8g?sx@}`J^mS!K4*Fn&#}fXW^M}T8tZFSZQ{-ca>bd9wQ2F|Gd-^I zw;S-`SRfDOF4xw^JeyczAtz3tob+d`R5(kdLVDkdvYs1xbx{|)7p41 zsR1&0@=N_~2id-;ktw~VX3qw4%>IGkn+N;Ny&m7gLG_-?n0{+?h~<3&u9|p}Z+z(9 z4RE2uv;93c^;y2f$r_tIGko$)e>t#yCeYZkb~W~Xuk`cbVjvIVF$J1uG2v71LU%r2 z-0O`2A3>gX0`1?-;@^GN=&Zd5Or-JqU@-d4hPXCf?DY;&5AHT`I~>e&M%SwS_VKZ2 z#(w_H_lwEM#WUXgw7;>bzScD^TY>yv{ychc@p)?_&ubzaPECJ?j>3~y>};*Y187@XZjO)J{<6m zj_xZz{m7~BqfGDV!o}WIe5cH7?6_wR24X)2nt6B9Zor@3AM<<7KA+{qT`bvZU9*2A zcr@^t@utB0lV16jlYVCR%vXMjapUOs{^>pwXpdd)7JWZ6TBoZuWPE+F6KMZeZva`!6)V0&Ir~$fwO;83F~r-r zu_Vt|y|ZuLdrcjgSKn$y6Bj!9)BVklvw$NRdW_|iz50ru=jNJCa_0HP=8xw4k8+@^ zd6tXKK%>99>oYx#6TQ{v--@li#);kwOC9Ia+slvg>zU5f;*L@$bRG`qXfA7Wp3jq! zITaiTG~D007(G*K;=rD@w+9;mznUW)$uuwgHRg-YS#lsY_J2&kmi3-xIiu6Q)4}n8 zPWJ>G)|)5u#@pdB72jjibwM_5DzxL?R=n)_1!2LdtO{Si8Z;TxI!v}Gh0&QCS zdigFCe||Ow_HG4ZTsrr7=6@s*pF>MHuLlD<@WoRc*74kLoesLi*ZAxb`|UXq8TMNr zxO!%vAM(<%7=ZZQ8L&bAvvZFcTT_ejdVNrx)&QS*oN!$=FIGPslwXF=y1W1FaCbWk zY~tcG$bLHCmvuVvDL?++6ySmXPGJ4t4>oSd^N~P&)%k9~&b*fFtB)BjVkmxeizWS2 zpiPTkFUR+RK zo*TLKJonenXg&k*yK%1`XF$Wpn*CGII`WLie(&<;i2m9r_x;|vFOU2jVlfjC&dEpqIQ|AwSEUkLCKclp{1n!k$~%gYpKe=wMW!@>BD!Si4+#(!@A_7(Qa z2S*&}XLCP0{ND}SQyO`Dr$D2#aXynVUgp#ty~mbw=@y^4oKR1Z> zY1PBe>ghTk_FEr$tlH17{r1b%e(Pee-@5u(wVvs{SXzI#f=g2en%weD6Z87HPHwCL z^|`sGKCNwKt$DmY&pUzkYq?8T&3_>Cqufu-p8x#p`HN=HkK|b#+2O})X6wJ6&sy}~ zxm-{8f?xPY&-{K?_q``_>aHBeu{g^GSvmj4$a?N)w9bFt(w1lKjd`}0oO`))$20G_ zobdkA{4jDjy?Q1OmH+nq{!ckr_j%oVb&p)kdk5;(zTUf|w(NOrf?STjoj=G^J^I@G zrR6-`<@Cag>2sHmQ&xXFa^}rBZ`MaXmHP{kt1iA*kG}irm%GsXt%3dG^6Km#>*ROx z8=m-97nyas=tx<<;4fy+Jg?To{|#AtVfsE#%jfzk?!@Pq&5Uw-g|_vcH| zcjt?-AIpcuAI*okf0cji{ulqlv*Yxu`OOeIT0hOL+z8HSbM?L4TEjj! z&{tpkY>)ZMw{NXi&gTkpotF>KFI)DFF`nkzpUBwz+p}iB_t?F`kre-%(!VN+@}6aT z-S;+XYkY6fCtuFN*?`~flkri0cxN>qw&gW-wJQ{Q@!#xg9 zW-K0R$)4@RT@AB41)9%s*0S^=`^br%x;DlGxA|x8Og-!8RnOzuEVn81+rh&DUVPHX zPC^&W9`;@c?8TXnY&thMIp6kc)jutsF7q7u7y~)^*$K2W5Aki&yM5Cb~J=DP;j>Xg^H&aa=zZAGRwy3hS)-{S!t>egp@cG#Z+OCxR~tzB%~2!9NUsHTa$2x+uf_#2VWvxyAkeDUp+_uL#&@=VbPX%@~i?CY`7D z(P@3>3hQ@XVf|(MtmAk#!1LviTgP*hd&O1Cz49vL+)d*0^9f+Y_kL#ToSMV!t}Lp@ zF@{I;Ebi(RzjFcp_2+cLK8)A25NU7qpgNBOgf6Wtju^mqTxZ2#?7xu1XTJ${`FR^?)h!PUk^ zJaFf)?`H7DT^?VZSiCsB_>J-4mpqCSo88ZE&E9*mxAEw`VjmIlUbpWx&v9QUFYLYc z3j1!1T=UA$#)n_t(>@y?59sT?gsZz%?(ogW7aDVWNJ~`3O1&s;anwXN+ zn?3ITx*k3N=|Hq15-0{`^^yO~xyqj_LnReI3jSqSkuz4{MgKy4e zewmvBt^4lGn0?KkrJ%EW)PX(L<^A5|!P<5vGF*H%WCO&DjoKOC*&~m`k)cy-%#2S2 z!u3dSYrtQzw%2D5c70!}Z3pa}4c4u958rXO=h1*2{?x||_j2}R#t$u@&9m<_DYMSz z`2goLf#x%lWA9S|+txoT5PN&q`Mfc#RnDF%(8STapHa7$&wOkx z;Ce0~!_Sc;KIM2gV;nVg+3|^t<@RK7DmbtNU2HdAc#3m#(ipR6Pwl7$x~;Q6=Kt+^ z?wP@Po_~63^UE1bW0P+G4y-eTm-zBmqvvx2K746l?Yh9b_M>w_&?jDx2k#54tC@EM zYMs7STr$1)eI#3xi8S$w+C{yI#T01f4+V|m!HgdX#KC+&7mUAO@Mz}6>xO`D^x})t z7&oC%r-uXip2say&-$5^%?p9vXI{4&9Y8-m^oaxC=KAD8Ov+`-SmWcoR(3Pj8lhM2 zJ2&1lbY2R?tnwM|<=0umSH3R>ttURysddh?u|0gSN5hYga{n<2re}6F{+tcS?*!U! z4fhD!#{>H{^5%MO#lo16Q=ri=&nJUZ0b5{ixqec{_|m2J==rRGo}Q)JnCGGXtkT~- z^i6?QKE^oEcPv=Pan#{{aWB|&G{8?i&TX?tH}2xe&-u^Tnc7?H=Z|$f#(ez7EFVXr z=VHJHJ!)Sp8(aK5?+$a1;f&cn5a8mx+3Wew4SR7AAM5mtoc{PASMGen z9Y=cEvA^-CKD8n?>Y#QX81$8M<*Ki7ufBD1&DmVe{OH5&gH3tF)w;ZTSI_0ITOp4_ zf4Ax(Tk_&2Lm}ZN3QD` z?#Z+HSpgeroE#2k0`0Njrr><=bfA${I~M})K4Uid#cuhuudezMk%gU0>7NYvLBC#p z&Cl;LwQ@MnaKu|3>34&R!F=Cl=5TG!$TqL`czoTuR?s?|F8o zZw5H2C$Vy7@5{tJ>FJ#UO+EH=K3RYMQe#7WoGJSF&h|S8fB4BC`^ahQ_Pu${J~^y? zWAX00srN0rHxB#Rx+CD1rdC>4=C*<{wzuY)4sq0QY;46yGsoVsK>W*zZ~WBQAv3Rk z^1H!_KnP6hk{`^1tBecz{QdLyu3J&3b>(_!BFHG%I*I&bZ23?ct3pQ za{L9$-ub2nr*pxjzBeW28ROed_Xt7{}i)nPz^|XgHx^@HcrsI*I zca7Z9N0-mDxQVy@_XqZp!B0HqJ-#~uxsM&rZ$Ah1j6It5+P^1bXRB))*Iey{u3;DA%bNgbw8}P|K%|7Qw zkKg=EU6Z*d0=mxy4+Qgi$65TvW0W^f{+8fs^z)TGe$LFv;8Z~8jR75ff8)8|vs%De zPSpbWI|H$y@0SuE^+ZN}>D9@q-u=88s26+5jC#e~+P4q2bbX$W2V^zpPo=7%jU{%| z^A#uli9es3H~i=z-&lwXkfXc#_Bj+MIWpfkc_*2#PUl^&%!|p>bxamIv) z{(A#{Z3mAAK6iL8S9gYc_MXhR{=7Ql*TpHi@R|axG0^v(l@DiB&EYSey}xms0&SdE z6Q_gCAR$=jI+(s3`NekQ%E$5}zZ>v{O>N|JAkSh{u(KUB9^!aB;Fm@>p17-{#^x0n z+t3B_e|qNGW2d_G>QEi9BPQ48zM$hmKwjQH zA<+2KT9G69Q3GoF#Q}X}I@b4&aUT9io;L%$nvYvEZd};qGab!|_cZ-v#@~D7lf23W zAI=2Ysyect&Zh~aH7?@C9}QQvPp*7=KE&Z%AcyL!KALC$Xh0`l>7=JQz!B`{i@kc! zbe#|WWZ<*&{}PZLWB-@)tl7t2x%D$}=X+0nWn|`HXFk{GEG@V+?#-__^21(vWq15c zC0>n%wR;0?D-e_UT=RK%)>=38k2S-;iviv0tG<4G#+$*RKs{~;bht;WgY0Vwq}flG zzFe#w$g{nbxFh6|eNc}Z0X<@Qf1sY{wb{E({htWP zuDg${;Y@dHZJpkTENZ{)_hZaW$Cd;I&oYUz$ZjOw4 z8}RF6f;$6sqJ4ATL*(qmZ!4gSZqMT6tU1GY<1B~onSIulXEDQ*9ePGPXII#vbCmhS zrA%$BCHG3tdhLtN+t%3U3;X=**~95VAU4i`+MLhPsj+Q;b9`=1j;mXY?7>ystQ8 zgT5Qs?OKM5x@YIfK)uMZMxXO`O(36g;~bs|w8t)Yd%bmb$&C3he`z_-?)c|qdT;j} z`_721s|A1gBmVYic=JO{y2b~MpJdIqrtPyw9Ie;C#yC@p`QG_t#E7qaQ&VHy#EgD- z-~9pG^SIrTxlxbY(^DG{WIWo(Z&eKK5mR@%7<%p*oif(w!AGO#V(?Tj&f`+sBd>M- zMf~^7Kkt_F*FKvMyZk6$@tfCQ*nQQ$vPU?3j;M?CA z?wqkM=qIE7l@&5{jQ7ydh2&+Q`Pt9C^D`_qboX7*_paK?0L>VGmwbAPJmlfkI~H(=xOfE_Yytdgnz zS7rT3(B~U6W>4JYO7AnScjHaz=TH;#xjw7cw`qXT+5w3xU}9HE6?Qh<>21F zC(ql#qXEAT2i=q5UMza=+N+%l_$4N_rB==a+IaucEC0Iz-M%-=e|z!rUb_%Qa%izje8JJnM9fK3}{1JI&Sc zFP4A*S6(~!-Lt><`?c}CadJlKd|@DFwLkZtK5}IAl`~f7_G|p1(|LJ)>e;*IQ+z;3 za~Ja@(+hw2q@4)lMDy9?bTGd=t%I|#j>n&KtEc)sySI-A+I)}w_{otwP@CH|cQz0w z{b+M5&lpVux6jwi`i&LOr5RW zfGjyZIX=7FaOqtphvisbtsM)*QyV#$lSl1p@`nrHIt7}2^vr!dn>jT^*5`ru1rG)I z@wxkqSLw_2UcNpx^GyD)f^{I6% zrsLgXuUIrT#(;yGXw8u0&!J#0+x+p>JELcs4*rZf@M(P9{-g(1UT+QKD-f}&Dmq30BH1FJ329E^h@d3K* zYy8<2qelaK+UZyDbVm?yL`%nj6LkL!#+Os zogAC^Zw5H8^YvubPA%78lU{8#r)otLql*E%^SWhAojRj_26`Z5$@qMS+g3307GIzb zN8B2x?z=a0o5LFUuBq?sV66GBW%@(vUJUrd7j@oR@sajSpslKTyyz8={I`g0pT+WQ zFa?^pfEu_fz>h3H#LhDw=YpO~^0j{=V>xav@YTe~_eOM$cSU1PmwkMy+^X*Y@TbF? zRt`PKo;Cc$N#5}D>^)hYW1L2=_=*P~$M@yC^8B@dHu_%vK{Q7*i z?oJzXt44Yj*KzLM)Lf_mzB@^i(FQ|a^krYh{eOp_a&a{L~WaA zmk;WI9Zg-cqqRQ9IN5(!K!+H!ZO@@VBYQExnV;hspjY0koemmjJm@VC+~{=ncLREy z13B3m=6qL3rt9k4I^WgbAIU+xFMYXHjxBQTGW(sw2ZGxJ95;gAbLx#h_8y5oXLmE8 zv-7we&NH2wxLD@{T{j1OW2bd)-ui(6?^DaM`@H|YJ1*?{JA>rur(0`3EuNmaOK?*Io17 zyfk0)ynezJ^2+D#ZOz=8IdNH+Yk7S>xo(|I*?%x-&YgAo_}-k$L37^q3&VPbd+TFO zG)a3PnI%l8Ha@#wycL>fMpIeUY>%4LO<|F?$gTsLu zQwQQq_mSYCz&sv38_hBO{ObSzojiZ5LwwAsGh;rto~DeoY4PjjH8S?Ht={OrFHl>W z_!~Dq#^NGA#_Tj!YL`CoIUnp76aHO(k6!+FW4|rWua6_26MShL|N7v=HlB%5<63{j zR9@(b*q$x6+2u=r#@fsn=kCGN9vpif?V(#wPEXgRKM??8Y`9s<*MhhfZs_(53kfUhVYrp1iTO9pFJ$?QI2O ziw}Rr3&^;e$6gIjL31ExV#5!7HiO1YZQzQRHL*AoX#L#cXFT%s;RcoAQ)>+ewp$nF zXRh&W9O?SC{GNfc^jpCcXx4FQ-P?z|oZ+CI2>47d?$*V&+v*M*{H_SFLB6 z@AEV4J?7uKaPQJ-9}c?#S?|p2(r*Qi1aw$ur}oK>@3TkqES@h5sw2ZaKc39E`8F?> zd^2}LpqcZ0O)%!D>$n2ntc#@>kZ;}|%Xr*7*R_##ZIr`z9uGc`@sJbo(8QrW9?RIg z8ontYH=arH@~md;^UUwoQf2M6##cV6m(75_?wR*w)RA-G-0|&!HMOUP#0v*|*q_%P zJ!9?R#xL=tdzB7;oegm7S)iv}`C@)EP*dv2o;l`R_%?DG?;rNcjc#(}%Yl9Vu~8n) z*T-gVGq@&b9_Ui%e=Wd~erw(t2l7eb8`A%N!k?+t_|SVm?`-f5NA-#4#h`xkar{hg zUe4?LJsEEY_IFObso&A({@J-t$^6yeRgv2bs#8wrWM6D?#CHnhs&cqhPOds%o|)Rq zYuDX5bhz*6@4P#!`^NL{d}{m?LovmtwqB93nBX_YakSHYdNOj*{iDr;nSWD&pYLuy zFlTs&@+Rc+go}^;eA@%=~uH{Hn+O z@=I2uOAa0iZVEJWp5=Eu16>yf==)Rb_%0T!>SEL}*SV2B+E_RE;Lw=!8JxG)n>GG@ z!J+(;wiSp`^Qc}HF-g6UyLY+HZ!&Dmd;9reUfk)x@A{$UraWt8$K1=symriuwbQ!L zw=VGzOTC(^eKj@uB5r>#e|BT6eY(kvJzi6w&DZ)o=gFpq$BDq%)%YjQaxn#3*LO2+ zec3PmWbN^@V%P4;_>N$irp0>Kj%WT@AWtWQQ-OE`Em3JJ*z5JX4ZCd<#`96?~lfkLLp534^ zy)NUeKt6u2zVjUGfdBMs&U5XW134x?1qT9gCpQHepX|BP_oL1R*~*XKfAU`r+!N#d zJLOrM7QbGOm6{o2g_EBT+;9o`0&=CD2o45haAunwHH5Q2-^oXKD6o$#4yS|T!8m9C z6lml6$j2Hv{?fzVnE;RSsk}NjU;b~7ai||pXHDZX*>`zJdqZUG8*Pj}9m(2OAXlsW zwD*aicQ4=H7?_{SKbW~s4AdbxIWp!Kn|gO9e(d1{-eG3~&7G;vfDU(5pR30n`}^!p ze>`}9V2`u*>fn=;5OU)h9$I-c{&Nm;Y3(HeKfUj+Prn`5tGPqE|6<1V!Dq0Iz|RUl z9N_XP*?&)Z_NPGOt9R2^E&JQk^Hq)0J?4pBxiZf`eq9LISFbo84V*!8<<+|KjyM!( z{fyZ6-HFWM#^=Vh?>ax%;zSR-&3XCYh=+Z6;D`V7;Uiw+rio2?vN7ho9MmnSJGsFV zR;}Z2jU2A~Tet1&+kUwf1F?EK(2U(1 z&NWPdHZ6X=e69{=OlDr^?BYbH`1V;ZCTe&Jv}y6{<@?#$xhAmgoVdHh%zV!jUgF_1 z9{cYKG_u;+fQ()|=)vXO67xGojp0dFF6kvZmt%_!dD;oI&tHCakW(?(UiQs1+iGtL zv=c$nwYZDkxXfGcMQaC^Yj0Yv@xl80g05${_x`~b=zJm=W$aZ?56;3Cg z=Ocj}TodpQx851!cU+HVzPhV3Qw!VnJQ?sG7wudiE^^;GpVvl~_I}PFZ|}vRK91il zPMOzmz`H((E#RPjFMr0kc9Dnot;2rR>sX3efSr&FT0(S6qC-7mFt+=q5$7LtL z?^}kS5!mKm^Wv_-p?Q7za(&Jb2N0jz0yVQ8$g#cm2HI9Y_k8ZD%&C!^0vzY-tM>2{ zk268hpZg%U)s+N{@ahYMz;FIOMErtLt(%1=_UuHUBT_^mAVI<*~s&UG&i1Tp!GM3N-Po zoq2ycYexgV%cajN^WPtgsg*x3s~I)Vcl>dqzxKx7dGp?2XEU(Jx_#m!?_}n->EB(h zc_;93E6~*I&SDgq<$IkCIXV)E!MQ*kkUJ2(Zg~H*PmZ2D1MAuik*Q60vW6S`?oi{t zKh?sg$7bW6$3+|_gS2V!>oe!Fcl{S905@c9JCMKX$BBPpE1vunp9_K5;yRAa(J7Cc z0lK5U#>?4bWB&8FJZSPDZfrjku=DERE%A+hajf6?h?{1gb$xv}nK3=(dnRMK@XRN= z*aCM<_Gq^SxE~AH(d@@hjO3Qj>W3cw&im7u+YHFrH|F~N`M$a}Pd`0A3<{)dmvSi*K;3FRM z+&q!F@qJIOaq(_y48+8D_I$;`9e}gX1me#3?rSW@xy`I!6Zotme)h7p8+2d${r0PS zevlPUV=Fhc^@Ve!C<6)m%)Ti-hcl+o1HZrG;a*bR0ik19Kfo7gxt9}pa zaOQUcvH0%%{aSMBTI{w1@sdyRB@1%cGu*Rl{dBMy2p>-5=DD;_9MqUKay|3*H4fvM zr+YVOZgAQf=6p_9r{+e!^s&`g&->F^+YHDxMs)FUoqlmS7vPU0f7Hc(`^R^dIExEC z`ug-~8ME1EHQ||!lcIJ}KPNNhr*ldFT(33$i}!`#bYKo2KGv@c_jH=ahp*cCz`i-hRddhy{>*ps z>VM8_uFJmPYk$l8x%exdrvkZv`vZ9w6Y-NPdex#jao3y;@b_%Y5BHVEwzb~%mGgbV zcA#$PX#I7b96PnE4$0C-|NQf)+-t3i;~A6n8Dji>Nb8=Rd0fY{fulWV0?nB_5b%{O zPUN2oyjR499&%dWG0rA`$d2{J2lMvwB{UYjdAf1)x%TGt+ku*_U?)$_6Ef67>!7QbHpZbp7Je#@`M2A<}` zT{Cw&kOTVI#z#K|+O+ufneUz4C66chV&MOksP$}}$k-H_&xj12({A7^E{?8wJ=G|ycocS)tTLGUdcQ|A5a~AFi z-WHznWPbGJXr8@q+5P?G^O;w{r|~-&Zkn9q?^$d{U&Zs9Ku&g}yX#}ly8cAg_si+q z_gRnnMLgdT8F3$Dc}Jd;qP_1E#S_@tS&n~g`0mJ=Iv&__W1t4)>a(JI&cC|(cX1zn z)-NsBAJ6#xfw-}y(f`?5FYilvJ|485KPPJ^@{IS$>2ou`AE(dD`hGF}qgPn}{C(D2 z2aTt5bRf6gE$KG{clG_jgTY&Z&kddmzB>5J!MlUM75rTA?}BTi=$7C_@JYc#!CQl; zg0Bv~G5D51EWcn4FFCXRKdo3ll6m>oekA!8`#yhfo_jZq=XEPGM+17Ja!>x-A}{W( zpKn_3KbN`v_J{tWo_a>aO78zyly_gx#%PyMU%0}j=`-DeaV)^zAt*7`@Z;j?)#GGx$nuV*yo;>=jK(ME(UTn1)BBA zAWh6CgS5u;x{T%F;4mk~&A0c5XYY;fX%3zWNAHJzo)~MRI-2_r}B%VQ1t?kF%y;R>iZtvb@mq z<=-dj} zkV|&O9S1i4WNch1pJc0#E&Kjd_BHHh39WnQ!9o%}t4eej8a#!e_Nn)kQ+ z%epb{_8O}-J{ptn&vs(Ue?Lc%*XZQu=(k*mUHAGfl)t!($7aBWc<>1aaTw$MGkM?5 z<2FS`V{;=IZQ?*rZC%Qkt)l^3eEq$UZ{BccZwjw8+EYZnO)=C0`WFYGR#t@ZPS-aD;aozcx8?(hA+i+b-mUbXRL#$w1H z&0cHu<))0q%-$p6&(4`Z!(FQna-h}DEg6g1!vPyOlkqOPG3YrQ^@#=Epe}G>-`IX< z&{$0E=ew~vwNBQYSem29Gd=3aSg!bKtp50FOrN;l7m(M~vf4ZuoC?HF;}1RjsgCaF z|Ell(DvJkM94aeT>Z#}9x{S%xugZzfD2H3+_&Unnk!LX}clLq5xbs!d27hZ??5b1D z8-H;&wqG9X*LzkMp2gAr#+u&7nk}-8J9)7-uZi`cVB~8aKQb`#ye`k>$X`I$eLIUL|jz$bQa6)$?sYpc#YzvwNGt>yUM^myY$ zhMkuL);+5cwc;#Y7ie=mWYzqEfE)95Hb*;To~vFyUP&*R=c<>FYK0FE2mBOQ^ZF_9 z{ky!Zi#1tsYivI?WBSz3$oZ4=d?aW*`{&}-8oT<9z`mV;UVo2Cov0^q8`nNQYpoak z6!hG#(Rc->w9*tTh4cX-xKoI{d$l` zJ%8J~hdgV}K0DsoU!CB1R)3!V?C_k&MGm@tGS8<1aRzy#lV9|et6cO>#k*YP!97a8 zyvceNKV0c4f3Z2goaZ-tWW-8sTnyBW-*2~H-Rv&s+zE7XR(#?^zD zI`iz@k@ei%_wJ#ud)T3i&L;!)Xbu-#*@P?IGyL({L9-w4oxsn-M-n`7WJ7Glfz8TK z8Eezx*UQ|x=YhVPiJLio^SSdUmh+zFO3e6!H#wjCn@@A%*S#;#m~45G=exL!=ce)PKI`_$ zYv)#Rc0bL1yLCAyuW}$K^vQ$XyQ4bq$=H6+d~>$8gVvvMWi$Mc`nx%E8v(uiUgt-B z#pg`W+UmI$zbn-(f5d}q_s@M9xo<{pKknioU%2z5vaiaxu@?_~eDlbQ+>+DThlMRzgf&_YUE0YOj; z6a|IKp$J&2D4?RSty@5FqoRO-ihvdc#RH0aoBjK~>-kOYJbBk4q3qp1_Vvkc-KXom z&iDO1>z$Rg@I4fJTf2?_SZiZloQ+&{p>Au#i_({uaZhu7UFOBQala;g@#x;xF?+8b z=EZ6=NcpeMyj+MSJ~gAIqjL7EjT;BvbRSe3o0)5T-DA7eM(u37AKzF%{O&z}kou87 z_W^%fLrb5>8oEAwjYql<@{t_!THpKmsm}1K#i;(s@8~POuBH1RU&%u1lq^1+52irM?eQYvsZ_3!TUuIa;ye3ti6(%!@O9d^f&2sP8?4%kNp` zs=W4*EtX=9_nNfwPB~; zSzUWt`tHS!#TswNVo}@pz~0jVdPhFb$M?*D?c~%3wl8Do89m;S=Vl&q@sD|C<5)Mw zX99$m9{cFM6trg8$N%yCpUjvKt(DP6dFZ^j!?Jd+$=vAo`89qwSCz#kbA6VH5n_jV z=aL>Zj?6hLjr)tzFR!?C{>Jphncrjl#JW7=Gex~5>?^-opYq@wRKB)*$LC3=AK>@K z8o%Xb^x4@XYxK7<9euTr&nJTB|C*uCKJ%5uhuTY?z5D_F<8xcN*U#hSx)|fXVQA%n z-Dp~Uy}xB2JU#fbJoNRi2-MW6;81WexI18%I$^^X1}_PmpH~L>E(MLVyzplVP~Tg~ zCgUxE{y4A3$^7^E{*z91T>VSA9rKqSHUZf^zdyF--xKhR`4p=ofjEx!I^K)y*bdaB z{o-&YK;q?H>0}^Yd;;})XFv`fek^&^x0uNd+!B0wgz@cIVDDC7{wp%ynw~PIV;pCA zIo4#_^Cz>1og2eiZFxrK`tOKrodRT??AmItF`0a4+xY)&vfG+=xh5B{2<%het<@vx zH-GFD+uH-W#j8gbsPEWY-!b>dOZ}Vr*&~u zC-qbA4+rLYM>Pk{-*|S^&g+7%rTd_>^D2`exs^-j=>-8A=RRd;>H%|}4`}2&u`{)@ zk)1#;|NA>1)zdnN!E#=0^O-Lv19eBA7?M2&twlAmjA74){c>Ww5g1=JkL@4V<-?e~ zb^Dk69Xn%U@|8)fJn(x8ko#wp#RfFa(<}bR0=Dw;d?0`Q8F%mT?t-m={BccOjs`Ce z$PrI8^4QM~e679K50XginZr?_5b#Okw*F2avSKZ4! z_BZe8UY4a_KR!MEqe0`}dFR=D$MlbUmogSpwx168IR3qRIlCbc59j!+(h+BLOYo;M z)_!$bI>w)oDc_ZuzcJtk`lesH@4j*T{*1+demwLq_x$2w&;QDpO_gKcvHT(0jx&73 z3m4^n5isrAbE zmV7UT4?6ey%<_77UC*SKNi2f|CjH(@77~WyUz5G=fYv~H#UGDYTo)d4)JJuG zWab`|@tAvSeEjYFO<8MX*w=Gm?N_tLj@sC>VC_e;Hv0Ni8P_keS9w|Rd`JGKY;As8 zc-&=`J^JsN;T#}-;C1JJO(wn9{Co^Knf6rB`Z~mQVy3P=`}DU0a_}}s>}TWc!HFQOt2@|!amU;51C8<8 zt0j{UPYl?7CP3b~P+KziE>3Lde)={7L=K*t0zCTk$$|a#V>A8j!20#|Fb4FhI#(iXx#Vq{)M)0M%zuBk`$gz)((N{6L7}$4fAm4cP z4+m2qu3CieLQr3)^q1@GvVJz00zPUHpYbEHQfsX{&)Gj6=GGql>>2H2Z|$qxrT&NO zN99Gu%Fm@AY?&;E_VeSGR3g5*+_qsWquixKYKt~;;^5rcdd~%o^7#KGv0I5 z*wK0HT~d6E>3M1Jo^ZvS|G@ORIYKAKivcVcy9?u&cRpL68i(#Gw}=jl6#^JJY} zsCOEB(P;0|o}LT)Pp`Q1`P?km|Le-%8v?$dWjuswlwaQ(kL$9&9UL?shr&ArNRGyM zu#r4Avr9b0$X&xO=k;sjbK|s`v3Rl3dhaY@VY6{_SbH}!$KI~lw^#nyF$IXdY(!^+ zF@O5COPuXHu}A*Ii*9?wfK9u_a9s|s+#`oGr3}FPR(gO)7@30&SgC=*X8zjKo$}k{bj9~s|{l0nLv-a`TY#nLi+L~ zCiXPW=HwCBDzDcTHo;XR*3I;5#~q%^!6D zn-4{nn5{cc2eJ8|=leMR?`QLg@X&QKI2DN1wL#laIM$E)o2gZeJEzWD z&x(Eai{1FS#gs9!pN>(#c{Noz^fgvf`lx!xedO4Km;Td%Tzqi2bNTJrCI;i)3|IT; zUEUwgQTN~@TWrWjzcI+C8?QW7J{#DEUyGj(@yxGbT79pK$KPw0&*s`%b7=2I@U5Ba z`BWQXqkT+Z-_d~V&UcPoc=+G7$EMGZ){dIl4%moy3XoXiLvl&q&U@7(SMy>CjK z^>Ih~$iC*xSe)G%?4`?k$5Z-;f{}km-_E~dsA+!PHS@3+k>PAKKE8)j-x~osAJB1q zKt9@$`{(1vm=RCRJkiGZEaOdwfJ~?y8X0)$G$)=}Hse0IAYugeQ_&l5C;Hjb+d=OaSlIQ#=K;B`Q91N@Wzzw3C}J@V2u1qk1Tp!GSWzg*|5b+McRwWvkasn6yo1Y&8Ay8Zev ztKnk-TiJuyBj2@Cd}`;B^u?CGF`lC?Hrq?*6rgeaAaSw>-=l-tvCg+Ko_K3#d6)63 z?(*?_3YL6)z*8S8FH>uOZb@4^=(EK?w->^sSMmhF3Z|Ocj z4x7pPb8BRI=8)4|^jUN$bMj|x3Q*;bb#XEC_8jE%9!f-4pzH@R%5OJoxJ1Hv&YCoUp_HXB9Oo+k2n)IkS~{de_x4p2lEGAD!80 zR(`8lM3? z5w_E#9zBogp8|5UX!M0{RGI7;KYOPGkCt5P<7e;WS6}_o*0*Jh#fXhlfTq>g`|mS$ z<1v3|Zqq!#<|8IT^pejuXVX6I;Xv#*f@%1^-MzCFAU4!jWApU|-*thQlf@sgG+!O| z(TmBd zddb?&cJ?%PV{U5im^<;90yNs(+|g5gV=l<8ZFsDSr&df_e@h=4`^tQ{K9EBXU#Gw` zNQ*{48hgC@t(T4T)rDBpCim^1PhMJ^n;DCbJk>{Qd~7X~xfPfunMqcx;w&jH_`^AqgI_aJQ{%VoEX9IpWe(uUCKx6#quK(<_&m0+i zs84)29nkYhyL{d(E_l$XfrmUXWJ}{JZrg!1{%YAf#;?5Ayc3YkkH3@8qOAdY*(#>K z|D%Ikv1AX~_;#y9Yop!YwB~c}##5}_18koHG{#c=5Sv;f_HG3H;@?<{-*|vpGN5f=&laB`M;a*VpVyqBYBqvc00UCYh@3M~AYhT|tn`?5( z^iIWYeRgWCv4tP?uYCMC9?*sGkSP}8OP7`pYGotXob#zR>=R2w2l@Uz2bpjDYR_)* zyA%3OWitoPyMYGbhZpt<_>{QZ&E z!a?`^%r1MzTgMG&W-#gjYvsK;fbLPmK0_$2d#*IBltYBO_ zl<~>nRG@!tz;3nOdz8NinG<_9uw9&<8mx<%b@RRB>@jAimS0-WB(3Yree2E?!yAJu z0)GGT)T(v*$mv~LpYXx>`80mK7lRW4zwz){PW(FoIdW?Le9&BVK2s~cqiM&yU!U<9 zQ~O~@{{#O`%J=?!ESC11%UW%s!@o;?YTDXBE*`e|cgKX{zOH5XAfLq@@!4KPK7Wq} z@@;-x=eruUP7i%zXWyBCujOydH!=q=4PHO@@vD!Ao9h?=L2-J*EwOYIwMEz@MkMvoBfXrd@ij8yin0{*>A3c`> zymYlC|5$+MQ9|Oe!wy%gabFFnM4F>z(*w;o{Mx$w$E{S$w6yUfkEMV9kwe#}j#SI;;( zB}=W@FHYZn0R5vbXU4woIKaM9S8a7xogp&bdjJ`u?&jz__u1Fae!JKA0FMuxxt9lh zex$pK!#HNAcUb)FKjJd7!W7%lp{%!`zfUqI)Cg z*>=v+mBHy%?-7sq+2M0P_K;h<`hF>{=Gpeb*vdBk_x>4u!ZX@P)*lT1N$}F(u|dpT z-DP-3+wt;~Tz-F7{Klg;*-oy#{5Br_c+VO?E`_H$#6ZmL<$K(?{4>RJSRcu}E^rRS zj=k*CvQ3Mpa&Jg~Gho-nK+KN>a@=>kiX)cZZ|BCFAOa8I>R8ZM? zd}b~_e8F2^{$2bh3+OdZ=P%50ks~s<0{)y2#Nu4gGuwF4K@J_y2>i_{?=oitIb^>W zHJ9FN*@&Nw?mXv24!wZ@{mF^F{Nw{(t$BNTCN|R-L$c+UPWeD;xOGjhvF|LQY9_LLh z+Dks)D<41D&yI7!D8I2A->b!E)aUF}AKBZ1ed=QLTfA#a^|KH04=-D^VyZnIu=}45 zcNN){WB)pzGJW~`SMOg4A6eC1-|1$n{5Gz&ee`obIrfOn(Lg-hkyi%tEiOoWdzawx zJ>B!u+Vk?DwxqkdZ|Ee0Y(Q!1`%`ZOf<(J$xR|(T9hC6=k{Cp)n>iU{MjP;@R=h3j*BZurAYnWc= z71BQ*b0; z)3Pp>GA@LN40hZW$S)tOSMGq^I|H`12HfZ7#n8P=KUwD3=YBjlgB|$%TcKPW3*;fg z2kEkh?R@Ro>V9{ZecM6xSUVli|8u+4V3t<$*v_B&CmwKRKnBYH5_`Fh#kKJfBX)^D zUi*G(;5C0kz`x3G{P;rFPMv;u{{O4udL}@3>@=5K_VfK|fq2LZ-^5egQS)|F`grim zk+|94I@wHrJFu>X@z~pa;$%32n16PRXR^OT!+YgM*2Ib(h~4BqH6Tx4yp}QE%-nX+b^EH5zWP3; zPlpzX-O>lTP6vGbGs7LgCN^mKH2UyG10P+ZEu$Udo=fwdz5MQ(tY1sNk1llW<@e$6 zP61l_&1QS~<-J(`_`p~5^lH6VSXax|@vqB=`X1L?FU{-Otm~6?WNzi5@vS}Hqw%nv zJoVM@x7!yR``E@7^PX8fU!5QGfah4?Y#tBnL$!-vc>KHSMq2XeA**uO&(1NYKfUJX z1<3JU$WQrN>Ly1%4h1KJQ$dcx3eGV3#%yEf&4JJT+0v?aAf;r;M-S!sgmknQZ!zpf<6;?`YqZzC3C#%&k7qXYYIF{<*X-3I0NGZD8My zoSna&>)t{9W{Xr%z1y+}Nm#?LZ!_lgExR4&%?vvJ;PWdm5*7S8@)gwa%|8V51g^k2P~zdw0v_ zHCZD|j%ssl>iuG@MsEuEP}}+r(;O{rV7Kp0#lc!*uLX9wL&SY6sC+h00pbh$@W?rx z+S=;=ITN5ef}SILKzyoic{bJ5>ORbwd`0^1BYpzgz7s>}XwVqAD?uD?57@^Z{OXua z_MZ*z3Dl!8Iv2Rxrhs0yE$z?L<#$HDiW}Lx{r<4}dni175OX%LvGJuxd}}Y6w*>57 z+UiVNryGggZZ?j(=_iX$b&Tj_&(3*z;O|we4z;nHj7{vVF6`f~ArI@|%@m!Q;l zwx14^!M{q4@UP<^&e)mh_?t4O&lvrwnP2SX+&rIOG4Jbq>&m*Yy*AH?QO>vJAvBI( zmod9)qw~c+aesS&)GHpcyH|dmJ@2i}9&q^hv9!nD%8(yp=R>Quv~=GXup95c`49Kq z_f`3$+&>t6%zwJ?KJonPi+JK^FFYeW#%x2Mp7Cn}Yn9Jd>)({0X`!RG|M86ZR(a_@ z;*Vsnb#&*v-th|;<7X_!|1Vs_Xhr z=38U?oASG~)apkB_FWqKk4aySeI73Ew*~gADfA85`@O*r21hbxPvwi}Pm!J9?Un8- z*Uh0;jO6f0Vz7+qYv(<9$ocC0PO;WhhL3nx)>|hxWUN*yyRo@0b7Ekhc8uY(=lL`% zzsPuI@HgV8=lVaL?~87;u(mFh!KA)nDN*TwX%Kt0ud@t9?;9TH5u~YsJ&!`Xf|G$-kZhC0FD{-DUmaF=e?kbM#1@W=h z{q(rNxxOpF&n9tb|2658H;xYv<5v&;&mQ{euGQIR>(yBw^^E#=lewQQjkElSd(XTx z?r#22fZVfz__g+qq`wu&o!HPXUhT_EvAhTHpwZSFGya4C@ACrh`>zc?FZkBr{lVW2 zelqyQ;MaoR3O+K)dwg&zxH)i7vD3McL$POj?G_hy_kB5Ac70!Fr*(db0b&_8WS%ELeIx6giYw|^P;%Ba0Z!&4id zmj2TIDRW{t+S|QL-paA(QET>y$*sZRKwsTFIzVHL+%-s^*h?;-Zw~BT>gBT-@R@D9 z@r}vczkT&-onAJL`|IOa z58Xe7myCzPFBcK1&0+bLIWr#RuCsdzk262=RmZY+nw#od7c0+;Q5K!{ zjWs)E+~<31U^m+y8{Vb7r)F-9J$Y!!r?&HL-Fp$9Us}fH^pO|8)cIHaO93M z4zhoI-aIin#qmkOvw}|#UKjk)xqWxq?+Jb+_(wB-Chczqg7h)LRl#UO{cvBci_OK% zk8#4^+Dms8H{;f+`{8)75unyFyOEfRKi^LWV*P{3?Lqgmv-(FrnydZt%zib2zjD%D z_1Tl~JmPB>_J|8w+WiF!K7Jowao#U~H^1m-$8PbgEq5+-)RxAfd@tCAulHD=UyqvY zt6ufaW;t%oy4IYn%OU%h@z`G2ARY&i`Ec_%=8rw&xHj`ojiIGq-81rZZa3c>&*~a& zCx5>)y^dcl<+b-xx|i#7w2e<{hK*BzT0_%nv=f8fYOel|GV5>WdXM&Z8F{mthd-t7A-@Da^0#A>eAIu>Tqw(L} z`yAJLrq=%{eI(yofi<`kEZXKz2FB>SVwZ0wC*6S&zQ8=&8_&UcXLRLy+8Wi@rM$p7pHw2<3eKhcQU7@<=}n6 ztAiT?^?ouq6^IKwCTL#rQT>D71?)lOk^Ofgo1LR*Awc`yLtWb$aGdm znRN4$P42>fxF#0IXPz{d&%sZG?|0)I(7`^>N4AQ^Pe#}BJhS_7!1m?Y5fd>GC#~4% z`+qUWb~gCSFEUO9&L-+P|3|+|{<-_)gN^bh=Ktp!U7q*uHTK;V_&2oM0(355XKPZ7 zerk=3W0@D9EUoU`rQUzMX3s;_`%l)$81;_1xfnb8%p1>&8tomKv_IhI@a2h3@^c}O z&n5r5zioj3*5Gi^bK<$uvops3pT>vfy||16dmDdoY@Pgc_B!9oGexgQlG@To-Sf|O zi5b3i^~~qShhMurL)O*SKVPG3>DyklwLFVIvqs*r*p%tj-LzM}*X8aXuQ`)qfOej5 zAN!zp$g8vVaNjG*l@oQ~{laro&7BX#ST4^6OTT}1jo+K$<2Skxxa+SE$+_CD;U7()a7yn|7963dm-~01;=J+?}#d{b%_XfzhAou4ZSB^&e z$h|8V&u#N~I`e!Te{TKCjO`)s7b4HO8RfBuugkmnudb;B=K=BQmf#m7?|0*wGscEp zW8KkrG`Kl%pS&^nlHgsz_Xj@~{BrO=g2!a@?+g5nzfTKZ6}&0<#vuQ#V&3?U`Qhid z?mUW<`SBg&A0$TOy*a*Ph|j-FeAYeRGrfA=(IIErFPvqaPhZ`VbuMrZlJ&3lkrkHJ zz8lk$rw%?gGW*Uh$Cd4jk-a<*|2jI>y$@}Mm(65e2*m7Y;2viy`+g}5d)>QZ-2O#A zGicoEtNO36|0c5birXmb-GeN4H3vQ)l`ppa@;>s!OFY=pd^{s^$pe0|&$|BdIVQHw z*RMp6dtqZ9|7ynl{*xX5Hsi;pb#IJk@L0y)Bk3A_`|*5l*f?3MZ)E+u$XXX~wvb<+ z>~G#H%bjpKK<|o<%2gNjla3G0_TpdKYmPj6DqsGVbv4G0%wLO4dY1Cote)1%YurcM z{`~>uu;pn1yT-l$VVBrt`T?<{ce(f153slO(fy5&SX>D14Uk-^o8O4cv2Olj#_GQ{ z*_z?Q^349H@LCtUWlYr!`&$dOXPunijGT4#l<8GW#=89Vd?wMl8tan$(Qf(v&$E5& zYTlgvwT};c)_!sD(t!PF8MFTqxnkzrh~a;o#~btbzh&IBH|DVY3*pme<8Os`T}@{C za!ocD-M`Gke-HCs@!RW}_E6rPu8B>%@r$E)J~cQV91a@WG57lX{vQv+=B@l+6Bn}g z(*pVNS?;TYHw14Az9@Km@Rh;4f^Q7IHTdq}`+~n6d?5IV;HQIM2!18__29n+|10o! z+&(I}I(TAmJa}?&OYrRALg0D+(%`P(bAvAr{%qjqqW@a(L&1**hx5?-sNkC5MZxXC zX9cefJ~w!C@Fl^Q1z!`qJNV|{y}|beKM?$I@T0*`1wR}7>)?aIZw9{|JS9cc>}H<>wb%L;`>Y?@XMJOz^~3wD zKXRY-NA0uz=zZ3Y?6ZF5KI^|{pY_M=v;GnLtbgP_>mRkx`bY1x{xSQk|K5GpAG^=` z$L_QKxP8{I+GqXhebyhp&-yj{tY5p&`tRFk{Rw-l=ekAD2CzJL8!>ma#h} z$9Z+fpPkqHeatNxfBXUW^}X=k>_MKth>Rz$k#R%j=|y<1+k>Y*;oA%!U85glc@M&O zE_mrYc2^z^|M*_CHSg!EJBrNh%zaeaQD$S4rOUCwdu-l6^4^g7>L(Z9^#|Z9@9_ih z`utPYjL+PY(EcL*(pr@1EFa{p3FDr}kMtz0dlMd#sN+ep2}M%5mfN> zByOLuhh5_OlzrBpy3hJe`>a20pY@yfS%3OI>$mK){)~OrfB!z~&)jGI6Zcqe-g_25 zDZD7f7Y7)_Er9~_gR0=KI_vy>u2^^|CD{!&+fB+ zZlCq@`>bEsXZ_ZF)}On}y1dBKcpg2E9v8^>R^a;^gx4K<+aRmYimp9xkF`Ir$J(dv zvG)8u);?{qrf$y%>V_YDWAh8b=d->(KiIt+?+e%P_ItdI>;v&?KkO@g?xau8z;n%K zD8?_E$IguLXUt=|#f%(wg6~tW3a$-&PJA@DKA`(af$#mu@Na6*n)@%F<#p{P^B6zg zm(F7{j9)g7$u)lYJf_R|74x{CQ{O(1*<}5Wd3@D8e&sx7yY)XfkNIPK=R9saUNw&! zk3Tez8xOhq%*?I(jL;r(_;M=9w`VKJwYx>F+W%SEPyg~=K+e0DJ{a>zj_znhsbK~OpO3vX{l?^6`sACV z8;x_$B{GM{8R3_>@W&l~F>v?M&rUVA9b5{mtC4Yj${5MNGc(Fdm{wz9B7b8Zw@zL^ z*M<49&NI9m$Ht9LzBOj-TSA_fa~;#c#-wINqdb;bXTKH?UhzRo-tytaQ{Va7*pe}> zITxQ3f7JcsbGWT=ZfgAWAqBId6M*nVV2KTow!4Sswe$F~R7e@psotB!lpCyy=W z@yQ9gBN**7cOkI%e87g|0sGKyYt5USqSpTn>GO*Zo$Hy9$Ik7R-=~CU39^=R9cSqQ zweI^W)O_$&ZL(7>UK2bc_{;?7sV_8)3%N;rZ3)NkJxc3 zkQ4Ll7-MHF_Kizp)p6sr?*3r=H!i@==D1pmcw+^TRrFf7Cbf(YfGK@a6!onnrwT9rOQaK*xn)zV&{P zyW!64Tf!Mw&UKun%V&G98h?5C_{)#xcegq(uUN~g9LOu54w~C*!n+Y@k(l$J4g5i4 ze!p$VulqoLmpK*l<=mKOx!NnwcV)fxn(ivk#`blM&Ewsb;qN%d{I35mOMfGt^Kl7r zS?w|JjCLY|k&o&zyfgpzBZ0c+A<4 z<=@rC`wcNb`^L27@xxtfpLo6@eCE}T^X>ifF>~u({n>#tikw}%YVQw6-iy;-KVJ&& zE$7Snt-;L!Ir`4n6d-X>7h@jzr}oIuKNql5UdXV1CaY;hHHy4cT;djfvED6sy5 zz}|ZU#Qy5x4;%2a=VEXvm;$6fjwh3$aZYYd1=j`%(dAfve){Ad3FzaWT(Olu_IVGt z4-eb z=FZ?yK;~P5TyLxYZ=~~V5I?fD=G8hmuM7A?j=j0s?vpS2?AxAOv6WN$D~FxxIX@z@ z`u&9XmwCI8x&8RW40>)4r_VRB=GR@pSVPTY+k@`obN%4okzgy>*kzt>d+_$mwl=JZ z!zib<;mj=8GPRnUbV6(=dyM&%F`8Cich0JqldE-4kWHs{3eYXVA5HO11|esheFxe1 z$A*1l{(3j4>8)V&yLC8a9-RpAA%3foDL`FYSL?6Ox>|Jy!W1C69&7o^jLH4Nz`OpN zf>#F4RL^JaRBL0cEXU-i0rNKp`BhW9)~>U%AK$urr?s-~-sxIIU%q$L`xs+u^{f1? zEw#E_JCZr|(eu!D${cFFREOufJ#3d(F)@~Zwe-Iwn4Xcxf@^~DdB2@;c^{X)y<*R% zDM04gqYmXx9JFd(-}<4s|K_xE`W4B;#k8&6bXT$`olxgnqkN)Ut=a!o!D|Bb^!mA7 zS6AbiTh`U*W}mv^U)OpL%<;YY`A2u}9`Cd0AT>kgh2T%m3oJ@2**{iH8^ff2IH}Yt3^7ueixO-f>JW(oQ-de61h6 za<6UvpiLF+2yUD{>A}SI#Q5cGZHIiHDfo6^wOPpV}UD-~ZS3DIN!{PxYbh#6=#&+?Wr@ zc+v@(CtDqne~`NL|0s@id5}G?TkMIdU2Az+GZW?z`_ztgJ}%FvdHFvZJSSim|Fj!( zKh2897@WwAI6Xc%7m!QN6d-z^5O~(y5Lo+g;5`{TP6g^5*zQi^zgWCrZr_;}v0L6= z9ProoR&UA!&vO$06d>Opp|=HM$A5b-1>}pvRv-s=26SH^MAV8OpBVP;CA&6xw)AsC zvVL~vvqv3Pwptx!yL;r2E&P-}GU;)rZwK_aGg>Ej@HQsK>ukeA7XACJ$9TnDE8bm~Yy4fOzdGH=>?(h{tGk0-JdI)VpceUMtvPD!tyQ*lc56Wl zmUX$2IXr9@m-fdyz&=FAI$Olr+B#c0Prh|NnuDcn&cd;vXZqp#|4?+w$*8l>A-d6t z;84(c@p9krN1WyEwgBmyzcb*g`%}$b75HB5Qv-6328RQ8&glUCQqC|Q_pNxUhmQ)T z0Lhy%ol}5}1ngxK|5^*{_{gizm3xhL-5Bw=VR23N1UqL-Lg(M zKarSyejv|$GVlAIl-}y+ecHb%bH@Wdh~q{u#*r_h?`*8E_{sG?_IWY*mb7$D0lFhl zU+m`dTLbbuciJ}=-zh+?F?xEA=nxlFo#f)VGdMiYll6)~Ud+*18OB=y``FVw-JU*~ z_Of5j*@LHb!d@`PzPASW*~Ny_bN}b&*iIQEIU8+Q`mwR%+KE$Rjt89!Y6qL0ZT9`~ z#98k7P5$cx_fP#ycU3o+(mux^gx~&-$+fp@x@eXY0Z?AShep$mOZ_RuZX_0c^-2A)-p!&85+%$)tGvZvK(C$H?3 zJ9(&$x6b_=(y9wYAD+(%-Wc%r-T>KuP0%yS4)OY6>>zWwS4`wjJm?Y&Hg>GWoH@EH zce#gL_BofW4Zb6CTKD+a{i=YTo)71M4|L#fyo}j$d$3>Ki~G9so9R{FN4bYGw{0Or zuK1ukg4&M9*GSOX>3!?3W`oBqpts*QdYVS!f;0A${MM9I6}h zTJqJDwx1V?-75pS%3Hha^Sn@JN9XnK=Lb8xr#UuPp6b9u2b<_N78iL{19aO{pM5@n z*Zi9UpTGM3T^G~3+vNEmd;EU4?jcW~Zo2qL4tx00I5%gtv9WwvWVO!h-wM!22Y8PJ zY6d^KTj5tL5ud9{KmH9Y3GJN43+s+HcPftl2ZhQosIA=_9!t?=-qVJo>y<8+QeG#SNVe z@W@|fl5ehK_Ffm5R|n?;wILqX#`Z|YPYmeVoLhMSF?H8(2hNo`?mbBV7X|Wz$Ggux zxp?K6jejsOZ%lv3Y}^dAY*Zikjpgr_;LVZ4pK%XfJf9qhhdcgca4Ogct_bLQWAK)F zT-j`GEvX-b7n~O|z>;!w#|+D0y!+?Mt!KK=2T6{&3^lwgZ=ike$|$GSf^iInqMcY{Fk!M=GIcr!Cp33 zw|i?Z-Mh)!P4{lLj`13GJ4=-{#{K+5@cF_nyz6v|^=>+MlT-V~IPYd(b&6YKXWw`~ zOc^6NopeHD{@gcPLG#(W;7W|4x9>EoxZRchiGW{7&h4|`onh~t0sWrO?i0LyW_b=> zAGnvuksI`az@1b+F{@njYR34+fIRzuCbeY0J$_z`ZnDLpals30@l4WpR`7!UXs^BK zT);kh=rCpz`;Q0st_tiI1FiKbK-22$j?K5Fe|1pax2DeyR2`$e=Es;{ocY*+#DUGm zVsk#=OKqgbxX)d==rdLysfEUxPg_Bs5n4WN2UCF9`KVRzq3^wvebc6*?@UX4A?X#v!ankAKl$p!_*KC{bL#(d9&<|eiNINO zzQ|Kg@`4ZO9rIcLJI{^}r#e+PW1Pit%u#Dl4DmI7^>wVRWsa^1|Cl3j8_$@S$h(+m zD_ec;ciwz%KISG{R=H7Ah^@`dXQf|zA8u~=zx3~S`wrQN-TV8wyS}jG3U#?^QM0?I2G_8#ys*LJj>n~h#6GA^S(XLT}n&Oa?Sp; zL1RlV{Y$;e_Z2nnedUXCkk~}-y7!fHnXeA-EpG{bZ7lz>%=6V9&qwy)eQS8_9cAB; zF~64f*~1R4bESV6wOxB&`g|4ly=2)3o?lymJMTy!M&$8D>t2@2`e4sEx75+~ z$~+u?RGZk{{&Mf=>pkIPQ}wciY^}9}$mlbU4R;NDnhWyitgb85U&ggE#B-E!G2=_Y z6d?B4d)gqBKYP9U{*S%txbyH~yU-nIXH;Mq0K z@vHX>dA9}it#w=9=-LSAesdu1Vg__|E@itSK8>=~T;CPwAg}9>OJD5Flk<|`C*r60 zb&qxNqwi#JD!`A2tz&%19^>-y8H>wxff$f6zB{N@^UmED#{qX08ROa8%=n=15WhUz zzRq4Yi#z+oNN)7${*vha=(MBWV;QseNHF?Mj+`y?NvAyR$EzO7o9@acabU;2v4ahC zUlXjeXL%1DBoCh)S$owdf5b#Q#K;(W_T)$opBT`u?%4abIcN5bwr*xDcHT|p+g|at zSKGYT?=PL@EOW3K-Yl(Zkvy?iAA8mB2ll9eXJoI~lF8=!N2ce>+q1y$(HHkC-QDZX zTetTed+cSmc)c?`%UIozd2xA7pw^xfpw|cD-Z2|b2k6J+qxv-_`wJK2*JeEOzj85t ze#U$h3;vA#DPuJ5_j9hJzWee`-njnW#rWRE_zfA0Ywf*b9(#_NbH_YuvFG?={M-5e zz(<|`d@(+j|DkfU@mKTvibnpwow4;B12Kbl<{#k2U5$#trv~U~Fz)^Q>~%LmefWj^ z4@k|?-I;$=a4BfM=;EK6Ccp1tTIWaGd3UYx&$y5 zX*cKA`7?gf+_vXcdtm4V(*RQu`jZI{- ziM`h3^whj&Oz-#Q_kWS`)Sz=8mpS`8{>=ZjGj4wBuXjd!>*vvVk8}Q+|8++$oAJ1R zwXL0v^q(A_rJZ<|ac#XczKuU#XuPkU$Jfklb+*PmQ}A!jt-3T;Z(4PvRS()zb1O&2 zVyu12+}<>|H_xqm*Shnq{lvNTOf-J>+)i`*DRX;nZZFL3bLaMXbNi`t`)PCg!nu9X z+&O(A<93+}<^}ub$gWY1yh4k$CX!s^DzEKe3TJXYx>R zGBBs6fGwMI-yS)5OrU1O-MTu#D^F8^?g+>e6M272faj*bK03QLrH{y^V+s&^4+j?m zdZz&4n{+~W4y}4SHnBmT>DmbXVV*;;NbBBoSCTI-YHus39pv8@AUy6@GQ_?*$gYij z5AYmDe8ER2;{U~Nv zT>pppn0pc6|&kVjiGS%H5h=O&w7boMG$!okJDcS=rramT&LF$*3d%dm z&-7)PF=6HZrLg)YE63?%QV&_4urU1#?XlM1i z91AemTSe_qu`4ph~KCMPO zx|~hE{>cb$OxOA6uHDT)I!52vh?l(f@zgeUOabcmgzI!$=l5+v<1C(g*&&wAZR1aO zW7+s$n>leC?ed;szd5b@?^tkEuoXC)<~}bQdq0flX384k%aLHrq59+to8)oSJId%@ zwz-oUGqz0uDo^`|(rLW)5nb*x#20$ak%P>UeKcrYut|LR$=@kJ^sUojo?b+@{fKO1 zej@Vdq3`;jHqtf9u&=zeY04Zb-?BFGoetRX8@XHL$Gyeh-ZAN}Y`P`wSH>tjUmvhz zD?k?lx<~t7W+7RWM{DFEc9Zp0v#ew3ZwGut*6W9H{i>b+VzBedtk+KG@K5a_liV?e z_`iA&{?VUh+;)81`MZMbdjE_k&n=tHy=QK_zE}H-@XE*G!1-Wr^Woi5tZxrmPh$9} zz#hE!1nS0qxxu#)Aos2ucdx!ZZ=2`8cy8s9Jhga!ZhMB@3+I95`EXs*5Y$n6w7Drm0BBLm-VGRT+v zDL4|eCfw6~pHeSKJ^j5^Z)XoX?A2QP>%nMu?br4`9QUY+EApMZxyJ_1i~fk`&f_mg zdpM{c?(-=?Y-ano?k>14;Cqhs>K(f0=1jNcvODId`;&Y$#(8r!bHA;8S2JWfSNw2Z$7irystwF%#@u&45x4`!)K-22${Vn^u?;!lm0iQh| zz9xm_o+V=nkh4K9pH2p+=6;&hnP3l+zvhtdHwN|`3Qp!3wvm<|ITv60{`4;Tvb2)@ zB%RPG+d14c8LB>Q&zk%`b_PGz!8+m>yV$6n8xQrvzCW{zeb)Z$E^E)oTF=+IxQPi} zVj)h)1Nz3;;;C=-iywTuI?&$^#F#C3jb9MhTfg+_v95mI2Wsj+VTl+md%H zb7He@k9qvwqwK#SpaYR*Za*IW$ZJBnBKGjLI?0nGeu)*T&3H}+d>wxe>(Z8yfAoWm z%~QH7n>%h!=m#>`+MIYlF{WRC9X=`Z;_U8W6B$#0_^1Z919yyExj)E52ft=8V*j^rXdj32%5F7IJd;Sj6(y%~t;KcmVxJiIIrxVU@6?sJP63)$U+-_#0$*DT>I~GYTGww~w6*rc0GX@Z^jPEL zMj&R^_-l>L=GbW8y1Sk|;$i=#U<#1=xO4e?WOgmr4`mLiUlPbT5~wLe=lOsv`;j?d z5{joqS8*^>Xs2r(#pXF@@_?>SgxAw8iJX@Uw`4Ufh)LL8hLw0N2el@=t zkfR3pKkB#NKJhsg91h5L)|Ph3AOG#4f46qZ8X9HNO=fe#HskGpZ*;Ab&6g=a)wh&8 z?qlPGIaL0(AF6$xh3`sWZ%HfmQ-JOW*wVW}Eai^R2bp_X_?&e)YmJcyVsv95|6(tn zmj*mF{mp>R)}M8HJ&)zIwwz19^{1TzG_AhwtesEantk}yo?OWr{mU9_K96OsdA>OF ztFP`O4~+S_+=sWmZ=`=kpmy-FXDg@-^EU_Vv3~8`K7MYmo?EqLUG3i(h$lTCoqPP- z1LHB4`1x@-u&4Im1G#w0+&`PP@zz?~3hX@>^uDQnIl!Y%@$g|h`(z+C6qAXN`c)rn zN7lt+3Xt*0qfWmzLB1s|xl@4DDLP0^)~5?QTOQyO+xbGiJT->qrvRyGbwiF=;aS$C z7^yd{z2YWbYTVw=X~`JnPZ=Y7opZ6VS8T-^udy1ju7=J8$oF!Gf{v&3(TRY(y?l}f zKB+k^9duV;^>@BD$b0qerJwKX>h5`&XR|morfNXUUJ|H%L?0WPW1ov`1@eWTjC%t_ z&c(p|7+d4kllUR~$swCgabipTJeoc`#`^XwuWq_fYg;>+2vyfZsqe4*5Y_jo9TQeQ zsZkIMzD)sg$8HCWJDz1Nt1ofU+N+%cG_Ahw%q{O%cL3SqCYJ6{tvWash&Ng4O)jj( z^~?3Pj$a&GLmTNM`{YcX>WB7=1G%+_&fYETafWLH-YWuf)Kum4d7#B_-FegYOt9aW zjvIqRbN@T?GcdR29;TNKbm@!VXrndHA%33=T6=6{hjsj@IUMVYZO*MZw2p_Y^6-z1 z?$NK0(p%D!KLyA=+W3kIoCxeewVz#lwqConQ-HdMo_Ft~r+FmvYitgY#V&JyB0$yM zcIRFEV^{YBzdlr8kI!1)6dVrNAm94zau@JjeTr?NMveve5HJDtAjn$kz=#vRQLI_+84jI!_pbKt z*ldl>tvfZQ?izEs>ND3|+*sM`oOpg1+dt<2&+p*mFXtV==nkUPrvIVt((oR8DN6~XJ{2YcClQ(&Eq z#=WPsWP|fX_7tFL_4R@O7SK8Ix-JlxBY`+p1|8=4OD5i)UGZV7_kqoT-&2521mqkF z*4fNAGS}H?uehu0Z;Vi5F*q5V3e*s}YWI@^yyUdT#DQ&eXq!v68y^X749L`fMq;~> z7QeWX1#)yOxGLBR>MtHK0rkrd{U!gI%%L%EY_NxXc8ZO>mbdpv$5Ymj81RGd_<;=1 zfc!}4ee4tmJdKkWT@kR){CK9HnlZ4Y{jqhAiwV8tlGB{snLgXaUra{6S7c0=T3};i zb5r`;fzOL7)48wAd(tOQKIoIna{(Xiy&Q0p9K`3*&(Z(=eEvXmemMFp zH|T9U%_{chE(Oy(C+3X}A08Lr5o0-cOOP^J{cPD*`f}JcIg|(O6rgGKbtjh_={u|6 zl%(I1)_4lgm>cszzkKSS4XVr8a1Y6eTmu`NAN^&kE;fV1!KJ`H@>&;KK28Brvy)Cp zZBBvv>r5a9Cj#dS>61I2r9&CB{dl0yw(6`8>K2dMM%L*C_HGAkZ9I3g_4kHn3Q+A{ z+G>p0sxJqBAvtglZF4+yeK7i=&vtfxLBLkEV4h9p#paE{6rgGKb!Q#VTLQJB5Bxe7 zh@Ci))mS!u%mMoNqkk^IZ?3-3Pu}r>JhsXykhu{ceQU^mKOck0?46>u=DCY51m?~M z^x(Y|@R!b`bN@`*Bf+x+zM!RUc8K?1ToZ40E&XOcUwa3O`F_BU>}5B5)e~E{=C*MX zPis?vYH#ge6D;j8h9?E|t;5Zk-w4!|_mjB1ij^3$tMmF|X#C88f9#Y4d+1j$Q-Ijm z9NRku2oKp)fTq>g`}qyo%-_c2hV=L7kLG3Q@+cKwb zUMtS_H})?{U(H$@^HQ0kyvEvIH6|Z_D|awkde*v+ymkEJ_d?EQ`R_`7udh7Z~NI`oekQa1$)`?te~+qc6W&boi7glPCy3z>(>89=IuWl z)SmjO7LEpF-5RimezMptHkSf(Y_*}|1!_?Kwfv!* zKVK2lAG-K-OMuug`q(|*4G>-Ad)ALWZe@(OKJp14d3?EYXzSB>S7iCJPh^XW`=k5S zz|v3qr=Wh~;iow8^F{NxK73ln{3hF8vRez{pkJTZF6JFu8-2F^wg8=xiYFWbw7}y)@5FY1ybn>^>ZLE`CdtxF5#npS9{`C#c`M=007mGq%t# zmZNU-_{>?a&3_>MR|HQ9t_!XT*oF_k=gy-7F}!ka<$(Uf!NouwZUol`@@J2=&AGLg zKD90;D!C$2zIMYeC#Hhj442D6PJ_0sla|<+xftneZc;{8{C*aS#0+=%jCzp z{NQD`md#^Zzszk0a!|jTPix|Bo}6{@ROjpBd3ENkv0q;F<+8HKHJ0ZQH)VV*;E%d| zeDItAi7V2w*ZK(i%&VWqQEY%6Vy{m(w64Vpjq~0Id@jsheDvt=hAgf2%Oe}mxuD~X zd8|hGcs$@^>oeWU?_2uU2lmtteK;G`?r%sRbxzCAR|aZ_{_?&seKhj&MPALxxwF{+ z|H3}|&0EK-uNK{1*6t3(WeU)=`ntp0JLb$hXK(XJkMUM;Wg!0KZv^C$NvFCnzpi~+ z=8pzsslUxYJZpF5l65$!57z6qmYsBxK4-M&w7SU>TQ=~^88V&%#3y#R zgSB$ujPAzk?9wR?c%BgO$^6OSRA3!;-lKPZzHl>R{+Jj4=0q#k%`to7sljG|pH1fi zcJWWYH8t|{i%nMt#{zYapNvtbSX3uJ$P-)stDmF8xbuxSnTDbMO)(}6$(zx61GfQvlj~wx;F6Ubu@$f|*wyvtD@zw4YPc@Ik2%kITnqVWSZY>>R ztiM}~$xuV}pX_CP&9VK8!28+e+$Zx7r;zF8$LPC0|HYFXj|;Yg`YtCA*LQdAUy9ya z((-=_kh}I|a4O(8uw9(_B*yMpHn5rRa&saKPiN?+XQ zVr$Q`oER7G%=X)o&)08_uVOvE$J5UTzBRYz#B>Ufdq!UIt+R7n69aL%DcBzPJ9k6o zV#bOt)~ib6HB-Y=yOI_6_GNH1_utvs4fY|4m(OA&AF8<N54AlI+0dkhj(Fx+}9DYY^oYH!x zXwkI#y2Im4$rbwfHMwd|UZ3?W-#1|lxo@5l(5cSHpNpnnTx(0u!QsqJ0h(4{AKZ42 zdx-t--NSx7qy2t{i7wBk)>`dn&lI5EnRvv$H9(f{!~WUaetFs>fq8bRovpx~B=*&n z?&UjE+((<W*T|#K9qYcwV;`UR zVlNp9^<_W!YR$W*HFg}G`|h*NKuy`Zj3GVG2*l1=yEj1Mt_Iu>WO+UsUkua}e&^~t zW5~K^2)psIiw^m(4mR?UT`r|x;oaW=Ro;M=nUcFG^U_S_vTW9^wkw|Oz$4Cq|_nV?0}HeShK4X3%&vH(GQ@&~qkECjxu;XwNcM*5v-X_OO-AlfkKg3>cqNd^kSO z%LDt(Y1w6t{e_%u2DRs0`h4fBe$U{@@BEARvA{XN%kJ;q#cs0cC99ybC4pR4CYx)=4e5)SczsXeMgI8i#D`J-#f-^@(YAj%*e0fxo9-$`>~;RsHL6|Y zu^vWUq>64&(d}Avrl~3tB!qcCC|o%`?~$Hy(;t13D6w@S>oyYH8H+E zI2<54S|egA*WEj%k6IV*Z8GfbTywIKIs55ZKJVq>%0T^~{K}~Z)Q@_dEQBrv&Ff?$ zG_Ahw)cGjqpRAE1uV-d{yq?)?bk?mUWve@#j@EFxt7pUbnL(d{>T@&TGkKMBBz>`R zXNl?2pw9|>#g#tw)O&3+eR7s}ADh$%dG_@gVO~so=hCBA-%bS^0bcRL4^x1q z)z=5!G3+fb-N%AQ1!R+BZVJ$AgDJ3nBDf-`UVZ${nOw`Wd3mNooWI>fXw-EiRO9X**>O@uhQZCkr9rsU zSEhe@9{=k#XZ_5)hVQyS9yWrzgPu7t>ABR3lXJcqB!sJa=a1UL+d5&NI>GO*e}7^r zrfOmekn@Mm1}6f%_BAJRPv)gS4Qau8@6joJG_Afqxa}VA8A~2>V~oCXpBT9dw}Zwi zF0GA~e2A5Jji@M)jaW|d7RQm)9UNa9=c8jrviQCna%6X)z=;W z#o%`Wven>UOKjBZRv`AhSJ*rSh%Xzf-u*G2=CQRyL2broT$^u5|94{NxHqC!=br8C zqf5+-o)v4y0{J=;jC_1$Q`~;QJQ=&~&(dn`eQ9r=`+NO7+V$ZXVqd;0uuR z-E;q3S~07R$~E76pHBD0JA!KiI@nmB>x<_go7}VZG#+HtR=o7#;q%deyw=%RC+qrh zyKa8noSJD((aQ$+3!UPtWryb-Tk(khXrtP*hVPMcpG-VzpzV}CGKMpO7~B-dqvwV` z5^Fr{=^e)wxiK#ud)Y~@``W$ACblaygwbpAFIb_2WAUu3O6Et?thdM-R**-d^0MWk@oD5C{ z{4&N7$zhd+0hJbg%vtAaNP(;}_j{Yx9&onpR)$ z|K3U74+YJ8V|h4p%e-4N&nI>r55x`0qa3N*uBnZS0XePxOX;5pkUY~p#@+m0ITY8g zO%ClNi+}7eUpe~hY>q2$J9BIoo5oD-9t(Ugy%pRNd|wL7d_U7anm#{!KFRJrF<}R} zy`RM$KRx`G)6D>HFfluR2jz ze8WEl=tRJllfkLr&cqG2?@0z!j114kNq# zXVbqoK=Osicu7Eqe7rTdBA|zT7l(fBwin1_Q*CfJuz@eli}eeEv&uiRyYKWo_PfH# zaIcEbR^TpW(=&o&bDyl+0{hVSWS=?m)LmtyyRyUGXANW6fpZw}bU-@E3% zHSw?xX9C2o?$@?%+KzQ^oo&s7ShJBoWb+eG?uAci{`^1b72X70|EdgF~@ze%={<&wg=C=d7r=aqyn_lbY@ymg8#7}-$ zBa2OBq23Yr^|flZdgKNEuZjcd(Qa$^x&`WaW_6L>-=q9jeS0fW%aOA{GGAW z0rGqE+*O-_y_W*{ngXOI{ze2%X|0RL-NCbi!!y{ekE&~Ick_*ZyV=bK7;W`;C)s)| zV2d?0>gsqmo!5nd56;kTy2VTmHv@k4OtzKRvw@l!?ep0)`_2VywD+JkhIL;*@X))g z6TTvAY~1-CVCQGbHs(2X^!>@BeBzk`bVnc$V#03uSL0-fkI$Qrq&*r;0m8%2DL`cY zz)&NT$&mRU9OlntEOzW?7ox|Q4=00Df!qRnoGCnN;nqM*-yWbB?KBU_!LKC;?Dj0- z=T^|VU$)LVJ=+0ZdidU0v_7uN964-%X&@d5pFLB6+)2(O!bc|JM{7oZ3J`v>!>l)KN_fQ@pewgY3$#SKAZUN`ATQ)N%s*i z8|=Y1#w{*hex^?8BQYS~xnzrYX!+T;_o_K|$s1XlfqF34_%3tChTiG?G9L56{=Oer zlQ%vixn^uH|-ckxCYpGkisAltpEPd0tpdjmwy_#{6S%?Hbol zXa4`;?oPloJSZE$o#(n$s+Rn^tq)eAyG=oppoG`++`1XKbffiO@3Du68N zC_yn|;(#JE>N)B#&gC*VbH>5thqTj3VNOGVY4tHn`x1=KOzey?6K1Z@#a( z69VIPo-6-)_Ivr?_w&5(S5;lH$K3MR-cIg9*6`=5pw3q>x8@IJo*(q~dBMf&>1p1Qi3d*j3*iF|zMiaHjVWIdC{oDu3)FL*E(EzcQeA))}g2j=4*M#lXGx zBj?Y4=A4_kvXPziv_NUY*HiU+`Vlkaq&a_@QhV6&quH!aXXSR9=lu8NT-nk4 z<=LiR{#U!VNVMb&uMb|xU}>Y zx)z4ky>-pgLoZ!#xu3fBXYYYPp6&?f0r@HacL(g}dp*NFGuS`9qwVXt;m@Z9HwL!_ zpBH>tp!9dbPt17M^k-d+N*9}|&39*neQJB^T&epzrp}ae{DMH~ZFtQ#Ht?Gb?uL7U z&0wmxm*sEyY^VQ*?03iDhFtR5F@-^aNBSn7FuKXKga z%=CMIeBApJ+w7$id?xJo{^Yp#t=sH%AJ{7|`n_)(_x{v2d!3PrsazxDc;F1L2Gcu2 z4(tyO1oi?Bw>w}rd6f_P zm7^;L(A;_M^tOedUvy zEOwMn@9liz>uSJ0devmrbArv}i93I^`P-k3cXaaXC$9xc8@_HmpZ29~o-gFVl|hZC zIdCsNO(zAfcv8D3iu2+dKm2m0?(XbhH@WuU6bBU-?G`A-dvVLQg|F}V7VDL}wyI(7;attx+>7=e z4a5ru8I%4$iq2#^=={mif1++3>Jc(Tl2ev%2~X~5#MuDyMN_I^~>(njJdn<#tu2k zFS4v@fwCU3uQ(u+4fI&AO@`;Be9-5gwzd4R);ZJXQ=LT|u)76xRBZTkBv9(zbywQf zPv`9K=k)7YQgz8{nNzAS&c_3CTcA{YYH!_nbtc83@|-{Yv$tYFZt;o>k0!&N8>z!~Syvwih3Af)8wS ze)&%B+s{%iIX%zCAwB)?bkZXS*+4(876XNT<7^ZU#Tv5q1lFs2r)R%RxHGsCCO}Tc=+*lD5)@ucz+Rjr8d#%vwj*#ev*>ZSq=SH=hm#=Z^T% z@V$^WAL?G7D)9AxFP*`heF&V<5le(>jP{aVV}^2@ze=YVhK&JB!zQ9zfwWS+m`wj9jz zmyB6{xbNv_H-E*QoV9=)cZ`^_qd(j8?lk+|YZdo@$oD?)4B;6XVrO3dT0Kotg9%6IZT6W-0?&z!Wu^Ln!idhR3{^EpvbhSXKaqY+XlG4}K zPr0HG=!7EynI)_2w09$@b!A`6nDU}PtXkmyv!C2q`&-79-gf(!gBHx&pQ-VCXb&0g zL(hr_0-iBHmw<{{|GPQPNb%R(N+&+*8I|VXOCKY1){r4*#Bn7k{;a({ptJr>;9A=9 zOm6kOk#kp|*e?#fJ;vC%GiX82U%E46L1xLAu9u7MbcLPegL>3Eh79Nn0jFU~I8=&t7k8y5mxx?8=c;i?}iep|*BHkhC0Jl}T(UyM z4&TrP5DbMz91lBDEiuWTn;)DD<$2RVIJxl4ciCi*@_cRBaOPBh(fG+Zidt8#) z0%MZvI(jpFPu&48 zn)ID%GSu|3e{+cn}Z!P`T2JUFZKC)YIet>JXh@JPB7Sy8QrZ<4dX!ghRYR;a#h`emTf840u${ch2eK9e zb{E&~@4bOsyFB=~vCTH`cI1-7PQ0=IXh6RF<=67qo+p>xcwGp3UyQSl{kXvk&U#x@>-)q)yFJTCqHABO=2srE1oTF1rKtDoh^`4wKmOr-NVi_nc{a@ zuoT=CkS#9Cqk}zxF>A=g4-S=w2lT1kA8KpFUz_~3u`Zdj_L$o@u1hui%vWscelxZb zyez1Djorrr^%a5n%Dw7uW=x)!9Q<3yK3pkk<1J9imp1fH`J~UcBLS{)yBJiw_^MA| zp*V1_xpNK$xWv^rCgyJq$mA2d*pF|qD7kC{Hq)!-^Va+2`KSHAbQuZndC18aUMz7)@Vu)pWW8s(XReSEDpfAs0NHYgp%0nWgh z;*#CP?@HQa$~C!!zg+>lza)^e#xDuv4Ebe``$qf9fSeZun}HbiIg;+Za)mA80WDD2 zVITWifJ3#?hOejemw)&Kb~*>_A)7ro=LdTZ1?KSjQ{meloJ@IG&6qpZ-g?$)i;ti2 zh(FmSm%r8<(>@X?RpV=C@R;Bo*-TFV_ci!fzAU7DZh(`@)B68uJu+kS;B%i`;v1jJ zR&isO{#sz2+@e#V$9le4b4{Sw)4zw{s@C*!aN*8ov(G*B$(@S*Eosx)_sds%l&P8nF`)CEb99#9)+tX4 zDo^|SM6SxWJ}>EYHpE3vih&sNAHQU2_vcj{js^0sxF+M)0C)VkF2I%cU4bH|)}IK( z&3whSALmEKp6=s8FGtQiH?Wt!+k#rp$2$Y^>h2)J`QhKu5iPZHru%@d;+HOPA6z=N z$*%Kn?t63o>Bbvd%+tFP;Al1A3w!7`u6-m>aEgEN{)G@G|N1jMwTCV~k?EP@OpA}c zdLHCCp2@GjTfknn?hC|9{QL7|y*1NyJwLPTkz?$c1^Q~7&+m%j!{b;>t=tmOjVHQ` z$LZO`n{_xp8k}iumJE4Z>*Xcc&kE$GSn#L()4n<=zU-6p^weE%I9}$T&PTV3Rhx`t#!b#5n%we#-9Sf%Ml@omZ z;Ik@l~@=n7pzBnuD@=c$9 zcP?(s)w5}5+BXH}E(_xBu-5s;xA%Zg2v)~_|8H(_M(@o58$8<&2hOH=(P^H~?7S_o zj-ARaK|MEXjd5J^Q{34=CwX#-FV-#x?3H6|EzsElr43)VcyM=+heJMJ9*}uyAdlFL z17m8>3^}$OuwA~a1*LDQyJb$nIbF(q(IqFBgIT(8B)2vK-0-9F&p7ZKH^&2dkB$A} zPh3|5yjlnRln?x@GjS+w@~!`j@v{U@_5^rS=pv``bv5l-u%;hRci2lF`^3>2rR+4v z&Waa*7XxM18soLbdHt0bemFI`El}iH@r7TYo39IjnBjolx)*S094~y(rhnGwBs}7V zPqzn~fiZh<1uan6_N%e6rJnT+v-e1#RLwu};NQE`U`PK>Mo#(1pL2t0jPP;A46w7t zACWe$%TGMDKw*Qv!cX#WSh-og-kPzuj&nI{WSf{PlhFyMj7PVtDbS zUp~_T>=8#Cu;+n_>1JeAEUM;1#pKt{5EJnLJk(k1pIvJi=P!BXlQ;mMK5c9tOD!*P z34AO$D`|_#iLrJzNpOz=S?)afEMMH!$AjC0x(Bq`w;Zsi?sWUy7yZ6F)6eyA^53p4 zr9a(Y@nm!56d&2jCUhy6?aomx13zV`~n@x2$;7u`x2l1$!kXv6JuxUH) zmNL)Z;-RIj(8-2g-WN~$FHaxW_RiwE?iQT0NB+&?oSuzw4Onzoe6E;2 zPM;??fPvjtAmee@}BWZ9a&L`bZ!S*9N#y+VFKN z4(4znKk%qs+|(VCp&@3Kr0!V8xHu@jaO@nuC!`)u&6gG^_czZEW^a#Olm5Q+ z`QaWcUOe;JhF3hT1?=1#7+3g!Py5vU`FEd?iF0`|O9nf7zo$H8dawrvcj=_qqv(sb zJXAk4kjMO741Os0G=AA&-rS+FZR~IJ`);XDp5s|-zI(F9dOowK?o#Jx3iH#k44sTQ z{bKw-6Jxye?=@^c)BWw9nu5;h*qQie!*9&VvrOH~SI^HW=$($$UO7=QpzAm1=(;3x z^5m7lQv>Ji(!gGEQSJ=1-7hPFcy0#b-U3C=$tN7P;JmR;b#hI~ERN{{@veoHKAZ_^m8p6B|9($zbbR;N0~4$pt=JU$V&g?JTVQtLc+(4O#l^ zbdS-cuPvA6y{j)}?pT1cBY{#iPH-hgzZ1RFoMdR6uk6#`9jpZGDBtZf#+TpAUNY!yfpW`MHE@norEIQRJnC-8S>+r# zcsEux`|Tr(Z7op5X>Wknl67g?_Eubvr!9WgEe6FgzJU%PtIx@wPfqU0nCFyv{yO_& z%$6EElC~mNp<*a}d&Jl-f2%gP*3FT_-twQ_{4vJwXHoh+k%sap0xEY9R3zS+<_Tt#@=Uc{>Uf}CQFUy<-i*Jm@j*+X@NpM+k5%++RqOATA;YU z%^B}ywDgs!t?UNt;b36@A0*}#LwUC^z`sH+d-2a+#Ta|)9x=WeJUu9#?v&r3bEiyw zBm2h!wv@iA&HcZ@V$gHOCg)%!u;#x6inHSUPHnU18-mNadA~!=&+>;4_SHCjCI2~T zEB*Z0?DKxBlwEbE>0;9p0)FGL&bhhD5o1f^9KZB;1iJ(K@$F0)H(xRRnl7g9h0^DK z!2x|@-JcIKb_P?OEn`X>zMiW4vyVqQY7M*CQ@ZY}Z0m8*0;S|Fq%AIGW1TgA6(@Ya zX}xQ;v=w*r-T2Hg}yf;r&p#Wvd$O@Nd=f-$~p1f4fFk8`nAq^0s)8 z4^VfSJCprn{c?Ao;hO(!s=bx}Y<1ohw$6Hov}P%=hdnrNfl_DF+^lx5ZzF5$FFkCv z&);T=Dzdq5qFME1^$WqwA7X6aZ z(pK8=^_0$DzbSsQr?}pkHvP)qbo$9(4RGN5ANtkyoDn-dDP)?jXTjH{4Rton6^@MU z8&mi3Nq2}Ldu|GL1#@V55{77J5Z%4fo6_-0QKZ{G})*PKUq))!krCDaC3$tvtR$*h$cg4~8L&tghoeTMkD@B~m z_wg2I>z*Ev$-e!;fw8SGmgG5qZ2SH0{Na0VfXjX#|2|_J-%L#}J^1YVWIKf-@7Y_w=;nUxoa~8?7e;OBS_)_}Bl&&4YM!-gG zMO>7!zhspkY+DMf?`^9bVADKZ=E%X7Qo3+{ICyWIa0Xrs@7XwB9u|vUo<)$2Gha5NN+&K%@lOZphIexeYTA;|Q9l@@k z_PI~&Ba`0x9!g7FX~Wl3d&wq~J=PXa7pJ`%$QNUHcMgrQvjs{UzMhh|k^Xi%&&~Y) z;6Sht=(Cp%+WeriKkMISTuCjZpy4Tq?Ob7cF{v8bHnRQooHE4n2{o0xq zC~f$9>Y2*_^3}U5|E#|wpqp*h;7D6>uR800I>x8}Ud_~(jjXG@C=UF4Mmnzv=-d~` zvsoO-fBx}lXMl&xf}V%+(OGaN-r(GQfYi z#YXvXFi?JNa_8*Mm>9P};R6o%fg3jU``>aF`*GcKknX*FV?P_G@GR@c%8r(CrH{XJ zePiHRr?6H2c$a%?AokATJQ>@?H``{~d_~5mAg3Rrukw;jEl{Sph9`v|_+am@;M`!A zFJftrdONv&4nJkwb2d4hr89kY{(G>o?`!iJ_k20i87sf}aAMq7ZLyOBxRAf(^7m}z z-q)D&rH455{c4vT?40^HJwN=jzRu6ttUsIcBBua9)t=U+w`GmepBJ`^k^0u4c)l-Z zB->6t&+T(oaYm-P?))dGT`=yM=Y7q3cXSKPD-RBE=#IkOkLHf)?KW?YZ?Bs%*YEXj zllr~#rp}A{sR4VOG5!8M%DM567wq?3Q`{}R{I}=#UHkddY#ZnJpcE(K-#?e=w{NQZ zk)775W@w$_(wN`1Ex+yIH`|Nnsw?MLGROa2f%ZHsW{!{Y!e@MT zv_NUY*Hho`bH-|Y>8>?Ziv@pbZN{I-J3!u67r!1}#u-4sb~h?)c2dI|6)= zfe&lQ;pcRX_c-?2hl`$@d3@Bk^$Wpf;2odcIB$W{hOejQ=%}%(%lH1y-J5mnbf*3y z&K*uoR|}L|wyL3)w-pzDu+6@|%s%7&XI%5Rz)7Eb`t;Sgs2s%KZQJA^P8EL9Rdb4?GOeE+LCoXzrC-r#I%7vHDr z*~lJy*dV{BHm+st;&I;Esg30?8B?7#*K;AKrd+g)DYN7k2OpfnfqgFuyo-Al^OG-l zuXxIXdA2!&{hYn!OMU;Zk1PKxuJzt)tnLP~=G`fMO#gZte|jDGQhFVws|_=!&QUM_ zZ|2CKmjhx{w)3wz)b8WOj(#0(b_Bidzm0Bd)`I0gJ}SKqaWyW#|8CCuURS^V@4NN8 zv%k(~nx}nM>i^#;J2ThEv3y{A3lu)^Rk8ly(8}GDJHvYS0X|AjKi{wajjZqc{@!Wd zfAysQg0X)nvP=KB{LJZp=i2)Nee69t*}pG+cA2;TVKd}?+bFNr{A1pA`aOS|esAMD zCi6crng8DO-QyohEFPCy(f^08Prh8GQ~dtjMCM=p!#(%N@3QIo^zCt9)}A;2{XO^a z-Ltcob!o_k(z7^YkY=6e8pKa$HNuO-x+y3@+-=3ZR1sN~hC(_4T?WgyKQAe%$ z#H5}PUqzh)2CBe%lbY}7fkwp`@yaG^3k4M`JcPHb37bo+3<$!nR5B! z>?xhMk20&@CjIqE|Klh99h3ea|JCU}{Nkkl!|Ai9_^z`M^M^BGu0I>0_MBHuWNc3Q zH%h5Kmn6T-RfV}g9AIbhYkLnwOii`aD=~0%sPoK=a zr{n)S{^ArLa?SgbJ;j5Z)GwaAyXbqStDR5v@>s8qwP%%ace~oNKz(4Wy;tkAP3`kL z`}6T(_i)%>4*;B=Yq zne@MT(*L4K{~76%`J_PonWJnmzan#`yW&;rK5JZu-~X5&)>$XEwXW_NKD;jTWPf(h zbF(+xWN6U)Q@`mI^h$M|KPtY?nv$hxi@e?~XHJdRgR z)VZj=bo}lgpRVI=>EoXba_+TbpKZ?>$LV}_H~#Ey{OWPMbY7mhelMNB{70wj{Ju&5 ztJAmVdE?&A)a;@6iJ4kA+w}X))Z6TH zi2wJOIIjdfub(sWcqrrM6*;Ot7#Mrv$nCScv4@Xib(XFBgZx0dm;FuYvy)By?{oR4 zajyKN%ej2aM8?|K@9lf@ej-efL;@#aO>KHQ5Q- zIsYm9FBr$Gt{nBf3vyP*nr-$CHsycFYfcUt!@-~b)>b^~Y?v>9>rQ`p#*BaYSbt?| z`{m*dzj^A6S>st_j-T)TjZ<@_?+3;)I%@2TGS=rrox2ONhRiP>>*C_yjC<+-+I%>- zMq6Dd+h3hAdYqRBXRTbU97yw=pBVFGX9VvDO4fVx4-v|~FB#`+-D}7G z*NpWyjP*B<^&3)?!{%E?IsM&Z&U?iR^A8WE_AYdH_){{^hVn-|KVy7WkfDEZ*0BAn zgMQsJ-gVDC^cQdDtz&DgW5aJ|UG>vF=Mlen`aSUTzjk{5RO}v{wd6VD>VltVXv-6| z&%Wx)TlbXy^<({{v95P3?>Xk5HP+7`>z9r7*N!!gt$X8Gzj>_RGS)wynqPdpEZ85v z-WmMKFP(ZuzBay*@%o_neCg;f|J+^X>+F5gxXxYuj(4Aa?`@=CIZl@I@uZBAQ?joa z`#7sLyD}y>N>|0J_+`7bbiVOdx9pX-CG(DqO>^iM9e)wKW6OL zy}|ZB{FPI2$0K>h7k_yxuPP57mN9b7{pWE{*>2y780)Ve>o=t) zo9$1GUVDn4f19?xxjI{=uedaSZE${|(Erw8`2Ji3$+>S2_6G+7KEh_e2f6B=SqWO8 zu(|G$mNvhw^(=ltK%ct^)&uj-0$FzliaEtReV$_%#2(M=>A&})&t5v5A$yDO9Nm-O zZ^Xgw;BfHZ$SS+-o7%ORF>&LU!j8qEwdEU|%SSaEtx<0TWIMk#c2nBo;QfiM?tZ@D z`4fWG;O3y#v(fX)9_#N2o*IY`9aA3Yv(9=kZh_Kfj|K@$6&6 z$1ZKjD4ph=3-;2-4*!-g%LcB_)(7$YXW4{%GS&h*$))$>GB+L9pZ?4$L&MLy#9R5< z#CtP!#fGis*#FI$!%y|UK7IE>?fr`Mt!EQkoJn&idHOgfhs@PEt6a{|5F0TQ(~pn+ z&dx;%*!1j(<8r_z92V$)+AzLzkgs3omA+ZX@UVY9^`cJ7v7q`3W1mk~273edq=L^n zOYRr@dt1{T-m7tTJRpPY;sDP_0y=sg=r&fe$kpffhsHLa`A42wpL{iaTRc4UoY$pY za2{{#`ZfMQ))f=)F>L;vz!?9_&a#a?J(ef^e(r&2*V&g>*9Gou{NYth`*~waBg6@} zv+jk;V>wM$3zQm{Gi$+);9~>%ZQYH*V*}jiJ4crX^oY0Ti&&B)o@#5XC386-lWlaL z2<*YLb7!4#XaSjhj?MB#-ic9f<3;J?hVAq_&&qW<&+^|{W%KTUEo`;61xg#fZk;Fl z$+~MCV>4ZcgMYrXb;quzZNE7-mOniY#YeUb>-cM(HFYM~QhjqRP>ivo?zfh<(sOep zeRlR^x2I1gU+3}7j*{E&Z5dbE@b#1pWy_TrUkk*O&p25R__r{&&Fv2k1ab!OAkJ)( zEB$+e=b4zaz&v?mDc0ht^1jAujc3b+Q7$glwLtN#Q|#XiUJ=;C7P-rwOM{08_^Wl! zE<4$@9Pou)>$JsNEthe>vC_WXVvD zF9`;MT=3VYl$ zD*;_{hwMiO#>j4gee~kQ9`g4F=I5=a$9jB;1HX#?7Eb=hzvZL-$`_ABPgS2o-f@Yy`wmj+}z zU-pvCmliApbx+=$Ho5q*?~;IhdND?#~rTVq3kL-Co;wcc|#Lj z=C069p{wkvnoT9!eD5RO^L+fc%(Y;akM7oaKC+Kpn}PVZfDCo{s#f?aUgaO2>$xNs zTcF@;*Brj^)bH>AUmwQZ1)m(y!~e>K;z67?0{#{ky>7WsIaYPcn8L>v@UQr;JlKvS z_a>drS_>3hmHfVDcMB9eTr%OI=hB+8qw4jH_3;-UoLm?vI03fcQVl)>@qu01WH@{H zSR4B>Wq9AXG!3zvzHemc2XvG^y6LMN zuREdg_lC^TZ@oK8vHnE?Szi)}H-9b*Rb78ISm` z^Czw?AZIs4d^w-_R0Y^v$fun>8iPUSC}<-Bh*~ zvt*Fh%kSrU8Rg5dtl!SQ@~h;xtT)CEF;(u540iT1oI|lWlPxE*#$Mc)O?YEN_1)ii zzc%2f`CgZ`b%x|B9_{J5IvXDQSnkdKh#5-p@wB10FysNh6n4?+`<7z264X7H<}j~s zZZlwqJ>?r4<+viA&Qaw}y}zkz3xq%?+!M{HvZ@NiK|Z-^@^!NZwtt!iyXPQW5jyu#X#xvxO}!AoZ|}v`q@)l z%#uf!JHhuxe2>5$_mKGYcLm+n$_ZT1u^h0ud^A_OD({YDjD58~&C~LdO}KdY(!FEQ zGOk!d4&SxOYk{Iq|C6Kqp{ZNIPBkCa1N#*3xD_k$-5b;#pNx^Q642p!wHlO9Ep3HN zIu!Zvp?n_3$ECr+z+8R>>ttTc(nWUZ!FdZ5vg687$j+}?55Es(>;v1#B%}83Py0Yn za@fzmx)V0jp5|5gV;$eg6PL@Ews>GG?!2GzXEkVnQhK#}JM_uBJ-8#Nb-jIT+`8`` zGMq{0(zEx&MMMnt_GcRB?85_2TA;My>z1F_kL^19Y+el5sl5=C{o3HX{Px%;A3s%_ zbJy+&aN+KuU%TSb(pK8=b!(0DgNvnLBPe^wmSgPs?&O2#&(3iy)j4nIas-E~0UOQ_ z+;^Kn3zVk>#>i)53zXjeySIi0`<*9y*sb(>U)AZAKlJ*nUT26*`LrB|*lgY%WgHjA z%CB2HS>~;^cO`q}U>{Su*iHs{`o(Q=)-tBF;p-`Wcc)K&<=;(d7jReY`%6#gVAJsP=uSm$UDY<6g4a#5VTGE6?ZhfvqiA2-e5C z_K44{J!I9h>`2{av&tV{B1o<&*Dwx<6Ng7AUx< zx9r}LHn^|FCGh;JJBw@fonk@}%F-JrHdE(|4!i-APX1#`(QGz&S4X?b$${JHfrNIkv4eer2#6&{g~89zC_bmm%+3ptRxZ zmi~HPlzcXbvDhig0Uh?Ui|*+?)-tBF;pnm}0ziZeD>oCDQbi^g?gz%E>~*L!u@ zTXC=X;;i&%`CvagHUqL+py)S^ls0_bvY(%d@A*_5`Onrpb8NNF{X###wzJc`brE%v zr!?=go$e%D9th42lw*OIyB~0*ja&Bne6$)oJrD=_Zwqi@-@gcs1Pb33oHvb>^?)2j z{*qmFosT*X>g|x}VK13-XCv6o4)*Q}l+vlLJy)j9U$Jwp%O7Laubf!O*jm6BF(a29 z=LW^6HOgIqae9o2YyOGg$=_KvmS0~z?eB%iHGA-`?Of`=DeKtajN@)~tV^c#6|dUI z#@A#YF4^FW@~7nJ?+#jE4?ons9~*p@GY=Kfb`|p8^3Hxpf zo)Rns&kdYOcC|o`R*cIgTqwr^I>eFRof1@xwE&xU0Qv z*%`1|`=Wpj?Nz0U;BO5UNg@x|tMn(H~h-LvD2ywslc z9LK>U!$C{UKeh6LpasPp9u)brnl~i=eYA0Xbi&!{J)5=nRpvb1C1)e{tq0<8Ti4#7 zcAZ1{m9 z`ncn!w`Dc`$4|!k`Df0Ud(k*XuJiEdfL`Z75kEG{>uUmB(DU@5xU{$Kd+V<)Z}WuJSvG>K53%n1_odBt_TC*R|7T$Acu;3oHqkK)_xHI@hkSo|ps=Cz z{ZqUvW}W%7y+3B{y}x5(Ajfehuka}Ea3_DA8^xG@-34;j9^VfTGx?44TLYg7t@X~V z821_Ss=&`a$uz$+*b%V3-Ye9P4&>}o;C%EtH^wnG*E!IJ%4a_P{C$A4HE%sWoT1(~ zHZ2Bp8m~P2Napo7Mvp=tKmRG`bmei?_cu51?>_Ob``|OuR{ESKSDD7{{@y+G&4L_p zMh*qjbG4E&WqPih2YW6LL?krGp%$-Z|Kb zo5R5sal~`J|NehVUtwSEtT`hq=ZCN}aa(ra=)zzraOeN|*w!~!aj-_)KDD*% zP^_!9?!H;SbK*HP#qx}?>6)|c*Vzycauqh62)3R(i$fe2(}#ZjMd^pKlV=@wK$coA zXP2~rF|yw@l0#ZcAoC3-)wZ=KwK-1VkwS%99XaY!r)Bn zpOZCL2fkPA9m0L+y!qLwvKrhN$oX2wj#=xhvNae9~+dek5Btd z`{amykL>ncw#`0gk-qE3+TP`$bh^*x>FoDbUh%E=y06Y=FFEvz8}#|CuNcFn`))lj zemJmKJdOr+cYb;j*xm6dso7<2*4-(0o)-L5e!sas_MJEbUX=OQ25$&{D0o+Jrafnx z|D(vbz(tTEHoqG<2J-shWBXX@x<4;UTQOF-Z@azDk|GXup3JQT^22xwwO7;p4+dqcyI#AuE8St;ca3x8lwI&j{8wfEY~{O~$o%|KruNIm_B`%x&-~fScOQ}Yj8Uex zbEnLc|CyOPTlwx1GR02OJ~Fhn#_k&1@w7{;p*QV8NL4AzjM2}x(gRGHt#MxFLQFb-u>L2CC|H`qOSKYYabI_ znTI8rcxr)Sow-M6jyz>&aBygC{f>@U0cQ}h4&Z%_aGYyWcW9~$?kI_FLK zW}CXk$o->?k)b?nBIASkrbExkPfq$ToAe)^KAXxvXR6*|>pfL%UX25Ft<#2!#(LLS zUpm&F-{vnL>y^}eVIvtI%HI(G-2B4ZtAlR}UX)+l`}e^=``|tI`2QjN*PwiT=U<=h z+jpc-ws*b@f?f~(Vq@%~W6e)}aZ?xAcx_-_k^7!8^5UAr&bhlWhpKW^3^oFsv_PR> zjO9kfx}~jb1}!kRKGyR1lOx-{K3@6r*{6L!(^({sPJ7i;JILol3zRl|-OBM#i4M8V z4`nr=PdqLT#LKgo4ENnEIe09eN|*bG-0AOblsN8Zj7e=L=a|dBp}`7ad!9aNc0QxPM~s#lh=?9}S%8PhHyLs{cODX2$VYXQ-vE(BF^I z?M}o&3zRl|-QpNeit`9$UK#YhTJvr36$gOBeStHt@I{;b?ri?aEoaMk)$RhE;(9G` zSF8p#U-gw4TMopg;!wH|W{gk2l<$@Cb&J1;4C|NE2Y0Rd{^H#1<Pj!l6#fMJ!^Hiri z;p43M^tSc3RD6mTaiY6yqHA|B&!$Wb>ns1NrbCY4*53WWfq;)d$MpQT0}6Q7c77fk zsttoZDy3ES}Br8(*dC{_x7y z;!9pSXZ*y$oe4<(8}!SSrv^I$>u`o!ZR=a0)VR+9WaHj^-Kn>y-QTO?hWql{dj6CR z{qKCXj4P!>`y;u&=Y^lnQN>K%KbH@se{Jy9!G8^K!!~*0EL}R*&hgR+ImB1-#SaeX z(8e8}mIIvEeYlx+%~!seXHU)Hv(~81uLZ{GV~_R5qR*IYHIR73u`Zw$EeYDKeO^>#+9?-uK&?i?82Fi`y z`vOkbQn{oS6SDevP4l5;UZKZ&e&N7Av7U0&GNx?jV>=5UXXVQN$UP9S1L)^h|4!pR zyES-i@b$ru2jVM_b_e#cUtUc4ukrG0-tRaciTy46<%t^i&VYSnTpLtg$O!bvnyBy$=Y_^cce&zL@{nPx_XOlgZ!=Z-F{bMU$+1|hB;MX}= zkACCMhQ6G!eouhkje!5`R@>+NpV!%Ke0PA0r1Oyf^i9u}JU^NR@^QPnO}thD`o(rL zU}N2@i)mjMxUa4Ad{MVRVb64oJ!DPCJ+EfjdF(9g#FPAKfwCSL+aDYV@Z^jik1XTt z|DND^!QNm;fM2|vn4>RK!``NmLQd02vG2OiqFje*UpOg z72j&-X}CACm+aNx>47|vzwEAf7q3S$rntYH7xBsVK`wb>fUiMrYW9iS?EzWhrl!B{ zv*onuH)ikMfnqNkJge#8=k;me#M%}pY%zC3=IHG?u=dmEj6Y$<_-59#ahfkUoQ{dp zbd0{wh}@Q%Pvqfc*19K-`nNkL^Y%||T!;=fTHimH=oUNUco)|eD8|HdF(7ZcxAu_h zeL);spz!laOIv);vY+0my!DKcRk=%V>82l?-PJ%G>;1|-5LLtX2Hah>Uw)h$*jM>> zN!s>5HIR$e)I2+_=SRiE8IhYkXY6!O+PfL>WqPN~$_Jc0IXc)fixawD5X{n5J}qQk zE`R1Ir_W_M&ldJ;i>n+w8qitaw_@9^0sryf^VLQ`fBD_gR;-zh@#C|$@uR<=*0WYj z=E-O8RQ^1jpS_JvKD9u-8O)L~@1B3kHgfBZ>|-*^zlx9ixhe4Mlp}0$HtI7`pSPZ; za&hXvT$+yI{KjqUG$VvJ^emc7Se~a z<&`|XSl@p?prx;DXTSO8OG^3P`@}YJR`|=V;z#W)Sfj4(0_~iGfy@P>!zS{SwoQ}|Ni`}-+IrGdiO5f z{C{bFE}v?c!&S|Rjg7;s>4lzoqkkJ$-xk2M5M>s^MIoo0EWd_bv|B0&DGIqw?rLeDw3b;T?W|q+(&r z`6a_yc}Db_o4&uwuPXy`*>YY?y=3D7AWS91dG9XAXmtIRs`^`Ka2M9(fi=Bpk&ffv98ZF zcqrR%PuqRSUZ9hl7AR92qI$R+$)(3U-FPaUEp5db99skZJpZ?gi8(Uyi*L5EnT&k_ zE)+IYPB`0i7VJ^jFyw!XH?}9hsk}5-=h|FxMTT?T-zPPKodFre34Y4Y($g}gSZ|EYEs%TonZ}M?e2{++3g{MV{^5~7Yk@VzA3Jvjmj~9E zI}ylp{MYAHwf%VXoaEzjKo723ps>N5LbiU-l{VPJHZoU(&48U^OQtewKMnxbH%E}R zb(I6y!q>_;{=C#L3BEq~f#5xXF<8ic^_8jlj|aTq%~>gk(Q<$rcGFk+l&yoVmRd~s zTlSM<%pU7s8UeLle=WE;;D5!y`lYdN|Ak|_YH{f8v0mJIn{a|hoG9c#apeCiSH7K> z@oK9t3CJoxwOgQw*Y!bt=G{o!`xBpb1az>az|OV69RJQ{O_mM%ix2+d1IWjN_Oxbu z3zR88_TkAIXH0x>E>9|s#&!qRZ3g|FxSl?q6ns3;wy|OQtomr%FpD2HToK$?UUp^A z(ugy~43`H3WpR8@@gA_4KD~V`<)nOIQ^nC_~fM?60M+Gu_*cUtq8E@~ty$Xc?D>^36TuS^qCXBt8AJ-rZbW z)O~O$W8~U@OJpykX1}v2j&dEJYMdB@im&n8gK6HggWUcd2hV&4Ha>f_v44MKhce{| zhd59U&fws1#-9^;Ewxy#2lOaYS^5V8@x?!W`Gy`kqpPI4f3^S+l3qSSjkt_HFb`{uD<9OEo%zz%Tk}rFL#h@RvpHJ5C!*fJ2uD=$@ zxxIm@S$p}=0)=mQnYXTw(OYJGcDOG(ds*N9VaO`qr@mI4_QxN&z$f4@JAWgD=!^Gl zi8s!Te^2ndfV?aja;;?G2E&}2YZSmS2kV#*~b~Wu5Si`=>;Od~h?@?o= zkGzdwGbmY}wYLUr^X{j#z?rayJ@xL?(pK#E4mDlhGNzbkQwzvd*BM(#d!9Yp$z#KI z^Jk-v?n40{ly6R+;HJM1L~f!=XKHJZay15c;5)fqf6Z8#kiCgHo+?9UM<@1(ibD3qQJvV>@S|!@?$gP)O#d( z?8mWv&h7JKUrUWMwL&)Et!+W&F~4xb7C*D4PuvtX7y6f1sjB-f&Jylc0&-{Vqg%NksNC_+ zZjZg?`};@V@gok`1#FSeY)~p!$g)>%PVL&r7+YGPSX=pLKYL1!8c!`y*bijanwBv?xHaKBcbcz&%0HwWyr-m{DSY_q-W=KXYcfYa-P(ml;3`f+bx|6JTizxMVvY17s7>^_v|bropb7u`-#fv>Hu$E5eNN&g{r43)V z_%+5xW7gPndob&{;rspkr@zjon(g+upLYjhwKu?*!tR~H8M&d_F%D=J;u^+{3QCrSrM~KQ9UXUGT%f z`vPNdaW<=urd~*m3vqCNuvJ{iW?#K`l1qMXv$ZX-m%WRDLLR%UoxYb|l`-)k&pz?# zb&;_<5G!)j^y1InrNDe|t2l0FS129|d1V{U{Jg;P4XmlQTJEurZN-On3luRle|_My z-9oSt*c)1hK3&$ZRea^Gb+g7Zd{UQrI_YpHs4KSGI9mSCPwoAY8Q4=?3|JBAI$>KV%y{INq`nP->r7AR$BzprJS4Qj<2w(_k7Y*kxB??P~M zz)tq!*Bm|e+!1((kZtDFEHNKWMTUG<>`uC&7^p#t-s^RB3*3{?Vy=hy6 zqXPlEaApn8#Hr#S?!}oL#nY<-c6v^WF~0$Sd?{XA+C4wy@^ktgb798f)=7W$cLz@i z0bk^b+=bOZ9L=$1$_?AgE;en9Yvz3p z&Gbnf*5eBYV(v|B*#dSIPGR-IWj z(8p)K;*LBvS*yM_pi?PX<^Mv)z~0(_a2)%+a9rHUaXQL3zU&RePjN=fDR`*!sy2rg zdf0Sjz{c`}jrQQEY-MlR+V9(wadYkp+&nrkW{pA@4wT*wvHJ43zSoHB)qoAwva@nh+qtGw z`=X$DeMQ>z`nePP-1Fwd)t;k4`N9Xf&Et=KJrABOy?sa0SK9D(Ydx9Q2hR;kF5Ziy zKIXlw$7PLTk8@gfh;!+=C2c;Gj5LSO+WP!f@YMH@P5S)p=h^G-Q1Z_W?sa#F!GS=& ztORne-}BzH*u$rO&o7_F9{l%ve)25#u(5JR4wmiouLk1xq+m1P2af5{FaF7}-dgW8 z^*m6UQ=3;?Q|A!>?A;SP#mJm|O!r=AU|+_a0ejrB6>IYQGr2U*%SZC??_GxN-eq2# z1&34H*8-(-#5(fpy{7DAllH7L^6R7Rbw;d{FL=Bra2ECi^zRQ21lE8t>;BH76nvLI zPWxi|{86*rxi8Mytk8v9_p|+cdr3C6)Yh*D_D^-Y6TUwvdr#@z`hT2#X6Bw1{Hx%# z!Rv!>4;1I4^s@h(Vt?r;$6U!)*))!~4{1lUwz-N$WM~`!kH#+F{ z|E^T{&L?s=0y$PPTH4BHV9%4|w0ool3uBEdy416{uK3D*{;RJH=w(j}6nw|bL9TWD zh1yeg`+o?MxjP_dZ{RLvPwngF8)G{TE>B&)v7==6KkIB6S1SJ6Wc2p4%NeQtY{Grn zRK8hrMWEjT<-Yj2E9*<vLhpcz-OcH* z2jb2yxmUS;N80k)o{hjd^Ge-U)|RejBIN}^3#{D?$o2l}3EhxLv9L@~;ozD;V|I;d##ZA>MV~V`3v8tPi6wd==VmF=RU+d=hr?2$q zN!xoao4=~ zH;ez``ov$I`uD33&c7#RcQ4m7!+!U|^YZeEmoJQsm1pFv1e?L_L52d_2vEBTwuz09|#&*qZ(|D=CG`nWG1_|fy>OugrWr~I|o zdHBL{tYkeuef#)WV{7BsYB%;%;SsmiC{IhDjrQ&x>)m5r`BS#pXWb=Z?VZE@ZCqhH z8P^0a4-wuQ-g7~|q`3dRTez3mWB6#$0%bkGv+|KxyFYRd1a!dD0v6Z12D|0N6M|<2 zpBKC_3x6m0KyYqI|L4J4aAnYfn}XYdFADy3polNOD!=5zYT(%*mh!yv&GU*ae7Akt z#si+N3|0a%aVuVAmM*n5##%sDFVjAExX&@_9dd{L z^&Ztf=X=|FAK5VV>0rkA^X0k!rvA5#~oPX!$fdakmiZ=(&02?Y7>8SZPrM(!`-60>m z!!D&>4eXK6*3=o38*-$V^DSeaE_(k%pzyQ!_=dEne8_Rdy2`PSBp+W8J;g`GWI1EX zlp{X#<@R7lQ0HhCNBC3t;ki}kSi6m5c*7;$O7>?>`cEAD#p4a>PdTGQQGYZzbI%uN zvvO!9^ZeN^hc3+gM&RzMJZfnx?lry`_uOj%o~+fz;jEma6PIi&j_ST-)AVj*Ukk`4 z&;IfYkJkm_TzRpSw!$_xR!qzO(oOD(Zq328*|R$1=fdoh^L3Y3uGF57nX#w8@0~lP zIP2|d8TUMz`o=!C&*G$Vx@Dff_Ocx>?5w@3XWjGcvf9|cKl|9x@2gyz>a0Ae9H^WUV>YU5Om48zb6(ud^*ZMH)UvM5%&b_> z%LDRyKIU=j`>s_uT2)DJS-|;KFWgnkT>C;2n2Qz!!y`-g)oOn0FYrhO_H? zE#9};_lV%@gZ~tK=UBfzHT+`m+aune`fq}N2tGE4&Ac`{Lq&d^0<64&i5U` zN?_kj!G!@naLmUi1lBmW@{=Fry?AV2pSteUo72Xf{fC3|f?9t^+MYxDbk}{%u3ndX z*%z=!@!7ywZ@WGlHUo0`>JC+UpUi(zP|rVlD>i&$>tdjgXYOEN-7~xQY_{-U5yO(f z4yDHC<%D_n#m*0WiN{j@&-pOQ1sc}0)?D;{FjftOk?wMMcyhEliDX=&K+j%{oe7Z<2bqQ zReQ@GQ~a(oI34$lsC|{M#>BCFukodf;rNPx%xbfd-S+gd>TJxCWo#qxzD(|8f;-Z1 zcI9gelsbcSmL6QttsD#7?d+Mx#k%6`fnL|&qlcpBk-@cr`}7B+^k;%!2|g}{J}h`t zaBc9!;46Z!3*H!ffACYmF9hyD@xu)sD@VkvzYFWGo1Qrc)YhI7w-eksQ4J%F6WfUegEv-0z* zjLRSUrsvSRbmiYl+V$?_{m35g&kqe&gZ}p&UYNf7$r`9TWGQX;XX&YTC35()8F(JF zKylx^BAZ(3^8$LU>1D5{-@ilkK0hOKegElWzxc-sy?k_+I5Tx7@#;+TTf4ZwEN$iP zz+U}XyjBeBtdl?QoQsil&barxd40C9uViZ99!&YbRqxla^ym45Q+$+6eLPfuo{k4~ z``F#&hhSxbj=CO+bHVXzd~ zhff?Rb%x00A3v4yV`@|R+_HweS)9;0<%B(Sw?N@r@57PwolWv8zT3$u`S$U*w`116 zT3>cl-+n&z``Jb2(*m~wULOcJ)8bRyuB1(O+0xQxUvW@ti}Si;UXwM7wMy;R?`602 zOWtDIinV)!9Xcuf`qESKTIR*6=ce-U|6}h?;4H1mJMlvoNE2KMtBPIKT|h60+AIcC zxJ@@pyKjIjirC%IU_&E|5fl-@C2q+$6BC`p?3w6f(@b`gF~(q$F*8Xti6#?G%$VIJ z8OpaEb_1>y#KxY0k|MTJ3XM6VNIp=-vt?r^|@Tg^a`ncokW!L+B)t-4T zx2G*TMxjx=JzeRTRF}OB_6+N*zV8uN4SneTdrB>w5Rf?&oR^>RUz5KZzz6=# z1xx8rBi=2Ck1TaTInmBN=E7bo+ zw&GP|)m!)d0L%npxG&FwBSXJ0&k8Z}Zh2au(ciz5*S_x=w6e2mg^hd{3%;up=l#$? zJltD#F44%Z^Wsd9b!{7OPtR`p>Mn40mb!<~);;9D?{zuL#|QLi?g_2z#@pMyJM&it ze1A|-v9B8Ei+hI;8rw^jxjYpu-P({wZ0{}4vEePb)8vT1c5cAVp*_Xd%VM_}*&78~ zEe$w!%dwNTDhT|HNOXqL6Ue9oRl`Cs}Ek9~~ zb=Jg7-HJ<%*(twx$_6~nn|hlh%NoC&6LL=pUYUW~5mTKvxn#P0Io zoq=c0dxD=1J`#K^_;m2)z%RZyGy(G6pfhGpE|`q%wJp>H#EHrwC0-vG(XfmQ_7c7)(;GNTT0F}zwyZbkY^Z| z^1HX;)(JN7ulz4t{T7w=<-buX7n!-PZliS32(N=fm<(?{0Z+Ag=ry+In!- zJeQsli0`8UG*1r>2-Fd~*sZtce5s>JvesnXbIkiTI`8c6B0kY2Zra1TxE-4LY(O6x zG7bymPLA=@<^8?t0Z+xMm;1TybA2yYjLENOsIhyBj*8dK8H<-aP&ZV%?$v2= z+7_D1XX#29meggRE;=>3G_v@sFB|J@@!j3*&c){(q8;8hb?*%Od;30gbaZHJ5-ag3 zf8AyBt*JFNzB?EN8r%E0siAd2)#kAo_s^Q%pHcRPKHS?mz4a`h8Z> zLGP=$@s*#N`m6ootNA2;G(A5(MPIdE^HKK5*cW=W*3;L0Tr%l!my_Guj<2^xzWDB0 zc3@!M%k62)?onvuqo*q!!#fjCFJn@y?(O#@z1-fmLp$5tX>=YCs4wrR?HThw?Sp&rN6b5ODc;wH-gDyiqwe`GPk`r%c+tZbkbgC_uFY>t zFDCZ31kTN?^ZHpvhO=2Yi2@D7Q|&fV9$x&dhP4&^>gFbwzYJNwj7l4TsLRlxxt}r{i^hJ zcV{@Zla1Or!SK!y@8R0ktntI&EAqMZ|0M8XCHAb8ZY8oN(Zq~#t*R04S(?146HR?o z+{Lqx@s4i4uhG0_jqgMEh`Z(ZK*MjX`a3cv+h+|ta(HK8O+Dz#4(|+gF0I+K_RwG{ z-l998@svEWRs|)~&ntX>t)D}PyK@4y#%|Alz4PVs*};KU=g62J==5_z-4*0t7Puq& zxb6#mA7{Ri{i2{gukop9j6n|QFs|5pPL*AHH0uJkq2>2&0UgFZ&(vJZ#RM%LHK7-i zQJ|d~+_C!ZdA++;{QI8#QJ{&7+~1#e+}YVt^4;tF=7*YekHbm9d~iVEj;dJBWDMfu z?layR;1x^je8eYyVkBPfWMdGglC5sm1Z`C!DBJ1}iPQ@c8rDtb1&hV@3s=Ur*&sjPq zV5d5`HIQe%iHUgH-yZO(xBab|zavp8 z@WS99g2yGPKNOsiB#=vgmdD>|9hshfYwlDz^79bB%EO@nTKO|pAA5u0*+WnE#evw6 zsh*q}yyV{;@Rwf~1&0OpLX{GKJ}guF3RT{+BYOObiOax9jps_x&tzw3(&r?(avWqFLHsm|9!afqB*Bp-;>M! zt%2ALpOMfjN8GM_$>7PaM?ADA4Y28_1@cTyc;eb{yY& zXARA^pllo3RO@?Z$ZGC`e zN5CgB=95}cBmM9Es5#%x4V)FUY=Wx-_Ns%j#ThgfBk?#RP#+q7)1Dc0lns5Iiq$9( zAHAkd=%r&*pnY5Sb62!$gGu!yZ|a*q_Opp!MK8Ad2YAnEefd*+HRm6GcCQOI2eZL2 zZ)^pz(W9FW(8&dTWYu|P|M0xZQ}6E?oxf$jGc2!94C?Qik~s?0K;=_D&XSA1f?jw6CiZGPPZ{)%OtBlFEc z#X`?Uah(a|@6Gu;te*-V6?xXm20eSpIzHepJGKVodPdj3t$K0B-c{Zm>1lXz;|0&_L(yossr9M;DkYvL_O;%qE` z^Fg-9aqoE^mBpc+!$YTS3nuA#Xn5#R3*N8hf_>5XFNxt$r+ZMFrt@#YQ#$J%U{C1P z*C^2T#fCqeV8dMtV(t<1U+C8QSg>Er|5M~>TZ4+ZJh?y6zom`M(Nx_(&_8Q?N_2m% zuqCpuUZMQH_RbEExX7Wrt0#Aada~wT7E2+vFTY}VX5c+%6liGb{w1&Gn=_sbQm*6s zw0Muod=zMC<%HfEpH!D>s_L>oqr-Dnbx$51^Uc9*Fg!Oy8<#tyUyF0&nKTNteLXj4r@s4~ zZOL58_vhvnW629^{j+8Ntb4Yc90t!kdzS^q&Wl)hcly8W8S=FFw6ABOK0k@8`%!#6 zANtx8OM5G-BaHI<7W^*3UnIddD}#ugT_9K(Ins(NBpl2KmGjf z>%R71K9KLuao^1~dS}sj7c+5|Z~LP_vv1F{kzY0M^W&akll-#jqUbc2BlGjyoGIqd z$zYhjtFx~0qw;t8cx4#RuU-B&F)(dk^7ojDJS)%NL&LvR{vI@te@*Ng=1{Er9HO~D z^7v+^W-!qOnFU%Nd1Z1k~lcqYV|-R}#Gw+7!3_)f)p z(_A2KV(C8d4vA(IXlOveBY4y zs-TbMiJ5Cd--_p!>>0D$IqGZ0-wp8o>YTcRdw=TeXL%fh>YeS8Nt&394ANF|U$cFD z{?qfbYm3leE5-!YlVSnSx$UimsL(B=a9ayN|vt?bhGv8IO%KFHTl z&M0em^x9H#_;Kf$YN1xhJvI2I)pzsr!QEYZZ|e5$4;w0e^24`jHE3Vl^nE+{E&;ILqIz(2K%j{H%eSyNw7_X1t~slCk^&j#Z3n1CPbBaL$zTRAH`Du(-KkKN^meLAhXH~8WIr6(qM>>0C(KYbqiwURd}F5a`mg%19fpZuwD z<+OZRiJgBn#ZLZ-57}bG&RSc_&Z9zCc9w5tpE%d}-q`w=16$QQIWP+R>_o58U3OPp z*4pOm%?E12nmEb1SUx7GyceG}@APv)ooTf!K6tz@(oG&Y@-JUA0XqD0wl-iZonpB+ zu%|}sSyvxu$*%e4jOPRL*|e{6d!2kM{U>MaUL{-Y^F=JwCmy~G{gp$u*&p8hC6`a= zCdG^WcLel2FIW?Jmhz2leLTum@whf1AHSY_J*Y?Wj4Oxe)&-k`*?@eq?X$~Rt@5R0 z*`tSV)<=OxuDpx_Z8ZM#ZW-G%=SSsS+{hdSTJiV3)ta84^cvS)$LGz#Y`}K%@E;zm z4eBm>e#RFC@~95gl`$LCp}d;&2Q5EN3ErH6XDxlBK)WQsUpc{hRWP)hZNr$e-MXG_ z{XU&!i0d#XyR$Y5G&Ga)L#Fjfd13D;&_?4w7v#w8_JA*9Hxq~n8%KdgZq=A`TJy~r z&j#YomsJ7Vs$Qz@t@pJ=pSC_=FP-@4N5@xly3E?JjQDRu{4)o;IqEhU9!nCwnq-T_^>1B^Rs&}uY4V! zbvlm-@bL-XVS&7s-~4nZi~`L%+UnU+2Xu5*&%YY?yzzx{)Af}!ujIk|TPntS5PAdly-xMNlYI|DH;8h-5xYX6FiE1oaQSUl@6JId)-_iPd=%Gp!RBB#z&p$-ezs|&@t+H|ZmqAksv~lXj@{qV+1>lp zkJ+VGdpphh`=+;X$Qu=l^|`GZaAx)H*#7V1Rjqjbksfkn#_QXfI5`h!*>iJnK|r_X=fBE;js4$CL$7&`%B@(j zjb6TzV_wgX49E9H#aLeDioJ6IeQN^G1nc&#vk47bt_{c>1?cqJp1?cnDA4e_KVcMT z;x{r#vwu=BABYK=+Uo=JqXP2j7H7VW0`30LRX(zbkCku!&jez~_T_X}u5W96=44er z%2=!TjmEQuIp4%!HsEvRp3Vb1htxDSpC=-yYkWRks{+{zu> z<^q0+k99WV*Ry#(U^9DG1s4WRpfd2AxKJoohG@=-*TLiw(iX0BuiS_8*XSxxjl; zQ1XYoe337*jOi=C*l*A0vo!%(_<@i5ijRA{*4R25uwi#F3N*fvtv@-)U(fnV*(Em4 z*m5*{T_2ELF)#-4FAU>gz2ZO*eLa80!I|MJJF9;A=-oyQ!?xC!pX8O^y&0bwuxAu# z;s#q=&-eT<4i|k_E9m(}R@r6z#GwE8i0q{6MS+;hkIxNg*-p+}KxX+NW^9%p>y;-E>?TD3As|FB-k<#Y9A2iu1J4{bOqG^0T4ZIJuA_r$)Bxw!N(7gPGHr+=t-Qtrg4 zFo*lRq6TS`!YV`pAE>~9a!^jA)b|sQO4T(Ks+`C8w2&I*2q}So{BGH z9-K9Hvw{EYM&hXrKtjs0Q|YFQhN|6Gt$ytRKsx4%AP`ZQxc zYiztI@DBX^K>jZc(29M<06qQeSR1el&CbBt$*aityXlKFCWpVpo8jUeaC64aGhTk7 zEnB?fR?TEMwo^TA2;{~X@T+6vZ2_C>KD;(#=V)CZ4r*>|z!vZRYWw&=J-7$!_mx#l zN|!p&iubgI={N>rc0y1zpN#KpIX95Ys{?w?>Dd$HuXBIpy7cU1oBo{OszB`)t+*MB z&)$G6e76M=G5)uV_{%S{t&;)vwgehGofYc`1!SumbutPxYhq$eEY0P8Hedrg-x%;! z&NaHr9`fiJ1sYvv2iCRG_|FADYb@5{qD`YOnhl|m`Mn+xi5HekD) zKRbqdmf_nPu$wQp2I{DMIyK{e9f70t+K|5d>3g=15T~(M?zI}1?W?lJ_T7Ql^)fOY z&)GCGNmI`wgEV&in`ReZM}cPjTeCi-ea8e^H6k9PfQmf|mqW1nT_S;QHX@!7ah7gVzSH z58f2KEqHtIj^JIvyMylyelU1%@T0-|gP#gM5PT^3jo@R!CxcH1pAEhcd^z}^!TxcA z-9B^s9nwz<{2iDpgIj~w1#b<0DfqSEw}MXwe;oWp@HfFf1p7zE!GZtx@X^6sur;_a zxH5XgQ2a6-&*iP3J7@j;p@X?v>-W`rKX)JY^Fs%7_iDed?)$m>zn>q`%}>er+g9Jb zZ~pCr`8x;mcMazMb};{r!TdW1^LG#C-_^~<(^*>|R6HNl&DrvGdhGJ4TuJxyy7>cAv9;z0Y00-siAiKRlE2t=7LT z1NXZ+bPtXK_aeHw3#{|eJIRpW`kE>0vlG_c3338-ix2%T^s8j54Q(j% z-*G;_9ql5X6b@P3Z>)$@F4@3F=zQO$c-8@&{_*wK5 zSrb#X%kS}lnAZM(n6e*|F^_to57fzApsCr~bC26UDB$l;Haq0l{HMBkruX2*_u-&; zf4ZZ^`!n4<)34&i_mctIpY3SPf3BOCzdxU~rQ-2{W%hqznf+f}X8%7fv;Vwn(hoYear z9a^2gI(ziu|IP3}KmEaN{#$Kccj<4pIp5u3!)KwjdPa)LB;OCndf7vc#vT!L$1DXg zUTVMJBXL`Be&Ah7lRtNvJc+w~HrHoZero7EAGP&?IPGX-F}x@cv%>?l{H$2W@!H_x z052cagxbY}zVscLvABOMaqZ()wKS|Day}l~;kx-S=UE#6jH!<`TP_Hm6Bx5a9K`?s zrhk+1l=!m}YzduMi-o$EANf@ml`Hk3X5`do(c^-84x*{GNp*cr_Qm)1K-`@x^5t56 z%>|=Ct2(of_TLA_m7|jJeOc4)Sm?&K^geuN)@K4f&`s9c1FdBJzn*XLk?-dUN?OI` z+>CR)7V|aASgx(hZ=Xx^g93TOvookWL!Q?J-jV65b?-rHrsQ3fv9+qP*^J38e)ozw zel_YID_(r`sxf0c>U1{1<1@*&fIj?vt?kZy6ll|G5udsuORV^6t|ra-Rdr`=njCZ+ zf{g(mG&ZBx({p>EPLB@I+!1JWk}Zy-K%<*4TJhDredogR_+FmG$6jq3AARhVk5Qn} zNB(fVVxcA~&Ra9)4?H?p8}Jj{6E){|<$OM4F_yn!oa9=L@z4yJArB@QnSP)eFzf{yE9!NioM?F*j!K?SUGNn6X`Vq}S|grOUXdHScNp zRJ82+-DT_&Ct!mbkjJu3EYy*8zKB`j?2O$P+k)M}8A0W+^k-@86IyL+AWz-}M(H0& zcwYDVhVy>Uxb~|b?%$hv#Ex?#N1FGl{^zRh<58fAA-cYP%+<(q+n#v3A1bD7eW0-A z0o1jWPyL;sZZ&Z+t~2cntqR0ctrw4Ys(WYsh+q_G=+JB8ec5=lAa`HmeSgL2yx6c* z9GdYXHOn>2ksGhse9GC#C#w(?wQKPC}XW;7|RhE z(DS*IG&y?acy#Y_G%Ys!x_*D3_<@PyRow!tN#edY|RPo)BxtPuc;#}t;!$n$a zBMWK8SNGDYtbsdTjy(^&Ptm0Z_gwufbzR2%(a4$!e9nDMz)oYl_RMz#RWr`srnc_q z$0gTuXxg}RsZYGxZ-d>&gr@1LKSz5H=@AE_2UhX^Eym-)l zAw2#3iGP02`5l>;T_;cA|NMadz`wYg{^0}tf12Mj)!XyB%=!7?fG_lj_bFMItMc`w z`AbkmXH7m2$=dGplVbmg_Wu$o{vXI3tsJ~95YM^b)Zq74-z}q;*W3BBfxIv0FDCW- zpBc=5I`cy!n-AVc>a&WTA9_CP`K>QHV{mury*KNRY5khkv)}r<)*svY<6FP6^>T~u z#MVC{y)}25TK=Q_gRyVOUv4@#xH4Ky%m7b6W6;2=-ifX^Lz^ zTUQI42_=u8ag~Zoil-MDEpACZ3^W7 zi|xKvE7p$-@Mz@z;XcT%x{*uIoo58+2QLhE1=j>O1-AyT3*H)hYw(@H4+K9F{ABP8 z!LJ0r5&TZ@hrwrq&jnu&{y8`>#y=!DJn;K}Hv}gIPYKQq{OtddV0UnR@T%aOg6|K0 zH26U9>%k|2&jw!z{QQ3=$#_U`WH1+O3Qh^m47LZC1iOOkgC7olD)?YJG3(M?(ahd(US!Vxlm)ZaC%j|z?nf)&>v;TL??EjBt_Wyo~{T$83 zyZ9eM=Wg!LnY-@5pr`xC71I6B71I6F3hDlNg>?V2Lb|UkL$@t{_s=R1mWK@DGoQJ8 z-7}+)(f*-bNi0__LpQWxW*HmYhX;gacwesV?6bG2%`eS6wS0S@3ETKPResRxId$MN z_SJLzK`Wr6$LAu?ZL$vv&r0GsDeKE3uLMLqfZfoIiMl zbPrh}-9uMM_plYxJ$!|9k60nyp(~{O`W4b0wgjEJ*4~xRd~zY5>fL+4T9r$=Iy^F# zdVlQC@)1kutFzMI6Gw)AB{k!{&bq8eB~@36?_~Q2wEd%(*?;6R z`;S^?-~ZcTDgDPRvERq=F`-+@*;umzI-jM^4$cYKW?c8sZ1}~pkJo(W;^ivX6lm+) zcLgV8%ue{0duKToqg$yfoMo z(5?3z)yub@J^DO`#(l(%d;VGHoBqMAXNNie^gcJ~)v@09LVBNT^=#E2*80O+ughqPKJVy#SD^Q^H~lfKSEJ^>JJ8Rzey;VNHP+X)Ui{6EZN2(6Kfd+rTfd?8 zJ~P>uEBy(re{AcW4eO6<{o`Bjy9nz(W9m<8{mHF&o~%3n`X{ztt(bcT>Q8U|lUo1e z)<327e)faz%+`-uzoqqOwO&o4+tzw@YOZee=eGX5)^Bh9Q(OPE)<3=V&uINKTmP)q zKfCqMY5j9s|Gd`wj)K1PTYo|8-9Oe}(E5v7e{t(CY5k?GSL5hk)Oz1{>Ikd)cTjV z{u^8Wiq_xU`deE6%GSTC^|!YE)vdp+^{;9D?X7=p>+fj&ovnXe>tEmcH?;nZt^cOh zzp3?aZv9(Y|JK&Ot@YoW{_BDV2M-P01J3^H*4s0;uScUVI%9A@=-mr?_krF$pm+ZD z&b@xN_0GAu^R0KT_3K-|vGpgk{>0WlzV(}1?|kBOF7?i%-Z|7ee|qOmKWhD1t#`hx zJ6HPiTL0A6KfU$OZ2hxa|J>F)ANZULz4M@V4)p3@ukQ6PZv9JIufDCTYyIxlU)}mW zt-rSQ*R}ro)~io^>Qb*B_3BWs{`Bfj|C-jnw)Jp#%?Uu^vcTmPZff4KE`wfwmNLzuo$exBhoq|B2TBe(V2h z>p#`{KWhDFTL0f#|EI10^Va`m>;Jm-pKtvaTmQGM|5EG!uJwQ4`hRTwKehf}TEE}^ z3wd7E`U6_;_pKfpn$@lUy4F9q^?qNg{fD>y(AFQ;`XgF@RO=tv`bW3k?~6Sn{OU*Z zeqrpnx%S|N@4`QNNG53)1b=tHcsPDH`??H0Z|d(w{#o|^PsQuM2DT-1nF&tZCjw&}<7ThUm4e z!LYuT()mE{iSGlU&snS(K0M>3XYsSI_;^>zk0icwX8P5^D9|J|D8Slu+4j|YtQ><*~rJG;&gKM_r*4G zQTz0Wm)<>cabT}v*x#`aMBUw=I<~}*`y#LER~;M{R87iB#agV?h1#AAG_kWbtxnOF ztWz^CSsC6#7THzX2W4zNDQ6dE!`=g(vn|niU*daz@c!z+hCXMHNKopIaHptmXIy)r zV|9P{x)K?3^1@&xv|=?AsPDVl_|fU-0_Ncv^D@TiZWSt5v_^ z-|KsC=HyJ%_m=G4pZea`^s5K{z9|^i#vNJH_~IVcyBGhzdRo?M7}%G_@%ZNXcqoo7w&ZT^$=u=g;?GaXvP1ijQQf+9TRBYU$loV zbmPB^!8ZD|dNm+U8Jtzsr7y__OMRV z+w-W2A&>fy1M#YJU`=D&IRP2B2kPR(fp*72x0tt?%-MKs1l761hvz2(t$e*Ok?xT@GTGh1}*O@F??zK^%^|B`MuMQ1<_Y9k^Zu6@B zE83iF`!5MfPvzHVe(nFy?>+DPBNLOl_w;p7t!lAyzlr}`pow39=T)35*Y!NHuA!9! z{6kv#Ti@0 z`lW0@*W19CeqOe`FzY`Vc+QkQw)Qq&p80PCWfOaS@5#=&py%yvrPEn)cD4kX_=!u| zE^j-6-ZpvlySbcY{1u-QGhQ2LwRUpGY+x_DYu(R7(Xye|ik3a})%(BvxDzTSz3+!+ zeRWVW`W&(I`B9M9mT~Mn!@O_uspv~*#YK$iuYGk`KK1Lx=l!j}Z|Yupe%95%DZ#oJ zpk}uPXe*C&yduW)vtQer#EHMSvDY5jNjWY5_2PR*z+X+A`n>JPoSZk#EUc5SM#|Un ziH&{TR}9eh>nCMivFX?4_PBu0+J!;AC-7x^@T|c5lY8{?;L6~d;D*4@I&TYJ7rZ(6 zSHZUh-x+*g@Sfnu0_WoAgI@|h5;y}N3qBcqI{0kx&%vYik3GQ?f+q(T1h)i!KiIbf z-yM7~_)PG*;O~RmQzX9-d@T5@U?wqpXmE5eA3Uz>PtSNq;O~#UJ^1$E`+^@0)S&lf zIdKk;4I*xFeZ!P>@tH*b>?!NdnX>-eDeKRhvi^c8>laU1m%mANUOHu6jwjJyJ7wMZ znnZuyl=YWQS-*bDx_X-=|HdinH%(c8`IPl#v=%{?@^IrsI30 z?t`ksT6b1oAGk}^s^(r$yIP;0l=Wi$q8GopK&yL{e018@fc!TEIa=et8)d_)fQ~J_js00XY#(SnlY0Fn*JrM2v7O|rxGm@F z>_As0+%<%16cGgn=CEp0OI=dYR%g)T2)MB<_H|-dReP# zv>jRN<9A@@6&HGXU;Fr>W0QM>O=ktu_}JO=iiKA8-&`~7{JDexEzPEPao#emg8XJdq;h9<6 z*SqkH@Jy-=ahaxn=;uM9ofL2JsdaTVNlzcgl3V@_YutWcF?i%^lCdswl*LdC87iPWmT$%C11E1Nv z>wAB6CXD5*VnB~`L63c~*FR@GJFTw`__Y*`XA$0t|3w*>O&PApAM#%p92huL>b`vR zeZ{0RmF2PBc*Wm&EE`^uaoNzHp^7nod%jE;?R-ea!+d&gEO|XGokQB!tbn$cAzvlK zx}1t9*z-C3sDRD$LHT$`#=cW3-dewN%KGc3tiNH(`s=5xzj3gh>56T>dB9sXdyY@? z<&{&`Z=JIKswwNQ9<1+ZbN7ws%X}`nJ?WjF7X@lSzU`y+UQlCskau(Mqw1?aPu7nJ z>U@nd)=FOSSo6G?X?tq3?5dn*X-wk`R{c$*VaIYbBxXQ_Yj$K;m$iSuwU`yzqweWmj`~|{a&|f@h;kxb+Q2M-ryAh8^lh2 zG<#^u#!<%FX#D3wZ0VHm(tBCPY}*m^@+v<3aCej+r3*hFG<-|>aB%k3-LV_*C!+QBF{^H0)Ba(x$mv>o!|EGn`;-2|6KTtCtkA+mc>Y&F3>D|#*-g4Fhu_ukKY>p-qvYz zwy1+M1C3Ao+}$uKjvKP4E@pzdC#q(=zkDd*Z`~QkWL&jY`+U1PP{Y=KIZ#7tQyq&p z8z$A{d2N3-{jetMvt`A+?0Q~k<&9mp1@`+rzSLfShVikb_R#fwnU3Y5QTy8iac7sB z#a#YXjQLe#ap3Q!fZq4!+*&hd<9B9$YWnpFPR~>O*JfYb%(Y7!Kbg+BbvAFwx>y$9 z35^bob5wK>Y4T3b+9Z9ypD$g!qp?xn+x|V-D}TtfUp9!(OS4~gJ)-TGP4*wx_?9tkPNW8`3&oH-}d4%J<@#%^JCUB^T{8+V7*P`rDErl>G&$l%PVHAL*j#H{GM;O5e_udN%j<_)|I6ts zzjEq*V@TKM8*Rz%^WF1_o&0?ykUu`UllpkGaZjLr)NSQfzDj=ivm2O{yFZq?;-A{3Q{y*XrT@f?*9Mxp?)RRMxjLE&Ce_hg*4eu$U{8L1;^Mu+Hgbo2 zSsK?2zOsQHw8K2te%aXPicfTI2iqLvPMle_FbcHM_|LmzY>Iw+ zKo9@5vZrJh%_O_5RZXgi8rQiJvsFQUW#QuQSFE*MCF76U`$x^+nYr^SPqlVqqY)$VA+Koq-o7~+J-RajvNSb%NZ`KNlts_1 zjd4~?Jm;NRxj|!oP@7kL)y&#J-0Z7e^uv9*-5!wZOnxyyqaN6Tr_YhkFzB6ga-C)K zs-+CacZzi~*ZOW9NM+zA>#*;;2woj)y@3FP&J7>njb!AAo3nmhWG;IR|- z$g+3hguNr%-s2|ht!{gd&mO&MaTI8m1nhlMz;8J*KcUUpYJPekzxxLfv-tl{5hpUA zkVU!pWWY{&yf_e(l)#uqKKZ*fxH;f&#Tgx48k^Jtc^?Y!ygC@tv*n`TnBa)OvxaW9 za9+UAb*-=aa&zW#sCMg4a9(;o_Tn1_TKQf6(97pZ{*bjJAe+qc!QJC*FQunq6|xn* zKm2sgI$h$UZYq|QpEI(iUN&bzOgw|xZtV9g@^fvQ&!=~8=YrxFQ#HYE&%xD!J#i)j z&rK(jMAKk&}UMzJFcuh_A5S}mZP2{g4(@i#BM=VVN8?G5F}y?ZTR9M~tO z?AQ>vTgX(GTZ0RN(k;hd2>1ijYFjQ&N^tl;JcE7iOEz5&cDSSyxx`uHLt|@uS+f z7Doj6-l@95?N@wKnjUO!%y z30`$*tW~aubtbN4(Oo&AN1UeBvF8Z-@{8~8Z#rKPu#|$SXM#y_6`KRIM?c+SHjR$Im7@$7@3%K(ELO9DdOJA@x;njjb$^KSc>$Vr zfqK3xppT6jUq2MMtMf|o75w}i@}8QtQzGBG`cMK)D=TYs_b$rpR<)1~)Z)611!9PxQycw_k3$bWnCp)cNA z@826smS@!JKqH$T=i$^aJ3p^gm}zQ5&MIHl%;$nS8*2WtfIjExHGy39JQrr}CU8da zKPEUm(6$ErSfDxR9^Ypll6AfoG91&BEr%NZ-p+o#w_#i8=uwk=)%d|~GMtT{4|WGt zhxXVYH=BdSoTXMuj(Dr>@|lksnfCB#Kiu)K0}mM+19Nvj+cyN($b&w1a(Prx`si>j zpBP1KCGUN~6~Xa=G?Gzt->^cu(^g1#`Vw>-qPP6WaItROJz{!9z%F)|?dxMKd)EbZ zmsYNOc~8tfTCLBO99O=?T|7VC;*P%V+boZD%PSj3fkxL%PE^J?Lw4xK?_58Zy*JUk7YZXRsrv7-cxt>1?u_eUqMZ?Rbx4 z%h#f8#SE#>VU&1==M+#jDRv!aTNNXfs>OZZySfTrnPHtks_J?jWIF zJV$@pog?)JcRn~hppRV_1@_6X@3VZxU%fp!b9a30Jt*U~LD7?URzO~z9eht2 z@bLv7+v;6rN5*V$_a75n8eAD@;?loMh_#qohrNL~yPMc{Ucg^8?s@jHNxLoJzxOPC zy(bxq_lE*9Um2Vqd@4C)8#*#C4%kRu#esZ0TZ5Yee4b}~7o*`G`|Xi8+?&aornb?X zk)Y7ipYgI;zVM?vb4rZMUeEPYgP}dnoLVGf6d8Q$Z75xAW{2mq{PCZDa`A4-x^cy% zYJ+TReQlIYYH6BHVk+*_?2+%1drrpe(bPU(ZCjwm>{XoAWq+Rb&;0N}?qGLN=k8e< z)mmR$Vk)%2!7e$@{BjVxtCiC8 zXJ6#^cfoQxHbnNuKz)F`l-(tVe{5j4eDm#R2C0C zo<@v^G$pI#95sPvrpZK8_2%r7?U`_S3>3$@+tunZ!P?;Bz!^L&n08jxwL9Rf4AfD7 zS4}&=>ZkIzJ7a#G8SqE1jmCd2oJnJQRoC)?XB23o@t+I(+cV~;xbyEdf}2+Pk}IbWY^7sJIP%fa~I{Fld6ZK`^Z^HHF&y>!iI z{I!U=oT-2I(>08_x|JDI+XRBCT9MFT-*>^{=4b9B~`R?7id--k8dOcf8uKZMP z=}j2Mw(-s9f|>N}qtm_TEKk$9I(y>jj%OR+MuFyz*YtHKva7d)Z~TDLF9y~%KAUSL zPfX}Rvm>au9MRU<&PV>!2ctk6jsINO-`>XfSG94;t~|;xv5izYgbH_aA z;Je=mizdtC_lJ=|T1dv{&3O17y}w`4@B8_w^Q!i=-9e4{;2CykusYZju=y?FVWT~3 zY4Sd|l>MC+-Px7UPOT z<*w|ioK_6Pk!=-=>b=WaU(aJRoI{f6`#1HOT0 z2ARfnrnhD+S8R56C;iM3JzqBm^q?IDnmbl)_B8H>2erLb>4$b)IHrHl`1vJ9{9PBE z6r2@2J#eo)FFurA@5}s(pza;|*zWoD{Lt}%{Y7_t#_GPOJAWBEF(E??#huTkYvWy2($XnS5UK!1K9Ryzaot&^wz)u7raJ1f3;t_;NR zg^81Ry(m4q`_J#zFKhcRp0J;#@%!a@>30Nmzp$rlSeNkuLB(W!#&dyt%$izft2M3Y z=(a`{TJrS8>&~-gU(R<2w*(giu%`f@1OOd{49;%Mdju42(<6-X7SlQWiCHt^4VOi*fSR&-<^Cs;2T>t z?-+70jK@V;Q?vHujvrz{R^`n9SC>C*SV@eFulKcL;q29U?f2_U_G=*>$3o7Y7R&@{ z;w6a-87~Sx67bVp%yvxJV^3TdKPUL1?oSLVC+D>>pUE21le;r=i+(FLqv*xmV2e#^y%fM00kNS#)WuIhADj=mfkI4d%2 zZEsKZ*rUcrfp$sYon%{3XS?oV{=4JFLY(kk6B*X!oX_HH&UW!Zb8Vwh_r;6Gxl;pV znGc^6MQ@K@IW772=)>#I;1gYYn=Z2O)PB{&B%RLa*2aHb<9}!7Vm}*XX>1>z8kuyx zEF1dk(~D90#1=F)7l*QYKI6Ju?DsX6>EgSWyx!2{-`M(_(&HJ%X_%9jht9o3CtYPn z#o9eTTno!M@9WabQSs5$=fC2Izt4#{d}Fh(uLbL`=$kOa{C&PxdIn!JAzpkaJ2PDTdCQKBe=Z>7qQLXq`MNy| zRp;nD!{nAsyxyZUyoU$Y-WtJVTN4Yz#q-OtSZm>{o7v_U_Jp**udmn>^2t4Dh()*h?>2cXqN$kG-n5{v8ti z>pJ>gchOtp1HHrdHTG2Qd%7%-pEn!QSKh>)FXARo9|~>@64LSKcz4FF!TG@n!KK0e zfjsi}!vQ;9AA2je<)1jN3dqBASeskh6OjF?;DUg?{C-2^)ZO0u&CcQ{D`a0K*ZM61 zTYoq9<57#w>Ck7o%U`m*7oQcBe{3lK(3TIq-(qH+KhA#9;X9kEU0 z^D6_f{P`}H_KyhgsQ>xk$3gyjOPNm#aCx_xp(LOoYSv{#6iBv;LFW{oRP~maT)Hh zTl4O@Bd8e4EgSuvIE{_dV&cwFA7bdf9nw7}Yhp}B-3xLl&SFtD+3!_NviohZq4wCr z4}4`KSygvzVR!%hIHIlf&yTWEO^OvBKhx2SPYcA29=Wl_zrHray5}{oI1O`8cD*C0 zG4jfOdwjxsanR?JeSOZ@fLGfVoEebo42}X#E;W7SlWqJGD?ZTWT-P&iQ^s^XIOn_k zrPsYCe{2?HGBmXOKkX?*``2|l)fxTxK#75d)31YgA)&rE2=yYyF#H)pME|JO^% z8rmS|pD~bbsp-GAi~V8OL5dJv1nr_icWm34L>*5d9&wpOyz+O?htKv;2H9Xpy=3jT!3DqJM81;JfmZ0 z-ILiK0}&p$oeX9G4YXX8>i5TE^n zNj}Jn{ZTL}FVpz?T(J$@jbgpF&B<0+n}?+*IhmK^UFvjLrA zBWIN(b;xFVCf(m^0MEIBGf2lP1GRcW(C_i5be8S4FNZ_>(Oc&a`Nrgz5ANNP*ZXip z*2(7sdY`f8f>EH2#(yrT{_x zvniMfK0e{B*SW43@R9H3Q{7wYRy!xKcXq&+ZNZj+e144r&3VxJa}m+wrWVBU{D7Uq zTv=Be8hsTn`SBTQZ6L1lqM;FcF|8b;(d>!AaE~qg7zLVKuL`W!co<_b5L>c_pB?(o zjbiHafx0|3;Oj7+VoaC1*QUj;YP&xxr-yznNa>EBTmL$}7_v!x>T~e$JUVxi=yqql z&Llher`Gy2+4G_4>w8n?b)N8T3E0PGby@P94S5ldT01Lav^|}iS<{T`nTw~-uNcz7 z9?uHnQJ{^+e=g);RmSq6R?82yGxXz>tbMKgP=kEh(e#Q1zvwIf)Ua4OODA_{Ro$%% z>iJmy>PNx;txq?uIsE(;AF-B4G{YLJ+ETCU1GTMQ^<=ZLKmTM@-YQ38J5By1`j9W) z4dlz&g%+cgUT_cUcLeOB!@Y>U?Ba`iMEuqU;=4U4`V7bPL-{3pCGz>WFS7T=_Om1V zxByRo&xjcxoiAsy{86`lUa%&;IJ_Wm2g+gX9hI@YI{&*fuKc+xitflI=-8rd3&>YL zI|F&A-<>bc&QIloFI5-T#Y}$C^?4J|AzkIIY~s7Tip!AJ`5;qF#L0Pm=fQX1q5M^g z+O)BH;DdLQO~Fj?o}9Ia8PC&=f1fD2l2zw~J+DWQHW#1~gQ6?hwl2H^H?_5+HF~@xYGIJ%=@@*8O$Hu$-qZ%`Ju08k{Y4I*}X7- zA93i1J^H?s-_hCY`-#Et?6lYWp~jxvcur_C((U)f{9`A5$^Dc6aZkD5Gnn6)dBuVs z;?(wX3w)MxSr;Chd<(Jp=K71jzR9=eT86(G;5u-B#^`WU%be@y%iXhK{ z&m}k;(r*kh9OJ_Ds#NaPqjj}>YVdEvXHA{GFSsILBON{6cPv3S)K_QO`dkp!@w>~O z^iK@DyYP!YMSEh#YlHqSI5~6tYCydd?GrLa>%OvH&s4N%#6uj>)O>Zu_Upafx;sux z#G+)^ou&?J9i3d)d_Lo%bNAIcy8O2|@99dPSfeMe&!svl8_MrPvL^T9S9_Z?=GROx z+&ii5rTePAikUb-$x{P!fm#y#dOska{vn-pYm>fn>+9g6(71Ed5&HY%9a^sH{uTF8 zpk1=ijr+R4<-cq{J!3vr9lj&us>8!Fu4m{2^$vYPbXHu{$d-V8Z0_qooyfI1FJI2e zxM=(QJOBGP`gG&`lUFqAd0pUMEm`MeOxBJ-u1A3;hN}Yi37U$Pnn&k-<*wj@z~24g z3t!7t_LV>EGk2!tPdqf|*q&CrLx0f@c_;Z_GJ3zA5ph><;ySFisIq#Yh29THEYt-^MZgL=TF-fn6rOpKrecC&-Oq&JKz)kva7$- zicbFfyKp}9qO)Ff=Vr|J{(kLghwpQ2-57`gYzzAPhF$X4$D!^;@qB7faj1A(e@4J> zGWp17;G;Xs`C1p)XR~_P9lSCSGd}fu`(hK_Td5_^Nxu}+&qiL2A@3o{qemWf8D(^ z7SEQ@Y0iQ*XY}1+a&P>4ly6ACF(41bm+!_~1M<}{{cLsq**C3Mud{*shCkZ^`C<39 zfi=EcCtuF}+ch;b7mNZ89c&Kf1Mlo{{di2pI7-6TQr*AFFJ`vj7!c3 zC(wv}`OS_#zdxI~XHR_xOIFdIn6dcESFP1^Yj@TvUt;Y3K+C5gEg$M`T%ECc#Sd!3 zT~fWcsD;^ptm5SZUiE2Q^m?_Vw~qgyU^c*SJhaE$I|SKsctL>nh&E@}ErE5m)jB@; z5f3q>lZ=wTIb$(kC)9c$Gi%-lSEVl*;!*iKr^}yuBF{eT4cG&>2JB;tn(~|?b4MTs z*7;WNFcmZBhz)x~us(g+z{gRbjmCf8^POtwx7sZK*=2l4>yJu*Mj$p?(ej~UQn8Y2 zy#3xune&@J!@a6A@ujciotiOU)PkH}9Pn=%UA7iKYi-L|tgj8o6t_{Jk+J`HwD3%; z`G%}H&*BVae}8X?xfsZ;_JuCDV!}uEzamD;;kv-O{96A6;7LRVq=}%?5)^i zp^weKHbvij_UgSC|Mq}ic!z$8jXQx3HdMS%&seU4~P|A zRg=TszPgYTQcXrnpG#| zQ^lB^TI*v>hxPtl%6zGJCGjNpMM2qWO|vd{YIhXO1Vg*kNZHco!(E2Ha>wVTa(_`w84zO>!JzKlKhQe$L6;Wepa-${j3O`=NwsE z0!<#Rsr!GIxT&v$W9WwT8w0h-?z$UJ&v-7Vx)a;-XWCs%J{mR_&F+lLS3Z_}@@50^ z!$XgK_u5@Sot2##vsH~=8K5JRk0tNCjKyPJuqP-Q{?pg*_wt=>cU09)e-8V4r<*Rd zTIaZG@Q0#|4tKaFW_4!RaZ#YQ`N=2yo@<`ta!RIk^40Wv!gOl-_onBg*pUCe;EI5c z{j=w+%*jOaLy_su*&a-y5l7GT9YNiL^BJ>YZNR5#a&F09#E*5AT@`{@AM+*dwcdPU2@L-SxTu*oAE^EWOMu5){iD%cXN0^>jpoC-BiU`P`Mufw{97|;`;SfG|4h3N`#V+b zka0$!hBY;$uH9Wfo=tW912J+#`i%j5a;uquhWxs5zv)=Rj46TkP@elQ*eQaoZ{&!~$-H_j% zZCz~aZ42b={jsO+&$4Ge>k%`~g_x{;(89BOD6`^CR{7*y3PHuY&jmU1-rM_KNxoXU zud>NuLofTh=wr)$l}!#Cd)aT#ni$K?nVwvn@X zVB2X~xIbi*Gn9RC7M#cXYBxFJcU+)X!@du>KkOza|J_4&{riTY-IMZ#c6bJSuQAE* zN&IMszWJHbq%%K>AMNnY@}9U-ezZNmJ8crLvskt2p81LJiH~Pk-808$tajz+O(C9C z^FulRVF@{G`N{0pT~vDNF7n>7A*g4`ri`_#@_b?&KDPc;WVkPTTjw)ppBgH@&*!=4 zUZ`hgy#slE{d8n_ew`#(Y4z+joeOpc_3S2dSAd3|rv=9bXx9hg*xPN6w*NkX9oClm zPND93&nPm=jz_jJe($U7@m#$icye%2a8j@)Aj5vW`{~6_@BN<)_XgW%12MCD>!Zaqyk0hL@dlnfEb}WB!O~#lXDu z)OWS?;D2cX-}AErJ$=QG?p8*mP2v$}JdX&9$GrS?ziH*0oZGW3-e}di{_xfxm7cDB z$@^iUFa5$q&vJP$eN_|7<-PL1uf2NVk2~qW^kSjrtE%qS#|@#~80;Tt&YHSWx3y<%e{0~(sweTJU%iVf`+hdI*O{riaW?DxAY*+S zms~QT>^(B$xuEKEU+h8z`?4{Y8Vu%CYGY)U%E&rLPfuZi0)w78+GGhO!K zLqirj$-X%tpWov1i;cg&!>MzWt?_pfWgFkiHnM7646M`hA0um&Uh|xn+oE%~Eyw@C z0YBNrUwZ1Cc@FYVPT8(@=i2DO zoafVvQ-+K0JwMgndp2b)s`k5mF#nspPeuG9{qGItA8p?Us73Wb&P?#D`Tn!#dw=HY z1km!k>Uj9Qf%}<{ABq6^cuk6zAAJ4gtl>X5I3YMQ;E%lzXKzb-Z8ZLKVf|M+9%sAf zxoZl~M>-xp;nC>%)hRr`*70l%UC;CDQ+WPU$FpI;^U*0hztQomAMpI=DLntB<2io7 z^P5w6eyig-Zou=~Q+Phs@u;;v)*qk3^E(}n8tr+0cM8w%bv%Av)W`Z0Q+Phv@vIy0 z{QeZ4Kj?Uzw_eYGox<~n9glO{^L%Ow&!;<{*~U|K{YO)H{&)$V&rIR@la9yt%Drv> zZ3@q4J05p+&-15Kc>b*8@ow1j{P`4~zvy^8e|nz3oWk>09naB?r{eb4Q+Pht@f?07sMdY*rp!t>7^kIyze&%aFJ@vy1q!jQ*9b<%TT|Ew2} z=Tfg{)fAqYj%Vo40aJJm?07u)=&2fg&=j77mf%@Eh3DXo$9s0K=j*2M9MbWKMbGo# zDLfD9c)XMJJP)11^RSL5!!b{~@$>ZIQ+OWH@g%+X;5l>(&)0W6-WA!Vd2Syzh3D{& z$Gb=G&k<92j_i26i}gH5P2oAZ0c4JKRtUqv*`97{K-J`{I7R(bz=X50R4^tt@lqc_Y5yubF`kFwTISwx@OOu zP5r*_YBlc=>^v_hndE=1_4}?@EB#_y`e!nx{{?{r`7Q93hWpEu^IDI;{&@iev5_l@!4l5 zw6&JuRC=F7kBcFtXI-l$PUVH9-d;OZb zy{FG~@thUk0Rx&z{Qa7GmAe=8=V zjJ2}C-lRCXuO`_rl)Wl+(`4K0WsB{JOT_J|*=G;i)D3>I;IA_}6Py}6E;7X7MZre` zHmwON=H)Lro(W{&dwlrRll9@xBFyXiPW$|yR(s@^Uu+ucrRxdNr4FXaLbG`p8oX+K zsLve#N#P&LH~0R@u2G;}5^M-I26$nm=kw&~xIfP4Qu<@g;`!TTl9pfHagXnIe`_%R z*x)%RLK%D=tiKfKYQ?fFZt&td(#^N!YcQT@6zY@NKJzDo!8KfTkB z7T-}5_)hESyoaHy=Xu4~+`9MG-X3;a_xZ42XSa3lM*X_{Sg-e#KEDqi*neQ=yF<$c zKljtfx+)m1m7PaqkNkB(uUCGoyZ8F_wQb$|QNNBK{c(eJ{ML^jtmC)tvj{oH&XD?W z9^_d~Td$ftsm<+MuUb%J=6uqh-ujAZ`FK=YuiVH1da>2dw!VBU+xcXlt@@3vf9#-t ze4B4>{mHF&&)_Tj&TI3hw*JYjKcn@d)}Ph-ZLL42^+W!rxAkYX{@Ja6ZhA7=sj0mU z0Xuwmp^1H8QBy6ok5AbJMQ<`pIQC?!D}W z8?V3W+AF_m`6V}9amB9d_q$^6_19cp@fbUO+1@LP=c;ROG+T(p;$~L&yLQ)=6~mX@ zP@|nY+vtXyUeZR_+_a~Sc3$=JHrn-y>)I$H_g-J)YxWlV71!TQvS(*E-djrd?7i{{ zk8h0OD-&;c+4behb$h>YSBbvis%sl|MI)JF29@B zaC3>>bya!1>t${2+QreHU2SPk*?DEHTv;m%ajvRZjQam#?@IuyD$f1S%!wcfDkunu zdJ_mqSOT&tvLuiIK{g@CA{uX!3tY)&78bQ?7wuwSi&|?J7pkqbt4r0kwpy#G)wT%xX{Dcz7Fl`FZS zGu_$}Y)qnNx?0e3=%LBxAl>4-Su9<*zP+_s`%H7Py<=mtsSd+6S=W(1BL%Kb5sFS8 z^{A*%MxBox3cpDc>(H&D6b5#bLT8Fn=uA-xok?M>N|$WW6pR#cTeGQ-jp_BBbxo=D zT9N?T(;GH+1A)yQ=?yKZtibhkUPlZmpUI96DG)ftx7M=G)$ zsmOAqBFmAAEGJAXM=G)$DX|xc$a17|Ezbh7mghopEC&i|M#duJEf-AIRKdlw!Z&Fm zt<7>~v%t0_JJXv}IkNLXvD$+OUwcw`)P+QTeY&&5&r|~QBL~PJE8Nwz&#|_Bjy3Lc ztaYDb&HEf{-{;r@K8IHD8McJa#abgDC@s=0)VGR9M=j$4QR{dBD5Oa|DBC|hDBDsV zB$Cit9;9vIAyIpH00c#C(vWO!s%vdawbV7HIvU#3ZJn6q(=9=_a9pk;1g>BWxZt&< znmX#5(j5RxE+$1N8=6`>Qc4?vB2qWuxN?-4kh-apg^btc`gBXOeH({QN`UK|x-iXQ zhU-k@0_>O_NRrXz6yn-*0PMPAkX(Fo_=QRE9jVl&x~!F&%c|6d>rfUOWwJ<_WPRC^ z&lc^nu~M{-T_L#Wso4~(I7w$wBC(?Z7rv%+OA4!vt#zrE4NSJAwqVB0W}6$QXah6J z`VF`Q+tAcnAIV~fN_7pA%sg}*@_STkWq%lWqZpFf= zvpw06!Wy8fMXo-)vZWj9oQNRGU}=!jbbHFRc5D4fMRXfVTaw=#_p0SMr(4n^^+Z!dnz7>jZ$->aM=y6fKq+6g2E}*s)7U6hlj*`4QM@d=6MVagpFv{!Li?Z2;VJx4+A73U$G&!rq z`lfWJYPCL1Lu7@BI%vaEu`^lUlnOATa-mv>MF+Ip)=`(*nwA6ywu87~=u(h^+S!UR z+u`!N(jZN8{<~248b=4FNKgj3^K5)r3w+H6lnb?{AA_y+Q)~oKU{e#lyg6-p$Vlu{r z-i(H9-?qJM1v@}{du#jll6lE=6Lj7_p{5171y#rQqKJRKujdfEF#xqx{#V*`Yv148Zg83Dr(7FKc zsN6AkM-_pRm|sy`Tz>Sl4Ta@J#f`=5lT96|k)7>bsq*^PR$RyQvgTld9>W=#7>t(j z%Tn!|u|?RN>L{V&+C|Xxiv~FF|x|X7KouzY8f#nSw+bgE5aFb7YI|guP z5>u<&OiYfTIlzfZnnv?)b#zBZAP-55i9oC+O|zOtM{v|r1^aXP9CVdUVjp)xoUSyr-WC{K>igRvYT{aE5 z-KHTw7fu;;gr6IebB=>*c`bnvA|yyOuuc*vCNGhPigS75ibS8{Md)HJ8_K!#XvZ*b zYMP$F@&s4K#D@0PEeWa9I}#NYLFSG`Wd%B7$2RnxtqC_nl`liPk$=q^4xve!WsHjy zC$Wl&D^i{1a*^WhxGvSyc|GKyPnQsbZDT!C(g`Mtclxvg_s z#r0)k0ESAis%G*WcMMa`89UoaW_e(DrdJe}z!$+6PjVOR_0tpe$;O1N$P*RNr4b!$ zYXlgtSzf*p8(XI{k9ASPk*AeoO){6deyS9@6{D^3(E^<70no5 zIID05auesd11PDSy3@N-U8(H}bmb2G1mQJ6@Swzi}&R;MRMl+G?2HE!I-R8w2A3y&@Cn4air+0@dyr6tkY=Bn=0 z;*OH?zI~1+Y717j8xne9Ob~TkoGyVgEv!yD60osvpAlqs&q$NQ*v9Pb7Q(A!KsNw}PMSE{Qxx)*#-{>%Wc~6n_OJ)%O}6{};ct)F zUNs`(N0{+VhVe zVyDmh_E~n|g+Ex=B{=Wo8!9x!|B^LA+e!_T+JK0Na-d*o-{`w4q+dx8ku_L~|VyW%@*6-KY zqmMY?Y&-H-OU||h&wuJgJL%6wKeUJ4{!FPIe!{mK?NPzYqwOJUE}m)aqDQ`IhrW>+ zZu^FBec2YhdT+TsR!As;OU%i+@D5C=>8*v+oga_sW<1s% zBiCW=QM9h8a2=L;<>QOW*NrGIACKQUKtKc-0g@~qRl9guRn78|<2#$%MwYBADIr1m z$lB_~%OHnl6B8B_Jie==eLObJ$)@qx4U9*kxoKJqh*g~cu~9B+Xz0_hp`jr$ZhcGZ zI4r(X?c>^7+Y;keVPS|6z^<0Aj#Oh}Tvgq?nnl%hOXtm7QC(X%r>1tr%&C(JUS3_j zq;`4bl3EC9#nxopdK@XIAcj|)b^w>v%pL8@Sk*LkT=k4`P0g6jni?U$iHrPH2NG?a z8@avfvqT8rsnSPMTv@inQB5$UJ)sfyo2a2Nu5MT>EzJ|MX&f|gk2hjm+lH}oQG-Vx zd+f2RCrp@@&D2boaBMcSbi#xw*-Yhx2~)F~H4`Qrlg+G+^DLfl^n@&C2{0qktm%>I zNykhrK}#gNnmWs{UF^a^P1E|K^46mAj-vA9i1Loss58d8VJREAt-W zPi;+A;HrTI>A0p5Fm_~f$L5AH$@WBhgG~K}i9RC%PmFJA#m$%2#Q4Tkeb69mGIul!@#B^h- zuT!|O5oZHX1=`}6FM)j))FB;s$6l*A{-ZBdr*$ShaDMi z7Phy!v*!fXaAWyUz}p#v=LmZTZ)FBxH(P+`Kj+~2hhw;7G}-Mf|78^+cw8#P;xUs6 z-E&%ePJ&ON^}$mPeepQr`CM7%JA=Kd6k+i)hCxxiQQ-dWK~vK9b+0GQ`+qdqV9h{6f2cdQd++6u6y={a^#hesXaMT?HlEur2PMh zlUYh_kGHbIwCyzi&c}TNEc4(hO7T!gstpemVOO(!aZzy+Yk4=_cAXiR}I`x(>AnBKSauMq}0+v%#2+ z#-xoo&6rIU=t&C#V-7IpNMp*38EwoMW5yaY&X@_t9Bs@*Vv@^&&JV%k>qGFW;7~kPeqfH5i*+LC z-WLXiK@t2&JidN7UWF@lz61|(kAp9Ze0h-TC*mW2^pkV^RJ@up4gMJTW1Sz32dKqY z;u8ts}U@b-o+i{ExuuWmCw(?gu<^#tr@b-LU7N=0rdWzLmu^ zCx`u9Sm5$Z6UMLr>vvM^mz5&Zh^+gSPhi3)oWdm~6*xI8PfBCi781F2B}8=+J!l;D z5FHpZzn|Nf7GUzCk7}kxnkrPOPToYCR`q>Lr>4p0 zLL(B@O7c(-N)?M~AMsYzMX^tEvX~k&8zfv_NEvY>}llibfJjjWLuwDMebGs;9JaNm+3z z@zTXsg-C6)4y8UsHg(Sb5u^HHaQFTTDBQA+TyS@oi=z~C+s!A;C9ynVbiXja z1oV?x%thw=E`1NeUuB_uMajGG0RE%k$HB{pdjb4PmX5F8yc*^D1Xr3zk$)_>!dz~i zFh7X|JP-T{E`4>DFGB4W9SMp;{H_d&usXXG%d?;Fk>~Z`;|_nj3xDb4{RHWo%s0%9 z=4SJCbG`Y3xyF3aTx-5$u5(m3m@gy#p81-~sR|Dx_bM{4C?Hsf^&4K?!LQm;GB^UO zlYhn=dE@!B2xHU3{?%B^VWa&V0pu)qLJ*7(=+^ z53pv$18`V2#xYj}cgFIAqjXsmf7*P?e8zm%TxNEF>9fHX5Pmw?iN!JgnQd0g*Mcx6 zBMS~*41SJG-)?b#4W4j>k0aa>QB2ITmLiqF`j77T82`QIyRn=@_Yho~2med(r{Im? zkHK%V@a@?YUwsRL9~!<29(S{X$IOq-kIdsJ^HI|uD_wor>#2xrS(coy7Jj%J-Tuqq zZfN8_7^T){A&N-@lE^}bW>dqmsj*0n$>wn4hcvc65ri*z4#V1tFQLWVYr(IPeL475 z@QdK3I0EUnf;WRh!9NHaqo3vB9x?LR-aKq^g5WspVDboDcFu0V#Svs~_7f`?0kX3j z2``If4#O(4PlWwj@a5p|0ZtmT)RVH5i_Evow;lY}EOxO=-2$2yg69xEIS0Jpz3j8DBJl%1>Cz8>H_$2c&gcsoV zA^c9mk8UdB`>{i8arts=_P!Wg6?`W6RPgzrm$42y)V(~6f9Dds9Sn^4zKQsjC`~y_ zW9bS4BDW-pA2gp(kc)F~Iq*e(b*CY*)pVG1AhF%NKPFcxG=AFQo^|1J?1%AkWJG;o zL~>%3XZC$qpNp%-8lP^B3sVRi@k?UmOSjp40GsBurWL&Jb^J#=cz*DZIR~H*WWgT} zK7t(uKLmA31ly3s1=zc^1m~J>W+5xE!T%U?$C*Xgdt8A1gSrnPaWZyU^@v;XYs0Sz zzaaa05SPLFej^f_BooZdT6(&JY>D7}N%W&G-GQ(RJE3ieJFz#x#orvdAGW@;uwkje z_HH&d3KOvHT!fA2+4!H=Uoew`i-NT#8T`Sv*>48D&E%j7=LXl9wdnR6a0$H6z8);H z^X+A3fkhMI9OXp&lKq(-ZcjIJ!e7{Df+x){?fh^-cz$@2c{cn}`1$araDA8zrvyjX zKiV7Zk@hJ&)I4LShsTAR!yklS2(Q3|G&T5}`7isX`6~`cO3gH=JP#)!+;&e7&alU! z(q~{Zc^*t#Za#v+^gNayC!3>el{r5cZMFo%aON_`d@J}i{_DUk_8Yc7yfyevaFe~+ z-eVfV`|aW8Pj)z#14o)iO^aP?PqORmvhWSNID8D<9~IO4FXtDO6bHelj+}NR`uXUD z889jcme@Dnu5tCe-TtApEputfi&3rLGWsW@PY>!weQneWsNLg6URuH`--OHYG;?d_ zmeE@vD+n$v84n0?73Mm7on^neWpr~;G-l!Gl}HJWlne0VTz*b)39iu#FeSeYJEV|RP7lA{yk)K|JKu~eTVHlh@pOBueb8QL_?fp} z_&w^h6nR)7mAzzsXI?ZV#r?sJZEK}Z| zV%mhyM`k`_ud$cggqaQ9egjUH&KmfNeHjpZ1PZJDrvSU(9)Q&INWq!?P*?lvTkI{P zZyEijeapUS&mB$eS(}W{g|x?Q4OVZL+FLW@k$TyFN=k54@ml?o6`QKU{;10m^KxcT z_*gK3-&}~?-|f#2Y0KPU=7*OJzHD$|m_QdLY7X>9nE6c5JFGO9mYm}9tHOohVd0f! zy!(1(*{R_$#KXer_KS{(9CT9V1jm7oxgb6$q}|d!SK?o2Us^ICoSwN9t@A!}KBSZD ze8{-8JSuo*9;B!hx@6cA3Y*=K%R3>hm1O|JgBjW{!t84dy2*Sz$iOyU{lA3zs5b1g_X4vKKf3!c%X~RphUu9(_N!yUMRW?1Km&Lj4B8Z_$pwcQDd&+=c~Au|1}sCdP(uMc9Y!6$9T6cZCxM{UrP= zV9(%pYw(BC%LYGhli^R1JJ-!ZtPgxn#O=K<8+=P}Amnk54FaxA*az5Kz8pRq5_5Yb zy?23(4bpkHYmBVkca70L@S^F5iy5BJ1>f(&C&QKIMf@mN>SZ(L@Ec8?J>R^Z;fNRu z8)O{(1*dtHX2PJ$1`h-O%i%!<$#C-_KQiCJNWKZZ@co%9%gTXKD~en_{28@=*4Sv`jjXDsnH(i_z zyU>G(OJWA`SbRVOy8bR?U!~I#$Mn;v%eOGAi#~+>8nWiXhAWVM%l-kmvFJghnNcvy z)y+VJnZfTX{Smlk7gQBw(Ce|%Ma*7#EMh6?(vs<*l-X2c^j989U3et_$x~7J!nlRb=SWK-YiRA zVoLu!fXmjquoNw!+vO`zi#1^`Eqm$xIkhWz>Ahnzk0(6+O@mK8^zK7T2R%LDu){7G zR5S3FfklUW?2xesU)BG>1K&L4QwJ9eczw|61F#H?&M!9fx?ul5M>S0;Ck%cb_efcD zCuaM{$|IKMXf)^08lE!j(dD)nE(B41vEGlwLE9-g^|v4=H!-K~YSua1c36SmvqZXtjrLt(!4 zN~vZuKIFppgs)sW5B{C7MuxaaVVhx=Na7ukk6tKh){uIV?h|C|`@Kbrid z>nU%z{{+{-ic9#SP0;^BXK9f$G9>J=JrNQ^gbh|yOwy4`5F4rXZcAn=f>vL zMrC4!B4RP;5t_W~s2FfB$)e$VA#muYBMoaaw`J?=v8+am3a4|z+PI=FPM;79Ikn5;ah*pTwc(Os=Ujte*5Q9w>iaWR|e=8 zGWY-ewamKA>6!Ak9y4p-n*VlXtlG~FO~JbG%!2RX_=GIK&kPU#^!Crp83pghi9b(Q zF>o>u7aRrb7xw!Aq>sbz#e#2y*M!f#z0FnO4nR`-om|itG(+tmJna;NdW?qbRc>jK=n6=-n!ov&orXzU7tiny|uj3ZX-*IdG z)8;`ux3bclf!qJ9OlPp#+=fHdb-_dCFv}bJ*96xFHRdPgVKdvdn`J?ry#b4rqk?Y$ zhokr)3~`e>yvt4wzh?%72bgnlYrPDd-wW;lMFCRP;UV@fSk(S4I0Z+_TWy2=V=&3= zXMYiV*S>*Y+ME*B;aQzKgH!Ps&$B^4^Yh>!^NcCPb1lX8U>vjb3g-cGGLEY!n}>r( z@EAb3?F_2$lnebFb8k4uo)7J|nA5O*?Zj4Vso9E~2DjR`(c6BE&E^6#z&?v7gl-JZ z4VMNx?E&T@GcY^@`tsKLHhX$7)xJ0EWe>GafP)WkYzvd7%1$y*+bWwuTo>ME=LL`2 zKLd9{@D%jzXI{arh=UM6h4A<0llBkb+-Q2Egvm&?;0SUu9u#^C4%TKY_gtyuk z%?E9XDZyhz58`&#GV_)2fpC`nj(yPF6JBC}ZT}1O*M`5b)zIup^S+R6@RYgJ>_X~5 zvk{uU8H~a)_bBuI@D}q;98~wQUG{iW7M>nlZa!~+5?*63#;v|lkaIL@^RDp6rZ;T* zqU~=9xj%f$+-uIZm)eKJkA~HDH0t+gJcjT9IBJ4#hfiU%cc6L1{ur7bY~I9!8!wrk znJdlMU+F=e3 zvEDXE1-AtU*@@> zLA2>p!NK8!<|Xq>+{ic&M`q)p-vs-o;1zIC)2Hpr(C)x+iX9eK+0*Rbv7sn~O)uN4 z!?c}j+ry8A=b^m2&8ud9@U;C6^gY>9?^l9j?Q|R|-DO^}uR``;%m*QLqIr)k4=0)l z;g@Y!@SKqcQeHB@hRm;ruOYlESRQr-E9|d>*Ug85*Mc`d^IKbEN5K~8Zz152FW_nTG<7h~J{N>HE8Ql-UFc&*C=AjbR~?;a#Q;hh!b7lbYZdyAvf$!GXsW_DXv-q+J+3fz#zq z*kRB!reKZulsU_62d2@q19OI{L3mMkJZk%Q!ME+&a2+tunzGF0#Y(N`|A z51@YkEBp%Lt*CvL!SZD+bh)^9@Kt-3`6{5FHU*H<2##mWDS-`-a~wMnSEE)|;5N&t zkliPIJlqAyo3?+r2IcidyA4O1R)wQXZ#yWw8#@0SJ%5N99RAH7fLpNrA?HAh_QB?l zc;N4ch}j zbGkj#o{9Er!}t5;@vE!BeI|~DUVv^1NNWp**w35iaErV%oQ>R4^#60v23yTpNS_O- z^e?$F@mSbyx0(-xn}Y@Bn<$|x>_8p-(6+;O;W(xe2U1Ie*TP8%zZSj+Z93oFiMiuE z{KjIAJ^^x`FrR>h>&(mHhr@?Z{~r&RncsvH%!hGp`F(f+Ag2d^3jZ8_3Gg+}iY{3A zemuB#G#+Z4WNyOOwwIZk@mq%3Xtr4weiS!N#@VKDkr`n=g}G=MdjDj{G0JQXZo`kh z%03v#`1vYqsj{2#n7|S|jQQE{HuECz*Fs*Q9f4lSnp$S~$iv6Y`@`+#X^et4aGZe0 zL@zXtVEiltY;&+W_-XjF@OrZb_cy+V8$QcSU)jF8b<*MThhSD~3qEX*4Jz!3xEWbzZbhFs6+PgyfEStXpo~9+ zi|y?=Q27#C=P%(1JQ@18un4Vsqj?i!d@B0XH?ZUS3S{m8&(-#IlfnZKZ<^j`nGc(fmQp( z>2-5E!Z*wX&}o=G0?-A)5oQ;zb3eeXcGmn6kTL|}0*uokxaE5~M&V}sUNFCcRzm<= zfJavr;8x2o%`xT%`?A?-ertXQ_*Og?9NGoJC|GbUc-EPbNR`-9`ZTaSf}MJQutFfzQ>l;SrUGR`x{2F2l&a2&?#sIVkF8pp#j7LIlC z6J}P}8#l^kLdrahyVc;?ioP-v_wF_av%?cH+CK=~aC3Nga(HSu+$_RT{cy7#ze~f< zI1J0b71FK%98S1^MwbnC<6W(=-LyWpPy^-lA-U?+OPPSXL2 zJF!;Sg=e~lBhTGauSJlZp!*2)zXRpYg_JMYU1ofEJ5qO;8AyLR z{F;;deH>gbq`W8mMz|BO%MnuEtDyY5`50uJ6J*Ty?9Ju``|;pY zW{17mQ5*n__{)$Q2hI`ZXgehw8{X#d-$VFB_$}NV*$KP96K=LG;h%BMSQYkz1$1q} zgJ|89+fd*}ia7|W6Wmtf1anAusLMTz4FGqXgl~3S=iz~Kf5VJ9VhO`-Nc=pGs(G&43Y0Cn+hHl)UAsdN_heC!u=*6feM&lChRex#A=xI;y6mB~~oh3_Ym< z5AanF#v)Io^b~HuO^GyW?Mn0jdeUjSr+9Y?mA-cgo|mbQXG`^E35C}~^3Q`>VYxC0 zS8nAMTIN)3pn(isyoq}9+YnpXjYyl{ zp$CY^&Cxx2a^+KqB!PE__w=5ZDa~n2I!Qm8hZAbSDYcfQdF54FjsJiiAU?>Z6p|ZL zVlISzM;zgF`FNlAIHokGvG6l|EDtBtLZ{SPlIB&O(lY*Y)(6>?hs9Hr7SA)SPSg2# zpZB~>X-;F|XZWQ&oKOp$QnOUg;ZsVh@uPuw(&I5G=Y2}C3XkU5RGRo4Q0;L2m zQ_E9HKCdO*fF3|E&ZiYlOm|S_@O(^pE=>tOHx!uyQ@R_18?!`;kC#C@FJJy!mV`nT z4+(!H@*-4nOe@^S`B34IkW~42FDp(dRFp5y%l}3MIouHUNFedySncvhIzl8?exW3V zmakHG1>z;|(+c-7DSU31Ft{=Wo{v{qhvPMAmdsEbd6nNw{AwgiaB&)PkxoM4^r271 zrQ(62$dg-hKBZX3`A`Rlg6{Cb8>iAVWof_jC44tRPr#id;w7Gd`rwargh;IXDoJP+ z%J>_R7on14TH!vz7fUaA)i0e5hJnk z3#IZXl<`+19~I+rOe@^S`B33tnL@3x=U|Fuif%$FROArnslV^^kK>g_V9Y7C@(WCP z6e{s|1M$S-QC#PJO0kUdp$-rQ-QyJ+rxYnHNt`d?>sd15^rt|PrPRvrsYITH#NHNp z;g=lK3iok7R5&Cg)$VwO#wmr0^2K@i*Ja6w)1LxGmQpLfrxJM*68rtg3%}%;R=AJz zp~4{{sdmRJG)^g0lrPT9|74boIQ=P5WGS`sdn%D9p z6euOAHiC~+sT`qa?mLkeh~$`7xR3Lp!XY84a`BoId~Qfu?RQ@O?O7tlD-97+f>JA~ zQmQ=V_zs?65igWJt#BWc!smRyQMksrG6>Cgd%MB%WJMOU4 zi}PuP`u3`AVvkDo;6X555(7p_ClcOi380 z(6nHM$5Y>J6)za2ddU;Ilt^as9&qrf8&ZBdOQraivygm!6rq&F(@FRW;yWY%s)I|8 zNv0%J3WfUouL;6aH%hJa4jhAOUSp9gIq83td8?wMlCxQt$knHJaGxRAOHw()#oW%w z3q*2!QI{!?mE7)mzP!e#Oo%@iPuwWKmnJEFnU}dkKy@g7;usHde0N0a_`~-A# z_u}_cdn?*Y`yJy!j*ob8QgUv4QI^+7d!oR|#gv8;-xY{=h-~_PJiW%Ap;*c7p4Xm8 zJfC+GdXaUHMRe6j_JwHpgKb{8cj*66Yq!cHy$d`UBIK@X~k>t28#E?oQu>F7FdV$3EMrnx| zswbzUC1&0`$`Sb8SsjAsTST z4Am=C;mnI;NuH~Bc4iV8q!DdYCqjh2zq!ZFk)%8hb0jH=OGIOgl;T8|>cY=m(1|XC z@V!8$B$Rl6Ji&Ar;QND;p?Y#jT4LsPd=SE!n)ru_aE>`i<<8W2D=Uj31+`F0((iAI zU`2d2CB_}=NVPNPOGOamDY2I7$uxks#Z*qLXD_r;=RFO4=9)k3t z*?vcgLC7hk@G;D_!j~JTB^Q79#X`wRkGL=D8O$;5p$Y*a))x0UD@gYc5zZ;s?pFNX ziag4u6`qoeg3Gl+C>X|RMHjqu?RX@Vob-qv0z=1;Y0XJW^Jk-8&&Csvq+v|>gN{#l zg^M&W9&qJLC^_j74*)~QkZH|HO7o7y1s*T3_hBULPL)qD^7AQ0mZxRPmm8NV+Tp)> zI{hS+ob-rGqMpGV(;ljj+)_N=!<7pk7mAH;!3#ZQ(|JnCIbcp86!~RKK0y03C85MO zJMNpKp1~Z`3S~|pjw~A}USa_&mlCC7wkTcqe9GZtktLcauj)c7!ro_Y#*bcd%FTX3 zCpbyt!!lWj;sxV#J|(=$$@u)3EtE@`hPiyi+L;4Uz7oQ+R%?7>RQ!6&L3b3SV+Q4f83KmvUZm%CG%Ga0+EC5XC2*wwfc> z(~{EXa#MWf@r7Km-CR}OAQ3=od`6%yv=Orio$@dGviPUWyl%6puB$O0kZ2tzlufh2IC=|FzP~54&ixY_U8-;nSrbMpK z<))NBKPHvJ;vAx(FPrV3H1woOI?c%`dB%b}Ijgro1h0~P&Zk7KP+Xqn&gW2ijW5Q> zUo@@rF?m?(CnHUXXZzRVCL3 zc^Lxn{e~Ey^C^+*`EpZAmmlX!^E{%VFZ*Pis+^2(x(UU}k-n!!5XK&>G#(~(etDK3 zUlVbX1Rm%7K~%!!XeWAKqDp0~d;*JyB8wqC=~QA6RDe%l42e_eUZ$pqms4SuCSJ>x z(wSQg84|{Izz4Y^E8s|seESnz)?kxg?{qX_wzK%yYMOuV(k$cAypIAL8I5-%PMGQnL ze!6=br1B&3g8@GbAGaKe51$?$Q4bG}!288VA(sdW5fr8#2aPTne!FbdZZD#uRFO$Z;wX=9Z7?ef6U>87!h?9nlM+?xY`n)#yvi0i5WrjkJIrh|FT%_MA2Echlk}{JpSjuiKRcp_(rDSUBYuTTdApZA+YEFT zs1(ZUuIvgYPePF?Wmm-Xt1xq%J`z@#K|uxj4XN2L#z(5mLHlD}fpB4jnFBr|38y0* zPi^8iC*nWWOa_)575E9BG8`c=!mn^CFJ89N3D4MwljX5&^5vFIc~wqpwm-3gC#CNf zge{BgI38LNQw2|sY8T?8?MMgsK5?ASfgFbaAji8gNV5HTh4yeMZ=RFq%l2I4;6Lk; z63EB$>6o4u=_^`!oM6X+g6j$mwcO*u$A9G_j3q48ALq&@ zA8~X{j{uY${I^r$ST^BWwwFhIvFkDXw^8{{=oDU-l}9?2&9#m=r4#Hp$RmdT_)7bv z@{D#2%15m53fv*HJR+YM{`)IB&!_2JK1UQ$#%U>m&cot-lI9+rPFB&EAjOrZlr2va z6043p+@s?jQfwdaDF@-$i0{#v+kNFJd-M~tE6*!~9VCR)eE`#+!|y75TPN3jKAZhQ zv=6uty^<@>3-J|=3-PUw0O2_N82d2G<`RS}J{Pllj#5-oE{{M7lb?q87_=*yv6LgB z*M=#fSrh5F9^ZYB%Oi(yGZlBFjOTOHf{TaRuB40aDDZjytR&LQFMmfNP_}D)e@9u} zwJYJdJBoeT-|6nHB+{?D9R($G{N?K>@OMK$9Tm7|j6ygnaBl3v(&!mq>35s~#a-&= z2aXDLGAbnJPp+8P+C#k~w;|YwP)@Fv;2T(U+XYbR zW6>N(?fzYK`-S;M)Z#w1C*4RTUh0_tDoRs6Rtlw68qJd{4)dH$Ddv~%pHSgnlpy|P zR!gN72}&#fvWj$`Ho#Yal-kEip|nb)d2+>Jo|7rXXn*^vJ24R&#i@jN{+;Y^a&pG8 zAajFisAEC%63g7Mr#2;>jKUOBer^zcnHzcsrysDrZzqZ@GOwvee?yYY3T(er@St0w+e`ksByp61r?s}})$bXKNYa{9N-38s& zDo;>zd#qlm?(Lz(`*&-{AI6IEC#VE=*N%MC)t4AQLCv-CG0<^Tz5wf_=P)Jh_ymP_ z>t2Yym=qtCB=jXRM=DB_FF$EoF;4;`Sf3)Ud-tRvm2wDQJg<_Jj?|ha9n)+_!ew_L z@`w}nq$Z+RYgOnxwdN(3cKiu=a_Waxn6Jbv#hT=tdt@WwMOD! zRS=An`9$`4Pv#FcUyI2XIt~3(t6#VB)T&|_4{~#ehg|36TyGCEeQ`VCyZl_^HMlW& zAQoanu_WphoQT{rD7+c}7iJ)a$bTXKaeUT#J#I7h$EP;A(csO%v+%fVe|&!JCh+{w zlmyi%Xf$pD_A=vwEhyycHZYIjM^B!#;o;ZO_>X=8KA8A(U>4#?aS?K(g2T)s`0Qi= zc~I0;y3|qpuSwuJ82?IMcmjOnHHCj({8%#%AFgc!cBbLRER7G( zUL9TqOlWQoO2d)BlCC$8oy}0QEx0k9g^!YsM7{>P2iTmg!oQ1u65;G{wV|F#b8xT) z8m+>Iyw{nF+)dG0;VQEUbhUO9J~+ABB#@s69())R#~!_LW49LnX6?;jB~l0CHwLAR zgAHE>%`|+v^jLJ48{N&_BY-*5T#eV4wuIDdWu*6g_y}9Ac`xK%4%j2+s&GI2U$MvW zso=B1dbKsi;=WGD{CZ?;R! zRP#Kby^*T`-B2`REojS;9}2m=MO}{15cF~7u--SJT();V(D!k6KZZK4fDNZu{zt-3 z;G>}dKAtfg}GQ2Enivj(&f9UgbATNNT^FLfspu=cfqU6Jh<1P2j<>0xAgc3~rU3i{ zfiE-1!HRaYeSLk;f5o_>S z*w^tH*dyFWT({t3r8C$k@NWvI;IrIEV|-PiluFdS!3R$lLW@}@4N0e=ou@(i5;NSg z?$jIS6hC3c9orC*4tCUDp>C7%CbeO z!kMUZgRxO&P7Dt;^)?0mxsX|rwR@_wyBF+ViP9QPO?Zagfb<;XCYeq<6a4FNd_5C- zFM?LoXbL_kdwVz-dcS5bv>RbtKeQWey5fViL(tPc3)pbWo}a`=W!E}8r-A=iGaazN z$w;9;l-p9&!WLH-Gcl9&M{6Du)Wgyt7;8f?PaTNXif-p2?v45l%}5+_SD|hDK<5#F zE`-eWpnJ|1p&ka~Bj$K54!N;mX#R$pT??uZ`4OP&XX+vO7ig0b zofO71dnNnY?_oV>wzr|@FKmB6XPP2>@-~HeUS`mf9Bd}qY$aaaNugJV2&b8sG0q2} zS62alR`4spWgP2&%X@DjaI&ffI9bI1)N0F{KQ#&*6WueLWm*SEDEXB0SQpLi|d&A}q$IhhN9%ZO_K% zTld31)~pH3(FZt}PQa({Cql}BEZ4OV=ayB*JJPAUB`&Lx0+Ue?L$e{y01leK`gGC&QnFHQ@yGYL1;UCxZ`` z2IeY+&!etpLE`{3Ngs@a9gs5x?Kus(gMn>yy?PeP_;vVo+#()^k#@ZKUAP!}{}E&7 z1Uz>2S0`g3T2vlb{S{`CVtXK@zlPB{2(o?%jmyz9cvJW^z@No`&D&&JU;$zLmk-YY z%NaC8uRH{=AaWtcm)3rOmqPBxBGfNEce#bnqgX=z$vlC!-_PP-p+Zh?{5V4P3tzxI zeIQb6(AK?S_krlkoPpU(hXFnS*7k<2?5X`>_bBL!fA0i%KZlJ3{KVBV~OMzz4K0B$v`ZbZ62T0Fpb zor}~EXf_S;aP-(=m~;E#I(9PTUSNyuDsX+=l8U`w4MmP}R@&Z}NvbddKL~vv#&03&s1(*dW<$)N z$HDi9ml=4Lv-@#e1$(&}o7a!$!$V+Ce_Y2mU?do5Iv1r|%7L}ZOf_2W4M2MX-p6Uh z*5h17yXRuvuo`x+avC-QU+d<8V$7?Xz*!3_{96r#`2T*+%Km`THui)*xT3GYb&M_D z57+@_BtEyz8sin{J?JUCF5YWLI9n%%voTk!f^H#X92>5J?IX|!*fRZG%hbA;+6KB_ z9bip55C7L&YifpB9;Wfx`nl$6aFw9W9+*C6{waJxAiThQV7{5NHAtgd!7g)6Mt zh>v}b4Lk79J@8+1FuqgfGvNmFz3`&2DBOhE@{;fcGcH_jXN7OuQ}Is?GH_MlSHpRj zEt$?_ZVxZEnM`1q4h=ttp2_q!_W_Il1(@jv_;Y}eVqjE9%<+1W$*`}Gq8EOA33DJ~ zaivIU9i0VPXXE!v*gYbLB9ocn@~opwW;aVdGr)?X0#{idZ9P% zkKWrCvq?YnMSeIyYT*#{-$9@`44k&9Y-OL27S6Yo?H0E+llkXtRlBJ5p6z-k+wk4Di}w7- zws(5$z5DI<|3jMUzF@3k9#=-c3hNRx!EPZ(h&n{56fao~~)c$@QD5Mpr_774z?8n_BkH*tYL&#+r%G zA66En4TS>DjJ*>4}-lK%5L5 z>LmTA#dr=Ydmz?tuG@1@#QhP};Uer@mmuzqALldnMBbC&9%umaxh=+fBP_$u9{*}j zoa^N6X@vQ)q1N?eSK7(q%(3SYMmf25bvG;itCoqjd$LUJ@o`U<3B~`_7JE1B%4B-J zKC?D=pE>>~dg5C2)c?tzn92NebI0Dt*uGfy?v1ej*fqzUcfGT#j{K|hKR(7}9(yO} z#CM}7{$I6gPkWZ`=fr=uy@Zc@7N&US`0n<^cg`~E`)a}mvS+FPvFji2iLAFh zwO9U}`2R;w%w*#CD_BFjucrvjWMr-naCcGeR|r&lBJTjjonQYB#a$cTBkI1zc#lY( z-yiV4jzYWNV^-lFpsqUP9#L+4?aeN~`^mkAX{lcyRw?YYHz>WSp_JyCV_tB!r`iL4{vdw93wmT<$}?JCU!Ur}ClW7rsO3~3ZW*7v%DvYq(&}*MHR)y_-0?*n zZiw#M^0`9pD%s{d_3f$e$=z+Q8B-%cUFF6UbNFZg@;%KKyh9xyQ?i2c{YTF?C`nyU zmiQCI?kpkqKVwNI!`Z>F>3X&#etylCko(UCu%0v2LewVDLNgiO182-9EOXmrn1k!= z5V#Yl5YKdwx;I9VKZW1d_TWyR?a{LpUI$XqNqg-6ECJ7)_+*Mu`Or(?RY{&D(Aj$} z=s6eUTEU*VZ*8F?pH}Eh-CbMg$fs7kH_+Wo?KKuF;^QO#8l<%EOk2ELR#40TJyxv3 zI!CXXTEB92c_*#lGd8=QoBMg{e@9#V$BOth;~yQ}@9enPTU+?PyyuzL(`l-^E1%+I z&8|6#b7xw`?b{snA1mTLO6$(Y|L$!en)2GWuPYE;OR0_j4n0bBiCf{X=ZgJj+d`gq zR4M=LxZpFH{(7O(;_E06%WsRgE&r?)@=T_dp;pM6m~V*4Gq{_eqwJGOse8KI=S!)L zK3S>q7>@w2xcHuK&$i5TJiLPcGyQ5^wnQm6{$yo;=&E9R&cF4Dh-0J?7 z_Mwd3ZQ`o`A88*-$+boF-naH4x4Q0ak+u5n<34vcNEvF2_I$3{ceh1)OLu)u^v<Dg`J5Q2bR6q1J%F=P7{UpB~NVBiw zL}(?<)m<$Y+`i}@*PCNOEtfjq6g@f3UA30lQ=JRG`|<6$RZ35K^Eqy>_x`T#$itP$ zLD}cW*;ll_xrfcwdj#rS>)Suat$N3GVPE0-VJ4$`^NqUQ`wI8be2zQ6ui!&_j$3-O z*P9Z><*%T;-mKGHy?N58dMp3GPd^FpPHE_@&9Cph>rJb)wHL;@RTq(?-29BFj#OfJ;;G!-^+MrRSz4z8CAXKAUn@%EYbBG}4{sC+ zT;8$p+=RyKR8}>7$Koiwt5q0rWiq3(+KL>GNqNU2lbMWnx=4{~{h<_C6-gptXA8DD4p96ccWx6|e6;7$=-ECQfGL}Sdyl894 z{3orkE;es>*BZ2iC8#Z#jJJg&AqY;x^K$Y$x;!tZ@9)UfQ?-*=M?(Dl9Z#XNxkBRa z@9=I6-``=0`c4aN)>Y;_hvS$$K1z|c`{#ef8vg45TEqE4PsikWIUV5zvGZI?le0*s zcyc7Mgt{JL&T}h;*d^RDYkF={55-)>Hl7jP(W(H9vq_aJqtv|#w$Qx;Medxk(ARS3 zhf;TX#*+Q~AZP2Ujc7OnWpa*HZp>?e%wRQ9kBH9?+HRDg<5T2Of6k?GYGUHEp-?j9 z?m%V9xwqnU{>$$JUPHcxPin1SzF*FFOu1sCEGdzrZ(;1+Idb?KQ)?-Ua)Ka?#*p7> z#5LElC}l?W?X!66NKc^lqPZ`NJmP$fkw)intubk3q10Ls8kvWvWfj&?TJuUn4(iwF zu4H)A6_zVa+y;EC#I=r`t;hAtr;?VWoSvyzMrm{}##41?gHn-09I3P}ycN4&6}zLN zt*kMB(=P^&E(tL0+5YNv6Wij+dd(!_Fs z={(dAmgj3J6kg66P>4-}p)I9OJMPP9lYdg0Hu)0SvcjWO9MQa^NT+q9E$B-mmU6t~ zeK_VQM`}WkvDRDQ zN>Z$r=tr7w5h<}M+a9W)mMHe9T-DD@k}{N`+)fRl)2qkp0Y>JUqzEv_W?{Vf-Kpi zGpCMMJ8|;vAjhJtJPUBmm**||;CmU=U+$B02d+FCd;JyCbKLz}ll1cbw5~M?(Y0m} ztu+f=$@yzdSve1M?}`t?yW-TJYoFY;X8iPsvem_R*9!A7*HQktDS_+mNZQqp)D?Js zKqyut=4yVOyMo2rRo-9E-`|m|yLKf!zg^jLwO#%AiSH;>zctbBt-BosC3APw(~d{S zx6m>CSM}3T!5s{ra;8l7D((?Ez9 zxYK&rjVoT`cTP7xGb7)V5ZV7ux`{?I|1$mWrrRnvM*ltQ?SDcy&J8jaWNwg}>Hhpm z=Y~DCDfy+R%hySCZVKE0a9F z%uMEZCzVh=QQ7x0_tj3y{_iT2t;xETncmO4yW2?`J*(Pt-R`+&wZyq@#q!@-;yZ66 z>%?Epn3FY<*vMxOIYzvVLXjJ;bXNny;eT?+NYAU}Sd%hNT z*N)R6)tAVVYArF>M!pZsQK{`1w{e}*m|Ew%?n)$$FOj+KOC+YJ5{c{Hy^|%%)hWLn z2jyA&kCd4EB_>+XEBZQ-zY@k*96BDk;^699%M#n;Jtscb#YbZNj>NxGmXydDy;ro7 zr^czA-V!fMcMWlkdtOP!dw@!js|S04_7>4WrTBF#Ye&|tLcuR*@u^|v;@6;IfcW(o zu{u^L%inG2NfyTn-4MhacXOh=Kt-0UTfHpRk~hBnSFEUBUK`A*oO}EUE0@+*Bek5rC|W*eIWW~AsGeW5 zB$&Gh^ugSvi&>rnaVXQO#QDy{K~SnqU!4ua2Tc z)v((^SQ(mNC23kH92tVeHA_~4fwapimsc+d7FX8JT@Wm;u3fOSDiEv-Sp_bkx-VW@ zwQ^B)uy|!{-t18(a_r5oNDRZeoRYiXM(s?OJfe^ zqN2i?*B{-MZ0|_7Y#85^+L~%FZ*FQb=Hg}Dg0EQKE%>Hom-H#BX=+MsNH!(vlMS0X znvxwG6RD1dWLqkcZh=niC}8Sb(I?^5NwqhpTaulr#+fS|Hqn&sOtnKmF1F9)+KuTB zH3e}?XENQ=kw~^Ax>~>x35kkOAyZYGhK4!*|LEiIj`D*;J0b)-&&ShVM=9XrZWTN_eso$1z=wL5l{rnbV`mSodO z5W7AJ!gU~A-`ajMqpp@yK!T`&7}`y}prQOA6q0OG8svV`{xiZcMeO zJ2&juF(%!T?o20}(r2XFH$si3shGg;r1+6MBL)Rr@VYpp*m)zEn+ifmnf7NoVdrCQ#@T>II;vQwto&jDv!dwMha zNl*#a_EbYKA8|)|L$C-`sH?7q&R_}H(Z5@QrQq*u4OnZyqykjih|czH|F69_fp6=o z^2eVXWqBqorKK$`w0&M=Te2m~cH$&X;z+i$xXt3mPSQ4{jx5Qx8d-8A*@?SCX-ii~ zT1o?DidlwzF$_?)mSyM^m;!-eohkf&(*ZgK3Y5Yyg@S(HbI!f*J;}<}&iv>9`+R;; zEZuwVx#!+{?sm?(n=wd$naQLv1i*AGZGd}?)2Uox3U08l{s6_k423u_o=PW;%L$Y! zj2qx+9SU(TeF2t6Mc&KbfTy#$d+Ced2jS*#g6Gq3rZ0Bp$O)9XSRPJ%MH+f%#tx)1 zzAdr%w!!)xnbbkwu2iO@y^EVn7n=3H3~JiS&*Tfq35&A5gdY3AY=`F(jZYUJ#O&xX zrg5GB2Rv6-HF`EL_-*lk@kH?&quuyl#UB?3jedNtF}_jUVmwkjvfy(I&h^fD|HFIU z!Zizr7v8k+{RL>;u37ZJqAxA_hvHX?UoHN0(c;B{#hVs4F1dKg ze-_7={JFT%yvqE?;gWP576ad6{JgjjPelB@xWu?;@n+An#orbGX7SRhy~Z=e z8y5WClFyirS9N&DJ^xYseQ_M`@%#lj{zI|ac)pl1PREtLMe};&=T%=?Qd510@yFux zRd*WC75`NHYY`U)SHHw~&InZf^Mc!}KURIN_b}eXq}Nx%o_q23-%??imL$MDJo8e8 zM>4DNfi#9cdc}gm>+yO+01vqqiyioj7z>PrMvw7I@H}KJ$CJ#x##*BrkI&X16w|v= zXRPCR#bPI(!h03mQ4~;8iWqB@OQ&2co>Ky$M`6z{fjF4jbsmSGho=)YM1CpnlzR<- z31g6tpeOpb1i8dwA4<27v8(voW5?tcrk@!pB}Pk~^!hJ->t#=J%U>z3+vmo0$0Qsl zHifwVIaKi|h@CwR)tFeKH0X0VyU9bKH>wz&MkdIjuTmk7DR2xi|5*}F!mU`@pq+>H*N&9^xt9Q9^g?uFGV}@;d#~5 z4SEBk0d4GMc#Y*uz^c(^%RgtKp;POvK`X6AyFT^L*=XVCAnsy3YqaPEe9kp2yynTs!6E{z->>JDQPqpl;=kdw|$gRkSZqSscN>r)IP}nqMSHd_E z46oquzeQ*@C&H~1K8)DqEs6XC6+VWsR}wQWLmSQ;BdD7KAXlkB?9s%te&rt%*m$JY z*pKhM_%n>;#NZxf2yv=X?v4$s%+F)vzpxOMIrZ~GXlM$H;CLbNA@tAt+{o?f z^=LD3oETdV}AT& zjU+mM`j;L=)gyt1jj*G1+MEU~ZXD1k_%+#`UVTp?#JSUeMQX1b0b>a}lsh0dz^I|x8X;VoaD=(4<%B9Y!lNX1I zxO9oas$`0^>qp9}za`*UR0PWvS>?fqQ8(Tt1gqoCOYzfJ$=(h z{)x+hv;wSSw7^Ap66(Z}$2$FZZc|+J@Fuz35TZglp#1ZLhJ?D~P?$T8g!zqTrlz9e zNAjR?{m@ArDn3T@K_3v8p=ng_7j+yqs=7$vgVrUhTkdrTFC~JHG$a=af=<^W)1bdo20Dm3iCg$Oj@@ zP{0eJB5Ar)rg^*kU!}Q!g-bpl>FCryk_yFrVe#FX6uI61uEVRVA6Eh&UD8=wX)Bbj9zSfl2b`qrjPs+mm8u2>~M|mj?<4&i9;@NYskgM{Ey)3Z;o;b zUm{&gni5S?olio;=~ufiQD{QN-K({`l#Yhduk%mZg5$63q8O#|uU3dL<7(SRqT^lz zLw@;3hn?*2^~U^3>NI3$a9SCJg9g`ad1t zXW{!?81ehCD$@_c(E!%tk}$ST!T>)FyrmU}*ozV8a;$z_jqjxuKI<_Myw-RFOzrnz ziRw+v!^>?>o?0eg22AC)4A?)|0_6$GOCq|GAl0^=`%_cNPg+ag~zxWe;SLHY0KlE$J-6g!vghrSjeLo-BY*D}g zY8NdE7aWO0OH8!YVkc;y&mT#Z+yti&#TOccOMf{)&*Lz6915HNDHkNkFL|Jp-029d zll`W+uS6bj%o)G0#4r65mq6wl`0rvo33cK~Oy|3jq1_1;mpdJY-pRQ3sXP!Js}5Q!~$pm5sW zp+6F4ab7HJybxEhC@wcd=Yeua;TJJ>IRX}MCw#|r(Hg=KA z4UyQA2MVcUY&V9Fsff8-u*qF4x*-CW98yTVGN214g*Gsi25jUhbvY2BL3xnB2GEdD z9S6sYnTnXz1)tmmmtReT@*sarpdq0ShM%d3!CGRF8%O5ZnC{S!TvL8a4ef#vU@8GD zN{Fji6qg$!n36*ZrzH&ik+5c_(u}1KaTSZ=azg}Da!BC;#&%=SR=r}e6o+SNdxM4GDGP z6pQUDw&2otsi9ZXUUn3W;(NXDT%n;kkS$oo`gDamT}x=27LruTy97y6f5NTrYDfpC{q46hW&4U<$T?hA`wZfJMs`dXM5%Rf4NoXh79)gkU*!E!^i zn?lA*sJlybV)wE5dE%IYF+cuFE|D0#C70wb7Tpk?dmXMr1(TqwjE#u13Y%NRC2j|@ z5#gmD+6E)|^j(_5iG7koNmH=NUFn~O)34i2xRmay5;M3qiI-B+Q2KR3+-?V2?jo$x z_%n(|3Y&S#Y0Lmt{wb$;BENeXN4s^J6nCa%8Hpgm7mYJx+=4t5i?`rU!wAdyr>W8} zK?zg-IW7ls3+R=8blA!M-eJuDxKp~NB;28@ap>1^yN&AF?WSKWYAF3W)K1>@V&k8D zN-rK$^X0`;`mdwFM*u2VUjKgzs^&d2I0g!%IQ@I&e^Wj^$E5pz8N=M=`0ry`qtWP2 zsKot$DZ^e?Qi%UAJz!YXhWQD4SaUV-?fg4-Go_HFMrpX)=fyhO$$S<&iOq9Wia!tO z{{j97IlxV6{$#NfLc(oW5~K;~ay9K%TGWu3OM!723ZXFx>c+0LuvotQL4Gpz9_!zH zL+|mhk45GG!H>lOcikNe=lF0lQ1s#!cdQr|7h@3)KlHnx=)tkKV%6dWi`apy8*o)( z#ImeNtuOEM#X`P(gD=+Pi}~xVMqfS{&*qZDbi~#2#j5=Sa1F;YGu18ZnvUfxU%t9o zz&J{MK)DN3lj&r2E5qf)G)0$4a;&&IB!P6Un!>_DBb~x2ZRDi3dIbZJLMoQQQSNjW zN4VD_F(ERUP0t`!2WM|Il}sn>OtuWLU#K*TXBc#H8Xy;ygp&=k z7e}adKH3<-g`kWe(PoB75!;J8iqipl8+ZRyG80d#T=4mCRZN_k=OQ?aaX45VU~+VB9Nd*eal3-55Ax%fJ4IZs zbA($93U)h?d}gPUxg2;~y^N8-L^&{D!Z^MyK$t}b?j>Dnpw;a-$v%}FPT-=2T#7FM zs9r{O3J5L~$i?W4KV_kHlA$2g7~%^J>^{>v5HHNAO63f(ABXsH0mM{}YJ$Si zY^2~}iS2|pBYbo?mBB>>U=_Jha$PmTWCr3u|9mLjM&O19nE(}@V@g^s9&-LC${l%sPY_`)#a4Dyc$9;n5beWCqdjDh^JlLWUt(WK+J5S zQ1B8h6ponccW|mciptQj>7I$|u;Mmfr9cD_PcyrNoMpU51prpYY6g~bx`i+`qmj!| zl?7s{pS*ORMD=oA1Ne2?>L3Aeu zH$e8OOF1x75jwL?ckPJ2UG2?ybI z8XS|S78ft50TVf-7}EB_>~@Wu?RHd~r-1>$hLd0_8aFwGy~qnV3NP*enZVT}(+o!6>N;fOJ)W`S97y*KWy8 z3kRxts-woT#wmC=<)BGtrDcr_C=4ak#x?O+KG|K}um<<8bR(vo9lE7ZgcDrDSIj6# zaC;#(rplJD_HX9_5qA0kSN9eaO1S5jw zOCTZz+npxJ-jQrJ%>o%`VlDHp4lU4JdMsbK{h;!z^7sZr5EZ^othoECRLL1{0GKuzV?c* z6lPhg!CUDXA+)D_$=n}tay3HD8RR|2UH!k#Ru+>ywc_KL7E#E{2vGzpv zfbg2OZch zfC4D4`JFoV#nu3a^Nq=CUS83%2nMFoSke?xqE(ZnGrC#|L;9TXmA-ZMY%G-#9-aB- zBnMZOyo2dD^92=83Z-TRYWOHzWRIj+3f27UWGX7m;S*ggWnaLxjByYMwsS@)DY^-) zo=VEsQOQ@tx|SM*q=!h%Bp*aiVZM_?Cyd%{WRKavNjPAZRslgK7!8$r9y$lI1l9z|Cr;{b%{4*Ghbz*2`8Cw2(Gn^)I`n%` zLMT$89z@9^y3@F5{Gd>Wp{p@=5Xf%0C^1E27NRPH+&R%&gjys-9eJ9Ei%2NcPZz}H zrY3R8TqqJUYqw4D#ds6RiEM7hN=)(GM?%LGt4f5kaB!&m80qu#eUwfW59jM$9peVJ6IX0;5pyRY@du0>92eZ4}2BXb0WC&Q`a zSKQb5VrY!DzQN!iiyR?L_PEq7xMqB6jP5L?s_3S+)Z!kBsfZ^=nON!j`{5evo8cC=_Z{>|dWwrzZ2Md?YwH1$8%s zs-W?pRea=x8dw;Q9F5RFe9z9RTlV1ME9WASs1B%Y^4mUw&dx=nQTj&I+ODqI+TD8u z#sSWkLa8TNYPOzaDFvxRQ>rJChwi-t!$cOSC$X%43aV6H@?gft#*X@QDqm=X{Q{!H|mB82kBmBDRmN#iT(J)kKyx%xY5; zTuVSB_Bgqv7<=Y|XnV*-YcexUQe4#+`|3mSi4bVnqQU{rT= z-j{in-qthcJ=3$afS7)1|3vbdkKs++D-vMdr^%tHZqb+P9Khh zB>+7Z`XL#V=K)lDs{g1=ZHt3YX-EX)Qi-*^+)rYErhrU`CStjL!!#%5iPct9yWg_z zYg#j&O2B5@y~4&TisOMW124M7LeGMMA#-)41(`%IMB3D2>2_6^mC;Q}L?X!|Vjaj%r4yFE zt+tT2@^L8p5U*ZLGLY%wpgGAUuMbdoduSFgbAR!(_qT)^g>s0rKx&2nqO8!Yf*gl00A_AVpSKUdFDP zb!C7uuS@Z=l`$!5I zJ+uILo~-_vsfiKf9an6ZW-70g6LW(MIgS?U8f?_S$4g+y#)$N$N~n7jxzZmKgCFHE zlg$LRR$i$-oFZe4MMaA>4dVjTQi?DA*GZSFf(M}rb-TwzJ3n45rybd-lWh8PT9}g| zOXeoz1$rb=)jGaSr4p_h$B#{x%ZYi0E{iq;L|1t#M&K^99UPz)%_TA-Sy$}$PeqB5G7XbM9#iMkdSUkI@QP0Uu8Uo6F_rnrS~8-F30+FD9N zI`+vG)Sir)p^9Uxq)DYFuup+BCaFr&0ZP$%Dzz08%$i;1r8+CUJaX|6^TKmN`7t+_ zl6-O0pbhfX@YJMP&sgpPxVwNY`o%~KjgxWPh*A4DMmKj1Xy8~(OKMZ1;gZUwmhWR0}8RmyXrltkPDzSt>%f_(bi*Iz zX%X`uRfNV7dkLAHr0zhl%w$4yKS(MQhP4_bcVA1Q1{pzM5M33PNrLQa zRH1-M5&>U+t+Fn|Xa;AeU2sQrf>hjYgJCLR}DPsaBRPi5$(g2UEfEF0(wfcnj?lXL@22S6~FS2u0S9!NsC zYO(S(dyGxRau`ZzT12=t5rc+CRf^_|L4yov$&lZ2$|0#u;vovW7I3e*rYDxbAU2au zwpdu%P-OCyK_-C0(#Dw})5NH0L9y3qhUUD>Jl-T!)a4#;*VZ|2r^oAuZ-vL}!_P{O z_rlF{-c=s&nOm(Eeouk2mP;KBzy_|IFg)V_ae~*>bkBMFJPS_SHs@XMsrtKJ4x_1k zLcpH$ZuC_B=XG=5O`fV}XXd>9o~mEt=VH$S?+#^B`|Y|p?`BWcUw6!Tw|J_Kg49+| z)l&y%_ZrvFPR`8Ymh3BL4P5bKTi~?q&24tGEpE*L+eRIj^Iqnu`pPylU{@OEBaAGC zq}m10r8FDI2(t26sB_-ko~ju5_-ap;?^359j!vc1GI_PxQL&ANY(Dup@36=7u`Lcw zR3a&x)IllSX{j+*LIG!cG4zmi=z_}wJJgc~F8wP|m%(}$h0t3E+|2_k?39`7m~3Qk zi_@@dI9cIBHu`$lPG+1s+nU`-4K`wHpEQUTAkfkr?78|fST<@J@u{n+TSikF2VtEn zlTWjHJm)n%o-;2#RKGhE+OwM9ACVnfXzU|o?jo6(XqvT3Sk@1K;8hY^7*q10pW_qu z+Wa_cnov6`;C0$~Bz=RsVq93YBcqZ81()RP%daj8aj}+$e3tGh(Gr~(A+}{~20ONN zGlEX1Ol{_FnYqfNa!gSPV9QFOhl(i>iYF8##RY87LD8_`gfuF!s1y(Ko)t~gST>`% zSXw05y2H9mBA8;B)BtS$bJPtC99RQ1+eFBNRt*zc2?I!}CT$eJtN5`KXxLm~4JU{K z37GI&u?-Bvn_XdM6W30O4h`DsDH?a$v@*n6IIa6&Mp3g0bXFEJnXj%|h*`9g3+oY+ zNKguhvJe*7)wfe^Ps9L}CoNP=h;X2IC=qKTDCoEvf+JQhYd025#;l%7I42*O=g&TLC6M+iL(Yv z!nA;%Y>I>|%NGgxu>|BB#0CNRUpfS^lum2lui3(D;ID%;vcO|JX+)Y?uogD@@-RRI z<(mwk3qHBc9o$607=9E6Y@|y)-ZyT)ms%srNb@5{;=kw2E??FDPMO;wq#(r ziIg8nB~_TA7kVt@)bcF+=75R47PO~=CR(mqJ8F6UP60E#gPxG0aczE%cvvW>ZCU0r zS2-$1B%@4uQB1$&9%V-yJL{EDEi@{uxj{99MKof4;*hMRL=GMD1@eXQfd1iy76Kyc z1f-uiFP_)D^|E`-My}QQg;MPoV>uqJf>5O%J(~0OcozNLw!@M8B4LineN~!%mkcW4 z1QrDH))=;-(tB40^jXXF@fZr@qbTNf!3djPl|p&1$HK&M(5PuCR5QY9W4zW|d!6jY zv&mc>)YKGan2kFqH0V1{Vu6G25(XZ1oC4Zz?jmUvJz81dBrskn>L zl_s)@)IqSxDWgMnIp@+IO;JTMMdwLmrW#F6AlF*D)lw~4mVl~kiwSIDPl@DhWoZEb zAyb7sGGtcVAg89MpBU$Q9kk@k-t@@xSm{Hi=B_nkl z(i>D9OAT0*B{J&LmZJkyVC-mSj$o!nQ82brYWyTs$ex~=&zRsk_4Hga`^MI4a7Esm zJ7q2`jT2E8#}^@9bn<-3cHlfLUND<8XHh;>5LOq6yHbl(5!XVRV!cB#;uy>=WT|mw zz#t{^wfy`BxP zG@9x-cCQo-HG*ahx;j64DkZT}wF$KEJ!bnc8$VU3lJ~5VHcL_pOE0waT%qGoqGU5y zk-In@h(?ug(K;v{D!np3wvrksYtkglG@4|%p+c84O^+1z*aStQrC$ao2xzvMkR-}V zaosp}lhqQX*+J%HH6F??1Y2fTjl;1>+L4-jWi3KQaE&u4ytXrPXMtQARLHPAWBySi z57cgY;Z4Q?n=9*X+ z(&{t~B2zN6!*T_4Dd`iKKQIP`lu(yvBbN=f4nXjxN+*SKMo)5~c5IQcC1Vzg_o(=G zBiGtR#SXUubCZ(B#TZW#GMbno;_7hLWO^Yc$?PE{`1MGdV72s} z(hHL2o?|oxOlHpX9*f5zT%dS7;!}a0S%d{sFoxvyc@09Ac2pC#wZxdn@Jc6v2>Du1 z)#AZJkvZ?{JXK4_ZDH6ET4C9q^S<6F^dAzriiNH@@0~{PPL|$T2p8$SL_a61B-_Zp z_G;6|mB4v%PZFp)tjNoh4JIB>Mj1l*aTk((QE32^bSMUz2G( zL4zXG7-nJ}C=v-YMksY8IWD&+0orbg_D5gL2Zyl9IvN&-QH)c;hP zt$%3E9f~9N=!3#cDdU5dWw=UQ_G7b0w`!-AwK!eOVJ;KJlA+8X)H(A=H&1J?YlpBR z?y6>mf?A>7GAk&Q1iUlyrATw1MKnHT1bO*RHag*XBgY0=;k+iVY7l2C3 zEhaXN-C^|B>m2rtSaT7K2lNLIZP4+22pi8Y@Oaja@&=t>W_W|nZveEg4SizHTjMdF zxPH!C>oK0cfg>Rz4;(x|$iQ(JCral!kSwGm+ILUK-ST<1?tSZ0USa$87U0k(kg9JE zL2YerX z6Va#*g;+EszBvX(GvKUDB{8AVwBxkNF47HcYZz;QBzo~|s#VNdKJbWhHhSV)uJp80 z^$~`6Q5m7m`boQI-?12S+}#K#=JQF8^1PlZvYu1sWA(#cC9n#HTcdwGUC5eYr!A46$?F%xMXM-L$76*466M*ybQtCh4MDl=J|xO!O&WEe(imw=0A zBAIT}!w6@ahYi}(B*iTmFe=-Y9c9s8*<>PY#uZjjn>-0h<|fe~-6Ow5D-#g}Sg{>) z&>o+RzUH2iO2s5%H+H={L2bXG0*_`%S0)WjR1s+@wpwJdUR2G)4t-&69hLk_Azi~P z&k-V#vgE*hQdj7SZ0qI7NN4YSzHkyWf{;+i)(m@A7TYv{Fm;n+2ZLeRemqxi5PltB zS?O0|G^>xCJuOUV7Ky0q7ALy&c!gbi#ADJaQId=%W$y-a3HGAaGZonh!?rXS(7FBC zJNrayEZGoNK=rXHn`U_)ToXPWgiu#Bq9FR(&w{iSi!DHnt=_fzo7 zs)y~bIDupCFQrO-%_XZlrnm^}15V=TR8u)N+;AS$fr1e8l?zWN)`h2(uN>xFzQ_Pc zx)*ScUl0*f)9Kh`o~COmVaZ|%o3Pw1U=M8r-stfj-Zn?Gx%w+LUt`kU<}n`M+&Tm{ zapq;0K>7B!h;sl&y%Ns=+yq3o7j-anyE|Qz`>MbmhISc78z?Ohc+V}=>X#j zwz2J{v89pA1p5mOBv^%l*iCCq5ah`sb(`wbEW(1HDvHy@L@g#c!X=`k5tD4`h$p=B zfckDWmm0%5NZN%B8C0y7Hc=#Q=edi97|u#OvU>}7n8GT$D>jS%C?v*zwL}K~Zbbnc z9Ss{sabErr!*Ew$+&J}%-;}Vvl^X=3^AJPi~4?r;UGu@3o<3cO1t)L#qp1r9L`y`IW{qp zh~Yde9cfW}SK1X&E%PI6oL0r??{MUOP*7N?g7UkYsl%l;wDcW0<%GCK%F)!24pM9L|R#+0si_FtjTQ|B1ot{?lG-)}eh4i_tw<^g+`x%Rl_0?KUHGcMy z`K!IViBC6BB;L!kLV#KZmFU>xMBDxe8=PaxIIf7(tqjvi;CwH4G{Ua4v7vqAh#I^c z1GsyzX`Pdj4ATxN+CFUhk5}J94c6k*aQgULEGr{R7rsb3SIj&HonnBup zi;N50kiagNLbkS$T_*@+ic#ER<*ht5F&(=os9a#HLqbD27XhxH;7B$x(=d_**`zNv z3X_qXrDU$9C<2&e7lcGXO@#O@iPxqQ4YFM7%f(XpWNkx3?X}m|Vg9VSo{o6d1ZrCA z(DCYEgTraNx`X&j=hJkujtJrCjRo9SGm;Jw~5HZ+2Jc;{Z9A9c;f)0NJflH>* z!-P%+)&T4ttX;ddwq|V&_LSAGSzFt^7Gp-UueocjFIBg8ZK$qhZK!rlsJ1&)w+6oM zwV?oIgiq~RE&QXH5*ClclTrXu_6r6$qFjJA2+tb|Sz>)%COK9YOC;*BC{Q;sm99&q zrjJvH^Rf=obs*X}B^$VEdK))nb2NlDDv7(1OW)Bhzn#l`R2?gQQ}o?H?zYYb^0alj z4;?nfV-smWog;~U5*X6SgB|VK)w!&_Cp9J|0_~HR%s4hNLShC?P)uP5@OhpkKSTD; z_n5EjUu7eV!mf{_r9=(qJ~K(Oy_z4{;+vp+yfYHPe=@n6KgI6Z8jtyF>@uqLn7`|r z^VWIH&u(#Ypa~%&cGWJQmjH_|Os&adZbM7)d(4g7B^^jtnMS3W-h=c)p2bs_-V-?j zXPam7zQH+fyJzvPZQv2@@?G2tz;e&xrmOGoxj(wZFqYIrd*nxaJ>u&TUqpNnn3b_t z=TE4bb)H4v2m2$QMPElHMm>w(jUVjCxuw5JntC#~#?C*Dy4bynYw~2^N{Fb zLK~4T?O~PXgouoVsAbs~eaNOa=e^Y9ef{=MJ5_2YXncY;=N+6a3by;)X%duG-ZQ%+})lc_2trpYC@K`Q8HQ5#jSbgg^M0ac+ zqM;%Xs1AWJ+83`;Vcc0py|mft6ZtmJ-LrW)1Ixc^EUV=zoSxQE!*&+qg@eQCsgVvF zfTP$LoQ45+x*Z`+P^U=d&zb-%4ULL)erAG z+A4w&?e)fTUo71Nq4-GTNc2eGk)9*#kMufZqUm(2O>+nD{f`8oUE^FoHr6Fv&O@PI znUQ&|aoe_LS;D8WHWV1pHw;-39~&s%*VB!2Z|n7g z37X_9JPXFRnydI=D-TsLg^6WN?});NhIDeY5X5RL*%GjD3X=q{`h!NJxq+=je0w6` zD4|{u(H0}Mu?l2huNXfjoz+pY>CqKxWP9K$V5^#QFF_tD{i z1J`68OtkQ~(#1zC9Mf%$Xg3f~>#;?J*47fkVHXN7rp?Ya__!VY_P(Ry=!sH;x<7K? z(H7Oz>~_YZaU>#xvi$Tw?(q9`V+4^V?PfaB`=gbctdLT}yc*vjw)lNuKXzxvGDJ$d znN-jHJq{^51g&34si{KE5fI#3d}DmcNKR2}c6pg#@BO{^9i`joF!p0yq6cQmZ%IYBnHKA|Q*JrEg#I)|EIi^_#VbN&76 z?>pL2nnww>$*vc&^3wyUv&l!|0WA7pVWV3ki%#eT%XqIpxnj>0`5fpvy(jF0(*9m2Yg`9W#j=T*mF5?F}a`J_oEQaQV8)gi_@Yt-_KQr!Ij3S z`?-R~R0zt`gz`uTN)+xe_{<#&b03-SeTqeKmDRkqE^s z@i)kOtAgl6(AT_Yl*193;4cHbP2oF(@_hBlq>z!#K((V+-@;XE*7UsMK$ z!HTdgfP>U6FoL;Qh&HOBF7^Q$P`H|PE|6xM3#3`*0%>-+K$=x9kY2N`MgjVN0g&Sj1cw;|Tj+Nk8B zB!u$5w6>>0NC$`XmW5!X5^8nj)F_0h)s<7D5T;fKYLTOU))c29w~`EUw2{U{PfO>GBJBK-WApOy#(Q2^U%*9sDhWbMz@>q>)=FW*rGNq4prxTPCl)T+P|#*_wySvYWJ;B|DY;)ImC-I#s(_l( zDxXbb8ZxFJr3!h7GfR~~-9I1VDF)}Ig-qjE990!7G~+i8V;$@l`3AVr^yvppt_eRl zE1b=-BX(6b7X(CI_5fdq!U;SKeKek=K-Sv%61rCGQs$Me!2^#EHnP#zK6LUst(kn$po zy`@GG6;Vn{%ZWl#IvHhEL}=wwB?nBE94=LIxKzmrCMAbUl^iZ9IUK6waFv$a2G}Jp zg_M*WL81jv0pM{;E+KZwCCu%WcvzZs$Lwft7cW9>8CHQn+XfN$KvJ2HRN@ZzByr(h zhoEBBpO<|(3kt?=?l}l_t)`-lxqRTZ%Lk6TeBipv2hO{E;J(X;8fdYzk6LgAp(d6& zK~8NfF9&jsbXSDhwGwuMg~Kj@)J}T|2J^rL((Tg)(lzA*38jwq`6fSCa#9~1CCN#h ztf19>elJ6=Z^6?<7++GEl@;Nbt~wW>A=&YC1(;a;0tPMzTX> zQyC#4Zkr=QF^?kwyi6Rx9*kk^$-#tVmqFH%H zaf>bX4sih1S)lT@u!^Yek!Ix*d+C}9NR!GVRs97fMp`=a)*Z7f)SNe zcHXPdl&9OhvDttf^bn4pAlwaG$ptFl&OvNo$Op(T7d9&=t!4@SINp?DAeaz8kkC#v zg%*lM%>x?ebUS(Qhxe9f4#4621Sd?_DsXbpH4`LoByq35jtJAiXljh3qSYlZPeMn; zxHA)iPy`8R6oPOP%k!PGq_@$wla&9-FzS! z+czvV+{A8B7YB+FWC)dqmMH^*OE<8EU~FgIOeii-X7bR2Q31%ya6E=>vAC@zoS4a^ zQyB~z;52&WNSg-8zz4{34S@iSLV#NnBiXbK#iZsunY2>la(?7k0a49IWFhYYx1JS! z`=LX;_H{vt#?|9eKdEce*t2WASD>&kxHy%hby7Qwl1WyCdet4Pjf|9N$ zIJPRGlCl*F6|A)h<<+W$4pl0K4lVJP>aNs8TxAZIsJnKSOXDEp5=XLM8pkeGxsooK zDbwTy=;-g_S5eE-DbwvGaTS$PE!_x7E%Aa1B92r_1+i2Gl!!Mp<+n?Kl54f_R6@or z%9dbjxhi@R+cE==q_|9+EFapEV6zLzg;Q(y?6$24s>=10Azrr~L2=w!tmgP7)`gy+ zZ9%5y;rOURI!ih&?K0qJ+5!&W8klRt^aH_tjo-QEW)hc;AqM7P+$>4EV|+Zvv}=+R z$sDv}dgGy^6hxzW-ikDA#*TT~KFAy0`EF~qGn_WHr?A;RvrN1`P4@sxk0*$+*GfMdC&iiUSABN^zr!eb(&9;skyhOy2oS zKbW%ulx49c`%KsJZ3r7Rm6uohqYBF(A+z1?DlcpuQofuIGsaXRs1J@Iv&BUrRn5glvi<(h35J~N6qtqDJfl#n}<94$t zn=GjiLFG=3k}quguyKF@9pG>-6)#8xLFz1nDO5TmKxL8bhrSqAlW}D%Gn`tEBo?Pz zKyV6x%GF>d_j4^{i04}7HU9>a7x^1ZUiODCiLjvJDx8R@eK7mN7czO{C|v?y3oo`y zM6jl^d_8(6-TV*|o4MSs>xMJWX&)enhHUI;zCTlltffwvv>Q2YtIznU40k))B-b!JsvfmK#3aaLKaX=$6gHoBM`0_xEg% zZohnZAUd?EF->a>nNfPqB-vLR#BTL;I%3vt*OqKL(8jiNXeS9vHJH70lMo-^o_|#a zh1q8S^|b_Mi&|@dEQSm8a@ewk)r5kqH9#pKG1C(96P04(8aF!bNw0mX#Rpfynz%mj z3^IuogEJE>Lx*tBIkuRh_tO<#`TD`jxAfExZ13NKI}~8mM-8QMaE^F`EoG7kK8J}l zDeRt;cdP3AHV+J0^}XAB@p6);OAAVtpAa}#>isCY?DPRxgehTfjy}0cY+bCfY zjT3119y~gBO?86>DlOF=cp=0_^jl%;y4BStKUsuh|Gce@4Kfu7G+EqOTdKn#LBlQ{ z36%J2DirBDT@DLx2q|vM)evTYe{p>RbP~=g2H!Cpr^To^VU<>Ihr1z=4nrK|`z@45 zS8vRzCs~%molfcGYIjN`uv0>~!kfk{^J4UTx(9Rv5OHz|N3Aiu^Dhl$*uh6#jnoSC zUJS+h^`ADATORoD9xEmlqS zGGrDHzqS%VH{sMGKKloZDHy-142cl^>t zJapSMot1~Zhz`Ub_kQMJf9p2fA&caw2xdz}@(B;#q#|%InIW+Nmv=}>aqgXNDns3e zYSlBiIBgq>P}OARBsHYWkaMQm^$buK?7UQ${FpUf8BwnT(Nl6w&4qEYoaF<}(-X>R zMa;+=YINO}HH5%|rF?w3Hn&Ea)U76xHZ4fPbW0E^T6wu?WN)z1UlZ)qB$^<+W#jyW zU^3wk1hK0z~?7dAwjS16F7@ zm@U=-=~j?{^v$gF_zEf(c40k>ay`?m*%0I_n#{MX!O@Jdyv-u2dAq7~-Qj`+jRxLv zz2-wQP!1*`S*mVufDf?{1v(8z0w>c}n0;~@2B!cDJo!UVtc~Fmx1AbY;zHFc^!?32 z3JJ2W+Ayl_*IBUEbCV+BH<6OdKO7oy2%ju7Vc1a-x+JI3)|e#)YSqz5bJ0-+skb#= zj+BQWn!=rtQzY0KsvK3G^$>cPGV@7E zdS~l&Ii|e4gc4D!c0J%F5iV;zSRR4uS1yb!t!2zRbn!q*Q;epQwL+-L-7NTZ0L4-o zBTK4HrI+y61`nA1)<(V)8{!b_M0~YQerj?OCs}dpBYK4%mt@wQkx^#nmY^t8bhSLL z;lym<59%?@tWkZMuRW%z)K(MK+Csi5h&f;cJKId$rNaH6v{ke$+-fhAgWcyDm8LE; zdOXyV8b4}-)281Z8l8skmw5xj1P_o(WoaP~?F1zC)U=0Gn_>2ZkExqkC6|+^2uh!2 zB0)_gWNppL-J|H2v^qi4D<)$$`f`!Q>Sf8DqK#^jHdmamnw0ijR$Glh0f5a>IunJ2 zu*yW530=%6`}z1%o4h|ri#Je5apAeuOIa(q&Yl%`q5aU~3Iy{7NdPj#7DNeb zi-BO$t1tKFnUOjf=2OZnU!X`v2Aas5gD}`3LJ*>v*`OQ1AkJJ1T%9;nR zHR%c*xy>k%pgU{0|Jlo2)Uw_4hT40H@ts%+Q(_Wa&16OWGwZE>xfq{D8JT==VS?(U z81I<(gfAd-t%aAJ8d1h6XwjrV@PJC9Fbb_iSa3LxE1%>&MbH3`aQiNDpKk^sib?qE z6eZQgNcY8|E0O`Z334U{w$^H@*eN7SjX_$#&t=TIW1x|mt($rfPYYpzSvUMHtA{pv zqQ*+QhYTmuadcgZTxS*<3@Sc1L-RsI9z)ZuTzIs=(O@21_fiL2XqybS>aoXM=ENLi2ul*c5S3Il zU=WoHV=QRnDZh|V^h}>_i@h@Zl?Z!;&qREjtXY2oWQ~g*sbHo>+8QJ=JCPij8iSdAjK%`q%7~^^8yqtO5>5@-9R#-&i~3i$ z+&%xz%`LoAV(jSew+yMdUHl$HR69l#Vr18;nKF z)dO;onT#UxFeVR!%I@kK9$VC{dlyk~JFAfMoJp#fI(P&f+1JS=s;SIgKaRb2vTmn4r!gkS-G(dMT2_HYJ z9rbu0AOcN&Fb9#U4nQK((+d)PsWGhYq0o;@nst3?#5Ow_U9VyQ;HR?I;em8S%`)kR z^`v1VbLNALyaCe{H94ex5oq_V2X)wEFy(>z$EZkLrcKc43&^3dnPU0+=`L^7L5AqJ z^vkIS-l>a(p5rLE7KP73(6M*`|4Q)!3WhEo^(;JtC^z+!+6$`!>gz`0CsF5BXJeS@ zkgs!D)Zof*kUPzA(Zv^-clDcNSI;1$PYdd1*k{3|sy9<&4e()@j2c&S2{vO11q(MQ z=V4uKo1t+=XH*fJHY*hv81JL_{>@k^;FA%6e2^2U--7$xqMmBzv!6Wt8XO=#N~3N| z49&v0Q;LE6EqGsW)EMN*O|ahbeF!LNHKEsU!2%>aua%-~N#)~6sg8ntTcnYD{}hQ* z3-fP<2r^A;U{PaAs-zBGKWYqd*|trR_CS?d%d{G{k#Go>dY4Pm1M2NVaQy&RAOLw( zOVwMYJ+YTK_Zp^0US{3(oKM`|FpkR3gEp?P*ob;`o>`72h<}9EAa*8XVvgAl>k{T( zErv?J5H5{p#VPf});zkw1 z6GGq^68niTtYJF_@hocFcv59Auw66>&eM|DP!{VTf&$|fqS2_1lAu1W}*u{Aj0rkEDxYQvBS%`@mn-nhwd42`EagdwhPmNG9y(=kxgIw%` z+}|PO)OrrexLwHMunHOcV8%d$_&6ce4bJ4F#wF|=;*p{WsHhE;en@Ti0`3kfEVHtC zh|edfKDp!y%0@uJxJNEoMa299;tsjwAQxPLAghBHX9yBTTt#Wo-2`bGA_&u2L`@DX zU=ZC{j?M`#Fl`_u$Owg!Pf`XNDH^A>=+lJ3eoPc#1;TsK(0zn~hP(iysZNI;MFS__ zP86DUDU%=ydplv&@4~h;)XXp887MuP6WvHTTR(Sc=}90Q&?DO0=bitF;_%+wpgtZH z?IElo=iEWH zH_5zOox;3&C+5^=vEl5SI5BF^F=7Ar_pQ9~;g42reDkUm|Iq)1I}ymepXw=m#!r9! z>-*m^y=r#lQ{PJe>gylDv3!ha;SE2!wdZB82)_9Y|Jj#5^z`;m<8*AvtQwBad_3@% zD=&NGj$5z%mp^~%dtaKJ<&io3pQ|qY*NZ~mJM*i5ZTR=^EW5iEaOzg!`j`LHhetlT zYO?>vZ@>JD_q_E1!pC47-u|uSuUql@KXu;ovzL7JZNK@cX{9c^=mq|4I-RHlyXz%2;XKns&&*MX9{BjNoxe>yaF$@wpz zJ@fpJ{OD|4pP*+XI{6pA{qoa#AMyYEBG0=X``v|~e$}^d`kvYzHMZ~@-g)akzT!*o zd-6*+ed8w|+J4i^aqia{ioy?HapxEJ)Zh8{-+TJd&CgxgihBl1#DwrGw_6`g-FeH* zKi&1OSDbmnZNI=Z2Sgd|Jp9Q`xA*_m^CjvpsCE~S#&*5Yv0cmC;D-yQ$lCAC*AJp9CO znm>eUBhe>pe&)u%{r%88zW#UbSg@fZF!f$g)Qi;N_%$#0e9GVY<JpL)KM zdg|yG)_&^z^>29Y=kKPDqUW&iH6MQXyEkoV`OVrVsv6q*zjGCGLJZD_pWXDHmp)Z} zVdn?lvGv!_T=gH=__@|D)%>*Ia&f!|u0Nt$O<5xk$s>GU-Hm-uy#K)Czkm1WH-A2I z$6HYVEoOu_9DTlj(NlpvuY3H~k;RFBZ2}{y*FrW9Kap$s+ureoyNcf*yZ4jl{Q|c` zuxJxL`#MkSrl0=AH}T`Sk*y1!?*=(N;D(<&qvuF`_}_l^bYSUcc8$F|g(9<99=_|7 z*WYmC;6q=1^PA6o_1`ajUrk)DORM%fa2B{NO*FJv>MywVQ~&D|lixY* zvZp?b>KFMnyeRm^Th{w-2yI;Ce{H__*Yl~D@T`d`D*Tpp@4B?=hhsmT$^7A4Uwitr zdxTs^d-zQ&KllCxzxm3YkALcm|N4ucjqF7L51`>!@7!|DGj)f*JAGdE+=-c3I|5jY z3!go0UcNN_lX&rCkDm6~Uq(L;j+w%+}nSN!?356=DL2k-dXM{(bU9-=U{ zhJSur@9s}GEc#?<|6eb?c*(nwJ(d{5W1Fq;{lmMSxbl)+fBnRFANvckZHtHD73aM2 z7ng3oWg^-s9TL}Z$9-)Fyi$Ns+7 z_cbkVtbOaxzrTbMfgl?G;i{+qqbu*fsPLX!Z`|7d)In68l4rwj`_YH)ensl(MPK+z zHhNRyUB9RL<~6GDdmnwt^*_LU@3(yIq8|i|H}_F0B>9AgKQjAF`r<2Ys{f~VT=$*# z_dkhx(~3v9_%~bLJ^DBMKmMxwKAL^Pd)hQJ0g^jz$ z)_(i>!nT)O^qmjA{{8Rzpc?kI${4=m@y|cJz3s~DR(<^NCFj((t>Ktt+6sU2SBW1# zwc+#MUU%tPi+}gg2ZGdUl|UZ;{aAjP?^mze6ME?R1#kPng+D|rQSQR=-!FaW$?2;P z{W@Q_>+nbRzel%q4E*6IHh%SnnwI7#hc38a{d*sMcno1YzC-*9n=@~^=HAAK{%PaC z%R;E#-|*}^9;l%z z5dAm2;*M*cxb|zy|Mm-e*FFCE>E~i9lO#5VfAIWUcRX~~$AT|4AK$TUY5xeCDa6|F z+kY~9_=ij0f8LDWf8Uqy-E|GPA!?S+r7T)+PA z&wcjhPoKZ!U7@dkW8gO}<@A_nK-#?u3-1}bk*Dd}>>fZ7M;<5T3EuZ~Vd4$eot!!+U@Ko9~Vees*@p@|MBZ{O;QjPk8!d5jgz$&{*)nFFf|8 z{OAApM-ggjKJc2I zHw}OL2ndQo6#n#0;QC|6o3DLl*S)`6e8=-(Jj?^(TOYskZNc1EpGyyX?Q75cTgS&K z2b6(a_zhosa@}KxYTx#WpA8?r_}XQdA{&(|9sbr zCC1WoUrt;24E&@0CG<;M01e}`y|l~3@H~1c?F)qQ=Q7%BVi?ue0cA1Sui93vT6I}C HyyE`=?EEEo literal 0 HcmV?d00001 diff --git a/boot/ocamllex b/boot/ocamllex new file mode 100755 index 0000000000000000000000000000000000000000..ac8ced2b3b7054f88da9933e649290c83d121e76 GIT binary patch literal 146250 zcmeF)37qCvStt6C>Lk@9ipHc#1kzo-rMD!|kk&*@SE$aeMu7yfkcH})>ZC~^ESf+T zCQT9+5ygFB1Ql`DDWCvYr{5AhF3>IyK6f-a;)q@8j}7L6&k2qTwg+ni^Rt1rDOeGZVSHpza--r1cuk<; zn-6M_HL?rWW&HNw@xi`8J32Tsuy<#mUA4bE;tA<*4cKFROTd0$>-xaHm4Wtx;5!5Q z*;{rR13A|O-xc(}9172OFGJ4vG&~uOY<$}=N2kW_Zw;2R``ZT|IneC;zM%FkHuwEw z_%3PYCdKLp2A)>u4>tQU{8#qZ+_yA*ljOHPP2zd$Ag8tAdmGuM@7tQWNwVHCM%E8C z`^L#q(_a|OSWFZ5-wZ15wLX`*4FNlA&K~0@1+{i!#(13r=Wc6Y&)+@r$RqSz6p(Fh zoF8~L25P_6!!B#RU2L#+X|uL!m~&p(^W>oHyD?+7kyYmf4;k(G3OVB8+uGn@_p!@f zy7@B|X!I_&W>3#wc9!o4Ys#{}{$_RiClLHW2ajN3Xf26z3*!+2MEcW~7l zSq}zs>`wf=z&-1ZB~yQW@PUA=p2yvLYOpfU*dupstyaDKaOUaR7iga!JT73L{l;u_ zr?cy!KrYB%?Ah=@)-^h{yMr8`M@j~pYmQIOnYy|zczZA(l#Smv&=t3`kxjP*C5N5l z%mx}A=+aqsPg_hA7rE136cnF*=t*{o3Egti>lAynFE-l(yxObdyPiEY&!6wgJYP$f zy+;L=tEr6f-5+T5nk!oF(B|=jHeAWkIB1Vse4RkGL z!*yAId(h@aY<2{Ew^!{|-fGR6XxGYiv6BNiwg1}SgMnOsV?d8M^k?}yGk0a+U5ze! zz91m0=lzz<;U&vDUSqm7y2#Uv@fUB|Y2SPxN5IZiLCGmTwjQo}aIc8jqz+Px*g&=A311S0ER2!OEbIgvszXIJT?N9}k9y7MdMWIQn- zt!M(xh!E~UtYx_dq5Qx*NpyHI_=)P=YS$V2_x>M93 z-4$2*e`knm#glA}fAY(&uMA2TKj_A9?csor>dspE-mcYMbyC*bIPDHya_5_Ih9j9r zr6*H-iw{jk(HS1NH}Pu^1djxzw_>hdDlWCZa$j{;@e->VSL|*X<{nCKeWB^q-1Wf+ z0b^PYJWGHCx3RJ&2JsX{}6vyHuPVI-Vxe6>CS$|K5)N zPaXZkq4!44>R?asieO)$Rm@Mx*mHpGa&S&iyz+f_5HTaWo|3UzU>iH_ZE1R1dQC^q zboAPWZvDI_`qYYNnpnx@g_&!4&Kh`}x8iwH$MbmueRg;}LyPbK{L3Sc@U7@y3r+U6 zpla?n|7rib3xB>b5EEnf-%ZW9wdp52x!)K1*zlH~ZyWTWwbym@b)oq!uC?dvj%Qm( zukPrhI{NSb`O&`qMd;S1KMYN$JE3&`T;}?Cd~f0rmLu>wGkDeY8wXyrc1K75_5ax~ z-@cOn@nO#0VBYhf+0vSIJQQ$DzV@vLcht{!;Ghw@WwFBsNpj-6jT z%vJ21IWlL0(z_`==$vbM8e`if5fKmG4V$M|nTv*VfFzK?Z$zcuj9h7bRX*IdS1F z(A-z&24@B91JC!>$NcMeoXa!s>^hrbWb9q-?!eskU}JDpp!M%c?qYYFGyJNc#Wf>zaUk``uB-bl|nO?qB;` z{^H|1esb~HW3OijwEEo1>w|=K#HcHejoEPrxpBVe#ITvHa0(PtDs~ay{eL z2I^A#SY+_E7m)6R!#}j zYwK_6vsOMkgZ#AzfAOF}UgWrZmrpe#=lI2kJ!FdOt$`eroU+55G5f`@-%nTZmd#?) z$|0Y=vYE`*W^1M6nvCfZr}Cw@TdeSl#U#7=%m3cy%7?v`cXe92jO!k$^P+~xk~i|U z1@`jmwaK@$rY`Wc^=7{{{; zhx0D2zjRm==T`;lhP~QCz#ct2*<=s7Hw5;)WT5H3HNacGRle{Ut2?q+2V{_ipMAAQ zkAF>Iy?E6`@sU${T3+YXemaUruK57g%=1Hj_*Aj2vr3+PID>f6VpqP1yR`=bjZIq1 zV;{O|UXI8yzdblLpx=DYyD4-0Ztc1vG@sNZo2zElWqf5|4_R!ZXD;wOu4h(;qi3L4 zls{#gy<)3f6_nn#*7(9_IisUu!FF`X%5YSJeB2n2+sgau(DdIOq&y#KYv+#4v6t`j zf#<+ez^%;6`8{e2GEr0ojC0IxV{;?U}lH@3))`wGO{yuCXE4G&nO z_mzS8KQ+Kxd)m7Re@mDB3z_%)x1X);e!g7P%+b}#C|}#TrR0)Pax)y&d&R_B`NfX% z%e!1_SF3N5UsXfBPra_vAt!XydY#GH%xPBzeXjT+=UW5(ZyfGz`Gai%nbtm(J3HOz z{mY(q?NeFfyZfl-(Vr7}=?>^HcXj6K9%*@3W!}AXX>fDEwyFbX)i^AV$oImc7#%uMNaY&la{X$NrCuv42nYR=xPHe0NZBDZ9#6=e6eS!zZr2t^Iu2 zxGB71v^m%k$UW=~G_jED$^pIj$K}<&xnWH#*o9ZUiHjIs6f7q$Lb z_Q^|YbJ<&;KiWEM?PMPvi`h%pa_exMz4n89(EEn*u0TBT%O^XWT{$$5$DAA(Zx1#G z?i_cPn25bbF8?%g)j}&*e8`p$`5~9iZ2{Tvq15D5`aJ>tbgBEZ1G?~3{EfBy_IIP) zm@Au%*+6I2!)(Ty`Kqh(Np7{)oL005BOd-i3?g> z*j2Hq7?hoTE%^?$?vu8b*jD#}v6^i2NlxW+Ts?ha%)KC{y|4V}ycte1`KD4)wN zK8x8>HvP?D(>Oa0CFbGt}Kf z7Wwt8vQA!|m4%F}7V90r^Q?`}EuraeYtp@F-uW4q$AssRacAZ)nz*^I!mtbND=8#jMR4-`(A9PSE3W=x(o^oSJc;6Q3E#CKJSPlJ8GuR`dr~~wdqvHN9sag1(c|io-f=as z*u9c1i$1HJ#|JQ_@r8ZPlU$Weo~h1e<=r#X*=*y&HVyB#04;{TyR3NGqb@6l=0UxQ zo$;=K?zupWt3Jg_Luz!Q?HYJ5aX?Z_G_tWu_*d&q18`2cT>l6WJmvTzQeJH3^uQm zdUsYk@BJG6q@hVZjzS(dZ|d~{6KUdyrZ;6c`uS1m z_MG?GKo0u%G?L(8RW{k;Y$6O#s>?YS7-Sn&tTD!>=lhV=Ws&tUGm=0@r+8B(JNj_9O zjM;53yV(ZL1FQ|ocAqQcoi27y1r-l+%2xcnt>)S|tP4$#d2#lcjEqTg*@vIqPYyKW z)uYj)bBdQwWb=t$dyfy;Uq0b8w=xj7vS~JBjVcD9Ih-6v;c+}o~hD%SYx9F*;4FWYAVZLwIhNlnSSTH%ND zUH3m)tk(o=E?@a*uN;`u$`7^D`tj7zi}}F^VDnOU3m);oPcPe?Cv$YNarZEm*NWA_ z=-|gvI_Agdps(zzd>oFm%V)WfZ}|{=G~eqC@LfK%%0tDW&hFE)*5`qr6{E+>e)b%S z{T1V~pTCRQ-{x41(7OULn;Uw0xh7EGhnnYB&$xP}kDl8PlMdgj_r5r-XL`PCwt>1LN{q_j>v3 z?i364G(U_d-4WhTm(thf_cPIT@-lSwd8My>X?3s7y!x9BwBlLH-;=_-9DggXhg<)+ z^V+^smfrHIYP)|1jH_pR?614HJvaS1DtR;E@7L6r^D`T0Jv}>`-5>KhTTjoN9Efdu zuCUfU!8Y;NjO+cQwUb?F=e%m(ezh&<*4w<#hSun2i{`!)x2gqW@p?wk->c3@*(=xV zr-RRI^i0=`@o9_MTfWLOd)WM%KqJ>2;42=!tqbU!4YW->Rv~@4c~A4Bix2Q)}w^oq;CjKRFtGy1vZaGiJ`eC(z~s^7VB`@E?38SP`^! zp(fd2&$xB@pAXtPz&jggZEQD%b|%T2q_5<)GFsW=qw><6MgVEpaYvr|iT6yLd zi%%<~l|4=#e_H;Qr`=ony@QCU@5W9G>YW7bENT7y;Epj@-xH_@dh~R|IDhP0EZ%JL z{8!mz zJndQgvCx`W{qSh?=(G09F>|*Kb8SrfvsU--0|PH#^_*EjTray z)5GuF$`jpW+Gmev&@;3C#C(75-H44dfjHe46pwQ)5AGXdHj}k6a0cqE;|IB-$9Px3 zKlve-eRSYKvze@l%WTG4z1K`$9y^IWm?b>vF_KwD=ay=Hmmo@E&Q69czQxK&xEf)#|ei8^m6H)q8jU*`|#xeywuC z{tv`Q{HAMyD7Y*N29p!0vmC$);! z{#!@a&xl(Y$3_O**9RvC_P6V&bvpb$Nze1e15ZDHe&)-Tw~X2MysWpn7CQQlj($TU z?}jn*-r4d0K}R2xebrKhn`p%Fmu#d;FXAmcF>7 zZ|vxMLr*7P?u4p=Kg;t#eL3&$u$up=%=h_uV<+!NJNkDz`nde8Jt9Z4*ABfiK!*SeBeK8=$|?C=M4Rq4*j#b{``TyaOf`>`b&oX%ZL8bq5rD% zWU^D^FI(va?^Ev%tZxaNc@WQA1G%U>=l+bZ58P?m1Hm1Em}}NQ7PRYsA6kwy>;Dj_ zCG9oAzXWv$`fkSW`O(P+tsUEcZqUlVGIXo|7rXTjg>LnKICQK3qoG^_l=r3vL3`c)6%ih|*FJrc$@vDi_k5&^!XE^%%HouRh2ltVmS2@#cVMp2M%o#gxI|FC#{c&h>`Yi$9*d=av1@fsT`J=Z- zyDGqokIrWYw+Hy;Qf~QZTzt+{$+mBMus*=U&a%N?d}>&mq#qyMf6ud!IeNXjkRztWQ}$PV@J&-zIi!3dl9Ket2yKLS<>5ZIP6oCt&L=|v2^j{p`c<{c~;}>yEC{fI3e&nvF2y8}PmM*Sa{g{N8g~nyniD>b*k@b_e9E*Bb+K zXm;HYlnnakf?ERPi-P6E-``0TXL2ex72|PtE}3cuuSO^Shl0ux-DI+(WKGJ~Tf z?0M+0wp*>+#{`15(=ZbCg`aGlU4cM=C@aXZVjeCN!e|N^><~`A# zrv`jlY9E{M>yHcU7uSQ8LHAPo)Ej%N=ckx2C%$3(SNSP9Q(3zwARE+z+A}^Os2Z>P z=lZVx!*bwGbjGWGpPaFn`)sSu-RIW_9|*?riMKt@f;LIc=VqUTep4Bd^Z%)<7ITn%H?po)w6*^GY^3 zb>8hO-(Q?D8D*pShl2K=ppz|n^?H3E##2GbDf?QRj?X$9*oOBTCfK$qYtzA*0l(3F zY2z~=nhm9|d?DZboxx=R`SYFo$nrELo#(w-Qt`99g;^>)IKG5CT zY>zm%_Mj*E(Asl;_oWeefGun-Tj)7lwp{$rpLybbk zDZ>Ny8CU+~r}m3U?bmx2^!xc<{_#z#{q%ypY`HEF7j08uuXCdL_vI_o7ybJk{SzJS zZb{E_~MSLIQ)HTqWIipo}F~6!}*|}+nhNz$Q_X9`-@)+@Uzo- zGgkBeH4w*L0p7V_A+Yw*pkKptcfhVa>0dF>AxHVx8+tl$XL$$m+`@02-14Q(hsU!M!nA{_OVU>siF6?BDDWDk^X-Sy=Ms8 zIoA8PhkBo@^nW$XL2ofQ^D&8{);olcU&MYRdeEGZ^^KZ z#-lGjV^CB2RYOk~T21JyW=|RDHABCgnzeu1z<>JCKXvGz(e>_d{MCyI`b&piY@C5L zf#wXb!5O$Da0XWAA=KCE<(YRb)a`kJc&JO~T3w2h*r;c*!SDHje^cPOrnd2H51f-@ z0`DtF2bDADZJcg#T}roDvxPsOiT-RK?H4zVzjgkcY2#LxcP9R^k8c|SzVlnH%@1Si zy>H~mtu^uSvr=QRy)+PCI%k60f{MF1<7Z3h%W!138q>;dvg{L^arTRqdM8hv;ypLe z_`nxyd}D|8aXgFV(tfay4ch{Kiq8kf_{@&-S#5~}Kg#cw8DBBXv(FjFU+2;~{%Zrd zxia93TH7)7mDAfpi^1A}O=Q8jfkrpEtvou#^X|YN&!~%n-NP8K{JmnJ@!lEG!v_2L zDF4m^d)enqXjkp;M*MiRgUKg(ea>bHN$Yc}e#B^gSmV#;U`t>OeVzW^n4B%QPFvX# zeW2E>HfA!X*5yYWE9dG!{4NT#aq++-SL_vYIkiW;`B60>Hs+re7?V{s=8m$Ltm6Z* zTuh$zlIPxEN*+HKlV_a_x{cL|8e!MCGq&8hY#;f&#vpB6{OIcMH*pe+Re`vu`K135 z`IZZ|_BADkY=?6Lt#}rzv(mjS{PHywjJqG&T4P(~u4;u|HjpQ7>ZtC5vSV}Rwgl|g z@Hn&f_VUfOwMZtEZ*0KR>ms{i#vgWy+3sOnI$tr+c-wozezvF=HQ;_=zw_$*v-N@d zq~b;%zh4^Qqw~ao47sI$Yhd2H6}vqzRs`nh`_Gvt&pE2OZ_ONfTVO9dF)xGZMn2a$ z!7pdi;TMZ`p6pL#kGs-*uiL(tXPqAFY$*Lt&pbQ%t><$a^V&0=`I4>YufB8|L;JpV zPH4I`F=Kbt20t}tfDUckxv@w7L9W&XbZ-wTZ)A}#4kh1MYvcMyiJf`5BzI?^Ed=DN z(K>@GhdDKKS>TLb9oVmy@bmqez#Jde233b_B7;0*alvPNM?mJdzY#+=U*tg(A9}QL z@eyAT8~W)Gn+<`S&IjbtTd^_L+SvR_6C3d$bFp~HwRn)l=Zb^4&J6QQ`R|;ReXYOV z5w!AGO!&tpdc<1%_(y;F>#Xs0Dk!cD=j@@-FB+xE0F)6= zF353*h~Xqz6<@M^KSb_gviLVimNon7G_HDJ&$zR++_`KY`MTO5ZCuRgYVR)o@c+a> zEb5sfHx~u$?CWPHbL@t51Fd)#t0{W71@c4gq1*v<(odFnshMkoqk^)bYK{(VQqA$3 zyteMhgz~F+dR=5!y!fN0#B293E}gF!XuSP9Uwap{?|flh@-An$XN_2_3dEy5Pwe(C zSa&D;p!~vby^Wn1E|xz&k?X$p-P0w3Ge*`;!HWa+BOcb*2UEe?01w;|sJYVvy3DbW zZ53;0y6VLKcMs2IIjH({9>t*EiJYZ+2k^{p{T3rO*;Dq7dk3m_0NPm`F>bViuRmo>7VN8@9pR-LX-c5K?eQ) z&Ro%A^|5@WAhYTz!y_Kb7ub3=Gab-x@8#ib=j{KI%#mlFuHt=vz8r7o@V;*N*-iO# zVMqV-@G}#6wfESeSNrJFqvptvo7ZKJHFba=Z}G9+TJ7g2y5!q~uFpYg814C`_l|K+ zV83Ra?6ZO|3!WQz_G}Ke1bhT`IA3_%yzdD8<-^(whc*0Ud__?Eyu(#3Si7`Y^Bi(N zs6nmxj9(CZRWoPrR|X~bIo%rGT6=c4hGwrldcL-`=PqbzpGjKU_Z9YCHtc6}yZ%te zU;mb6YxuMu$+~)yD|wQ0kQej%K9BB2^96a8KR#;mXDolu3l1fJ&(A)&y*;Sdi?f_n zEcbS6S2k-)<E$={CPfI z61Xdz8TxaqM(6V8jK$%;fF3p5+S%&r&*qPIXZNj#>8v`ptAcX^XIpb-jh)#S1#*6x zhf&%E0h=qPHOJR}4&V7>=JB@kn?r92+Pj<{F}x)pXICJ0?+NH(PQUN|%xUD;GojtL zbF}*D{pxa(tfh3)Peu56pixcn@g zhpL0GWNQ^)wi%mW%x=%s+B436ve~*jAoI(E>A<|WIKw^*sPVIdJ;A~ls7E|v_h8_h zr~&ij*83lO)&_XD2AZE?wsl;(H)pM_FM8#IJtfb+^}&kZ=s+Wv?S3Z!?}k7QoEM*2 z>E_EgKWc7o)(Ndz7|{_@G{4Fg{w!uc-R!B@*a!Bhw+8}^51Mn!m)(KqdF4cHp?3u( zOKj!!yg`8-d6?oJ~>z&oD>`r6hEJ*gW4ljm3MlK`P1^V z&zgK)7_ezga8$t0X9e~7!JPVNZN4e=i-XFyTCKQ=AszDuI`}Tfa(HQQcaS4BdUq9jwRTx>O5puUJo$Z1pyv5uf7O+E zvWq;n;C(`HZ9u2z7a2e|ea7x+@{I2Y==|f@!C!mGlr#3LkG4+R`eaMh=(u{!^2i?X z5O=nT$EJXNn}aO@TR;qe{XZJ?{)!8G#FEdS8^{&De!g-_XXV`^0U%^X?{ zeNE_EM_&-S)wQvspU}~N-F+7SSV#Lj-^zPeNB>AizpbOcy`$e0THUG*y*m%8w)Mvj zv>I^^%sFp*zU%p{S1WqwN`KPOx1Z(BuL;x|d74@?@BQ+&!2SJ+1aLmRdJ{{{GgqB% z2*h7AHxsDsp0}STZyf)m`LK`p>zv)%(0nhN?z)?L8sN;*p;R z0!=*Id3#F^TkGC4f2exv+{+2j-|9fSQ~2bb5D&Q;x6eD%DFMFgf?o{y?0bQu2UuSl zYzejp?!=P=>(-76YnGLin180H^x#NR9w+G&<_{awP*fSew z_DqdN`~9dpU5w?Z2Q^HHoR1v*V(`zB()Rp;rfN<+q%QIXlIma_oI+ zOK?oECa_-od^2D2>TbhxQy^xZ=j0iy7y8hAE1Hhm0?qokd4ATsT(RBU^Z+u&0By{E zu`Bz{uL;CsDzGjt6$9(FS8hv&SdWt-#$;R^jFaK6FB#`$JWhrjka0;cPKG)t8Rus_ zPDZ9jGQKRmxRWO@#+w59aaX)7*coU$f|mzH(=iV8RbJY0%eyx`yMuPU<|TxDu-vz;%;Mig8K4YtS@n?^*v%q%a zrv&sEyC22h*fWH^#&ob>+|efwv>2gJ8tAg2-gnCm&o%qYmWo%|bHcD*HsOV`tKwF+ z>8+Q26<>4gsl14rb8VguYn2l=pevVbM6+4!`JinI+(ny%ErI%g%L8-9?jLg8W#qdT z$zg}sq1OiDvoFxxA96yzJZbms??!y?P_lrZ+XFJ><CS2a_$(aLS*_4>)AQy#^goU+?_*%%xXh$)%vT*#4MVxsX~ z4e(X&HNI^K_@S1>3Xj~FJ2T)z-LY3?tdUW2#aTY=t-O&>Udd;lwj8-t`>nll)7Ls( zP_dlJxZ)%x#ozn$HCgk_S|4cq7t?WP?1Idf9C_d)Ti8~*C!I056vI7%J?93R7>KEM z-~Mj&?oCg7p4i>SmVSEGFYsIKtP89`tHXZ!mm{(!j|U47~3Wvh*^4fr!De(rjH z@q_H;#BU*d-ia>@#7(O>sUz|{gXnDi+ZbBRE57r?c#>^fvwpC)?aLlb{^;gYojJO- zvbEyR2aq%8VQo-ne!2JPBwr$GWP@6CCa*P-X8ioo=o3X}b%^tGYV@@8* z2X$z@pRc>Ko-wt*ty^~Vd8u5_XH6_t1nqdaad=wxX@?^YY}6Ku13j&8a?2O>=gt`C zKe=SK`zmhs^)<2FI5=DO&INL&E-nnTcJ8Rq-YePX4!mO+<5yGWTmCabYwcXgkS8*3 z4UE-PAN#5iYkU@yc1|qRp%~CnXYAgLHF7m|AwEY3VmKRUY8++*O^wO{UHqI1*m(Xx z^AG*ZK)m?9br`ok`dncz``BJ*No@JR=JMA*>kC6)iF&O8g_ya%N@i;%p zoDH zKfKy~`@7L+F*3xVjYS)WUbbi4B-!+~a*UUfRrYTj_o$%ai{~@3!F%dB8_cVX#cXKf9@dfF&V-b^MxY(+jHkV?Fo((iMR2?wcR zn(WUTeloTNVtQooE4iojI|83o*vfBpH7@4%+dD4ill*ip$!mS!8@=XxAMk6HlhzLN zy$`=T_#khK*)InbL%jSQr(=GQGn-y3xw9i`zYH-FUuUn@_3eF0wpeNMji2nAx3|W< zj}=S%jt?|rKBzPA(CSD`tEMWx?j|v$TaD2n&RR?VTk4d1jZf2~(f)TM_SN&CYDCQH zoZ;pF`N1S!^X?Nm#Ie4|+BMA4dG;_?$7EX*zq!C3bt1l1GsbrXl>_nhtgra5%h*1s z&sO%b!5-fQ8IRK^zih64oJ_iaY`RJZUf*Bb5qNK2A7~qbm4UTa2K|~lMSWD9*jjNC z+Z6%3y`LJh+Z`oN?jLbtbHzyvYg}s8_FV^Z-Fhki}GG&0M-HilxUUd2kQ=ULgR@9&1AGFN9%oHV{a7U$t`+g-L+ zT-1zuaM$o251{MO;$MX6Eeihi=*9sS3qr$e3B{I?H3V^d$&OBUO{KeG7S`gU*l z@seM>^!`P7$<$sF9y*Fo&z9n6&r$h9Wa`A)aYNtxe@1xZ0gu|z_dIV3k2}j6JN0U^ z)%E`H*zf+Wc{U%Ff0vbR6btl@*eyr=K%YAJx+>##-#fCe=qw#^WPbkF(kFNH(>nSq zLbJ!+S-SizlkF!pbMMO>pIX`1cCua)IxGj|+&9Q^XH^YW&dIMhT0!|Lmc6 zkE7i|`q^PTlU}2bEmfOeFr3Yb`@8ao?{;ELtLO7s8M_PJd#_QfY4r>cw+jOCI(8U4 z3*u;Ak2bcB&sZI+OJg#`+1MFyHjJHRKFHBrz$f|F_~A@$4#dtF+^gpf7s#Qv`t2F73p^{= z2l(mL;}L`Ei??Ly`+d7Jw-As4#=V_WnXC9Y-ynW!#aPVbPt3^J70^{N-jTiM9gvXQ;Ljbh<5fzP{mwMn+| zfuCjDbjEyQ+x#%*gC=(F2aSF;WUgw1j12*qY!+AXWwTm<*+8R1T*k%0I=OPLwYr?0 zHXd#6=qgmaXEG-~>jV14zV@@99qeVt-9i7p#P@M|;cLk`)EW|FHrel9-59V>t9;2H zp7typ9~vJU)&}j_5M%u1zx8%+&pV%WF_`4%s;n*Lr#My((MJ}a*nk$_TIb_*u$104 z;i0$gIP%U9#6!;cv@0NYZlKMnkBSRgtmvBwDh}q@Tzvh#;XE&8A9;tvzOqq1#p*M) zQS8~}{CM9m7PmT z_>m)rc;^B-oC9m@h00%hhVk>uel{ExXf0hf(WlWb##+@B{(1+fyLvuz;!*t0(o+27 zxI4sz&Gq?{EOTUCF^m_hVKL_?|M^(syD}!@#K7}_4mDlz>3e>P@tT1Bl}~+p{`o0B zWN#V9>@)9-Ia~50FLMF8t$y?J)Ay6~*M7boJ?v!@8ExO%-r9@LJ$+Bm-_vATd-a$# z=UKf}j__8Fc4w@9#Nf(dECzfM17|=Cst(0LzAHCkRpT~K;#zSZ=eO9B+4htCrbDYd z8MBceY?OaC(l;(o?4_&k4<=8}2^noa$zFVN@gIUodAfJZnmlRzsaUF$%AMXhT@h&V zX-=+M^!GU#n}e$H3=ib2&7b%@7P{$^yYjESPuySbi21;nKgM#iHPHNB1h%2A`|q@t zt>)~1@9VZCa)$p3bHx+nxl&x1~tQC)aY|?fG#@6&=c~PK|#m-*V zBp+wPtH}!)_Nz&a{IaKfna>=Z#VcOsdOml{Ynu6$8E*|Vf49D+{r<_HW=@+TVoX zqy6;#Txj_(`W+qrTRQs99qr$N)Y+^$q)&bEO+P*K_|R3iZM~{P>zdj!RxkGjYHRz{ zqigHr%(-94dSxJ|V#lXb0(Egs@ScFIdxQ1C(*n)DeZkcMeK!tcd*$32SsQ5mTueD| z7xQs@pr+}hpDuF615JM~gO0n0^;QO-?6G&T^|IYFQ0wKZyK(#7jqRF!>~^1N+tmvw=pwT(GoK4Xz9DT@`5e2XgZq zL>l@RgQDr29dtg=xWlf{E&6qIt=C%7)wewT+_*h8H)&tH-tyFZ>8QTt>F37nY2&R{ zT3SA|eZh6XilFkYCgt89aW!9Ox38Zp9XOBpZb}aHb&lOX4>|Jh)wAjXG^CuXYJwp zT;P5zz3O94KyS$?`Q%+3@JBq$rp5fBe|qqUWT!1_S7kKe6d{2^by z?B@@^#8&;0U3WLWHGw#2WR*|W$|wHupA7mh3-Fq6=cb1__LeWVW{kJ&J|<&z^FUB> z&T#ZxCy$TpmP6xlezT2^)^GVETW>%A`OW8*O+U$Z^2&GdDBs0cBeS)q?i0MbgVvs^ z6@Ihf+Tgu`*4`hbkKesMe#?~_)cD|8CB|0=8re4mFAmstQJ|Su2UXi*S$V7f9^n^d z?vjB0_S#c9Iw|9Jy_fZ>tUFt5Y5B?qc2=HWn{nk?EN23ZJ~i@Cz_--_JoqfRQ8#`Lp8{hbq(UbY%<4YZHs86fsW_kV}x z;copGI{Jq@`YS`zPaglC8v59V{;Pbaz_wcdrO@sAPlT4YTE9PZYv0Q{`uQC_*U_KM zcODgwk~!*i;aAqIz|mc-HhQ1UYz<*cnU z>us&c!|kaR|IK!PTlaSYe^a@wHTG-dI)^6(ZEb}-u;w0W*T&VI`X;}vU9nlJe)v%~ zoR;xtvwrG+;s5E4?$74^;X#m&Z}pP^D!G} zZQlEPuWG-ZA7p$i^2vNdpib0c`*~iRwdVz713A!+Yp!~AQS0r#8ZXtiHn<~O+8ygI zbeDOa$phMV%IaBdyA#C4v&{X=FLM<)YxdTfyw;jCP&xLzmSgs|_qaP`UvPe)F16Zo zLdNzyH*nT9Hm?rEy5cNWM+d%tkViV!1nj>iz*ju2ZRYT>M~{y^El=s=i*#n5^qeIF zulnrg`<$?yeJ>5fMUw;d%-;C3&;4fIdfYAF=*o|Rv@;g24Z%&?YTWN<)MvjYY&?$_s`B){fWgNHg~#vn{Dm= z`E@p?S$qC~Ytt8;?;3x$dbxh_p!a3z3%&lY9eCb1^zHhuj+qFJ*34<@Wo7{TmkWD(-f?qymNSp1^_lHO*BLB7>+Taj=jd~T zil<&Yi`N~;S96~;yh|LFamjve#(&t+zZ6=|$e0f7cd!0kzL(gPp3XL>rK>%!|9|}V z*IXO_*ADR$|NpPYPkmL5EmfoH2T#RHU9WFqwbcIFr^f#|--)TwiZR*V1*(SqUFfRe zN$1L5&HEsb!6towwmiqlc22%&kS({GGu)m{eAeb08$ur7Yk7NJ=r%_5ebFJvsaWx6 zs@d;+m!B1@Pv#3Nv0`&Qqs0ci$M$G#6c_i@wt#H0_{PXPCV6dZeX>NN2j9r9+|g@K#e;vq26aS^+}#?GRW`gXV~q{w)ODe1 z!d^bVJvpg3oE4h?_Td*lHn6MLg|-g-zA%u_QvCJ-3>m%~C>i#MmpM6JuDr00{O$ALX9^W-{@fL?ziOM! zvw^lLkWcxOyJrV%xj*pTm@}x|7n~ie3Gj*u{?fy4wdw4OkF|;c`Rf9_mj<(eMz@@4 z@_1SxCiuysXHT#_P@iJhuJNs13whvo7VLd@Y`G#mnY)99K;5kkt_pO;Z`pnVwg_&b}?fLI{CbWC*2~DOwa;6T&3ctF&W>~NNzn>qLv^Lxp`q+V= zO*e*a^_|!8Kb#+G@U`UqP-ywEr)+Qr*uhRc`R4>xyUq{(vx093oT-n-*ghBP{iJ|h zy8`m(0`{ZHMf2PEnt(0#@!dZ4p$4V``>a>JvCsEH)^`TlRYBPy{_}zR`=US{*4c0G zkJeW*)xafz=DEU_HA7!D%O2;ee5iV5pT*3(?z&*vk zm_CxH=GDqK2Yi=T@jf@eQ+Z}XyRZBcqnekadjk8^XYufTPrw%SW^D-DqvAGhjea)w zF??m__``mB=@=JZI@#XaMt|8YuD`(OG;$7yPQEOq^Q{M=^PEB6BtKVXT^;GwQ9aKl z)erxds-JHec&)YhXDMEC*PplL#OvD*B3|GAS%}xl$2eZ@`Ol=j zzT+U`^_`!Ec>R2IXv?_+4&^*nybiU#JcE{dpMQ6FAM5k@62VFnFVA%EAD&-l1@57Z zfxAfaOse~4sr%LbrS5dHN|(>8YlF*!rJe_3G86Q7GdouYs493sSodJ8;%{O+UPYNy#9tgDQ!2aU9CgbvBDr4^wZwtg=|2x%+k-V*; z&kwE)9vARcjK4R)OHMsw#F(7#3;H$pjd*!yrccbt`Tl@S#{}}>osu7GhF(m?Wj-)w zvvK=;*%g{?=LO`W)yrHUFZ9w!j{LBt-jUhx_F$3?VoVpC>E9ew97=ZY(+`Aal03e( zwx75RdG9y~d2FlNU<04a7Vnws0y+A@fZf*w;&EA^My&l%(5_t`T0Y6GJiRVsx@H2k zIvZ$L1(W#H$84bC6U!}u*xnetFHi$yYh*t@kUM#U@`+CJ)F+$#_h;Cw=JCkeJpmi# z?e&3kS+P+Y5fBCLgYuf@k=znLv!?lkc^pxDP zbyeoXw6~L7ZC4;p>}6lQLzJ9Jc2~^r$sV?}{OdyVNi5jQkFxJj?UIMqzk{_a+YiK1 zzFrwPA1`k1U^Q3u%cn{8D|Q93<*!zCZZBKa$PW+m^|^XuX!$BV>J;$)NI-6TXOc~x z_&FcsT0bjLJL*!b<&a!*el%d0wfR8IHw9CH^>KB(KJ)I09}9XLS{?S1@#Dcb9r8U% z2Yc!GiNIan`YA5ruQ?x@zTzYXa9+SZbz9E^vDyE8+y9+``Q_lGflvI&VE0c3&OmFM z*zk+}Y?uqkM|%$0TYmpv8I$uuL}Gx}fE!n?G{=(}9{}3;JC_ z-HH7FnT8g}Z2=wHN%@<9bZY+XfZ8q_?i^@wG$(hbcRZgLdLi?r&wl)TshI1{>-j>K z+WxBMyH0Ct(;pk);m`50&mOU>wd%zX&I!oV+>LaJ+s_8>u5St4FKYtNsD}bJ?+xsy zmySDw%YqGoXPtUGDYzlPcT@1`EP6NvfG1@h%CQU~&jzA)g|nn3Nz z1O0ao;}g=0v-vv$_NayV^nA0XZ3>L}CD!E^S?p#{t+AE;>}JFIK)%)lY|%>I=8U%l z^tb!v6l(t&8Ixmw#lF_g&fH8OzA=6DeYDv8c)+gWJ3nK58vWu_`YQ(aTTGLGb4ANB zn!I}NxHaR-LTk3mNx3;CM7>Mzzz}y9a8dUGt z)tFd*B(Prd86G&_CGWhgdqBTAP0gvtNjl{O=sG3X z6OdCjy)@(Ean7y`s(#SV57ZI6(Cpa}{CprU&W2|?d#pca=%1awd}-(1QRUN78OvY! zB(@r#$Xm>(7iYbE64&yFFV^UMQGn-}Lw`(qz7%iy-txD;-yB}CBFmVq6$fz?hhGTl zZhT?J6^F0R*uEQrHV!r4#=#!3tT?R9SQ7^}?+(al?Oq6ddw@rswXs6C{OnMFc%4=E z+J6aJ9&z*esgI?(wqATzX#bYZOoq9Z_mt1Ge#NM}UXVcLtXQ#|Kvj>@)97%Vp)syggMjmZe7xhe@iAu0#ev%JJlGs;3CLR=STCQ&ulzA)>vX_Yv9u4pCUCaM*cGU! z(jhPO+ArSnz)vxp4YW;xy;Vc~-}(A*S7Xnm2F4K*8&_5dOh4K%*6gYDumm-roPbt3UJ; z2io0*mizMq`6W{`U-C*%*|Stl6<_(IC!75m`^oUR@!`PPIAb^*do%v?sUwbfRrK_(s+}Nu1}uF%`3cc5^UmkhUk7HApKRTQXi3 zuzfbrt_(H>M+RzMO~|*q)BAMUYyIxP`u1Q$z#i?YU~@n|KFvO{*2ofXF|uE55{^*} z-k)9!L5%smExtu9(W#jln%p#`pg_ zP`9389}JxR-wN1qxZ}h>;8*LjxV*3Pnf{8eJ!}rks80B*-o#hE&jc?G_~b1%1IV1LE` zxQx}adTP&5$OATv%cGd(jE$b-Wy`+Iv4x#-KsG(=1NA`<`>d(?-wfLIwV@~Nkw@>G zV#&7)0(Hp8*1l6iYw}ojsX=x*#$I#I%W*;Z?_NgV88|O; z!%sO-qit-|4H@j!(0Iwv)RVPVA9+s?)Tz6(>PEc8NzC0#dXA_%So{9}!^2VOu?Rd(b%CY$HyKFikV>X(|uY|-_|d2Wy|9;zSl(BllFH9&Wze9pYWAmo>OXvPR%@fYu>X%GtUn5 zRiom;X0=Yf+Fu{=absYwwH?7ngLZvw=t+C7$l8+w&l9mHug;ZclD)03#@a$K?%myU zZz^y${xB%}ugth&%0~B_ILrn7hFb{vUX>n_UIMk{}z~+$4NRK&RW@= z;Qw!IN@qS0v>jF*Q_6G8%W@^oOSR2d->?=Q34s_+fJ>VXpOWn6Vl8Jvs zPcTns(?Fg6Uf>QBFEM7%Vt3e|4ZKt7 zHFsE@eS7~r@Y$BVGea-OK1+~apL>f(Z(WZ^Uwp>r1Y~LS7}N9LhyE|px4vG|`MxT& zJr%p3&-eZ<|JQf)ouOO)ZK02C_Wwz~qqo0}yfbI(dXU_A~SY6AP@iBpC=hi@-eoyw&OP+PL zhZbM7dE>{TKK>?h`Sr=5_2;tK)Y2D*Zu5P5XfY`t)(<|goz47h_kSw?UcIFs9_Y3{ z{x*9Kr9S>g_D!k}zWrSwp7L@y&Kg;hYQ)`rNuXBg{-1$3xsx9bE)QNCxLZCI^lR4+ zYkxmx?dikX{~EJa_tigSjb6E$4K#NTd*sD@)u((^ecIpGXXTN1S z=FhHStX}7W_HL4=n*wskUycp#+13WNRW^`OHnF2@Vn^A;jXR%^rPuXXW zu^3eBj>))U$G(ak+njCuWtV+r3xCTN_Kvf~bNR^NaO$tP&|kLDU$%%>Z;N|ROz@R0 z_>B2fF*+vWiji1UjKrd1Bo<=C4)G})$SE7x#s>Y?KznQcjzvq~5qcr>&e_93`B3Lt zU9hX}*Qt!ZDtqve$)BB}`BC)W=8uxw$5!)vL9@5**@4ERKNvUz)nw|@h|X)yzRlpfDU=n*E`=U zGq#Tm`^1D!d(Fl(z ztoX58(?2IT9I@n=yPa+1va^p%#WG8yn(Fx{`Brgj`PEJ@U)Sy-D#9li5I<9sU2OeMj=M4M$;(HT(fj0V#@g)Y|M%Np zXRqDMR=M94(5ba!cY%HG24{#Z?tsezwd?cas=&H6-zRt%5flE~Q+|5)p~L(g0U7ms zhIH~*E1hI*4ea?y{8FFpJ~G)|{A%RHK(m)EdxOVCkvigE`JgA04gMy7D|2n;wDSMV zjQ@AABXA$h2HI8oyGQ-*0bBaJgD(2jI~&QE55x&(18sKn|DV>2$KG*wTiI4TljQJE zqt|)HZ?E~?&Dgwnii!4jiAhWQ8&@su_dL+sg3@t)J_EM2{{~D;ugsns3C{-gJQM5< z9tjo#wJY}K@R)Nx%!z}u%Dy9mw{`aTEHAFd1@@>(_UY}_i=&?IcHTa;y?XVjUlp7a znAhabSnd5&aP~0%Kj}S#f0*R-JssrnWlNw{9*ouM_CQS7JJ-;&87CYE z#m|&hek*Th)}|(`Z^*p8n*(;z3vAjGIE&88D*|)t19f$D;GFz(P|pwhN}jyqv8VQn zrFiTO>RHvV-JCUf>*sIEoO(mAmdzFOFAJaCoEoSpww2x+G9IUs>~T8r!fc?Cqb6FJ zi}`YMc*n_I$`|YM<6Mc8Mz`@}p|9#;oW9-Bc`z}ne9UH_HZEp|BD1eaah;_gt#mwA zavzJjITTyR`RsR!+_P%lou!F~dxee~PdcOWCAMU^U!3<=4!Mi%b?!C<&c!63=;&oG z#Y-OB>0gX@A?vdP-*WiXGMmd!dS(Ohs{IF>@3!XIOU`2PVDq?pp_NniEGCB@eDlG$ zGrBVKJ`a$)B53bO^xELcp#0vEaXo+LGQK^yJlGhx!ygIM%KBhUFcZ+<&*8Pu&$H8< zdtI}?c#NTV=m2x_QGAzVtlrqKdB6Nj@DSinI8#&lxgi-&C-ayhF9Sbjg+6 z9JPq9);4@)+wP3V)yzWX7pu+E?b*7NZoG2MhS@-qug$@h;Bf=W4)H6WqN5*XSl2P_$c;GXD z`CrLHwd=E2w|`&>uVW$E9z5dP(Qg zl^uO?M?bxzPwnXb=a0vB>z~T!EuULX4#YL)9N{xqYt#32^cy?+YX=!>p=8W=JkROq zT^)VqAY)AJ=ILEaNi_z0*VQ zenKBN^mx$4XAJFUUi3-BygEQXdFboi-F}Vys*{(+K6KqTJ}f|)==Zx8AoH|KM?vjI;D zP7A&yVDHxl-xK^$@UFnwUmsi)+#K8*yfpZl;FZDM!M(x#!Rv#s58fPnYw(>x{x{0K zT)ETH<%j3XOu#?!y(lQV?#UQ$zkhe;@XG~$>(2;0Q_Mdp@XpikbNABcz7}WeWe2-v z0(aTxW-#%f?ns;++pEqW0+pzZeW7cMdwd2REJ#kq3f-!4yPu~e+ z*2F-oy5lR~ZU|~Del->oact@7j#j(1{?*NRK4bA#*L;aNqu(iSb5K0|!Naa21M=j6 zE$XxKkRvh59X|4kkNxBL=u-P7yWL}aLBRjJ1A1E-#_B}h^0BM#5@)UW%(Z;v%0<~; ze9objLu+1djyk19h(E=K^;~$&o|;+#0Z(ALQW2>uz2hum`XFO%FXCYWT!# zBJUdl{;UbuOOE^PoPkbv;Je$M8Pg@^#|-1vUvl_Wc9y^TmXDrs@vFG70mQ!5DfjfZ zvL@xs{)%0zYpK|=ReV-;@nH*@<6^_6@>yJF2Hwg?Ys;Qt&G)YECb4ig@f}~?P3{-< zA;;`zml`-HutyUcF|T~wn6Wjqc{G1pT5Ys6y)8{|OViuZY-wpWwzOwnOS8G9`Q6fT zT6A0Q^j1ul%2}IV{)@l87Y3CNIep@g)Abp%bFrL?9X|0`&a+qE%3d*97l`c}g6Uzb zPWUw!uu(&A4>ks3p*=5o^Wl;3J3TEpq{XH1zhMzgPGS>VHk})PVeF1E0J;_~d9)FctJNtckf=m>JeR1M_Q&kD$k`w>FT6pZ~SL zUAMpL<4IwrOFYgA*ruruaw@iMEvS{Mh0o9Uo&YbjdU{%J#eBKB_1;|i``ohUU~@a2 zJ>V>?51fxL4fyh$KwRX@8M-GJ=Tp00`NcmM>A0u zaRQ02Mv}GJvMk4Tyu`kWWhYJ?ve-$8?L-;PjHOAW8D})!LWn~MftIBXOMtS}v}~mX z+!iQddr(5dgHlqKv=j=3whzLV1j1uS@Atj;{%4M^MqUE1?fbl={B_Rxpa1^d)GIxNN}msl?pED+#7_m>+5ZcPxYRzXRCPI&Ay&zQ#CH?qz-aGnZ(E zMvmG*sxjXyz!sYM&6xPSQt{y)-h9AT1L}$~*O*ZO_PG2uW(^zNIkB<1hQZ%nji`^? z0dJGQXgLdr`R@zxo!pWy8ot{a^{`0LAaHq@8xMHmJ|?i(!)JLmyy?zrZG(WunvLz~k^xUo)qndSxcrlX!s zdL{fd~3wVGoC`C&gI8@khDbU%xIFaIIU@o}LHGykav&KuK7k3aOtr$+}pdx4(& z26}QqzaZ+#C3E%~J!kr20lJVep&P780e`!5jUc1%-Nyv~B>0BlX4y9?XcDd2gdBkT z0(xTW?iFm|Y+5bwDgaNu;AhNPKus~eU4RVtok`9e8a9}2?4ZuDk$P?uU>`9>2Mu44>-vI@ z7Yk_Ql7?LDf1ZG|sYw8x`D^x@Jo0Gu$bG3RU(+B)oV`{v$iGv7?70HkEds75=*8x= z09%}=%7dX$C3ZNrC)C6PlKu!k))QZ&!z2SU~pDG`ETzwlgcl8lda_rJzlWPZKa=l4_ zjnupCUFr@y@edq!BA*xn@NE{r=lavAIXda7uQ367EQX%O2IK+Y+?_ALCv3EP4d(d8 z9R1{nvEk9%AwZXlYt`KLquGfc>;ujMWMU)np&2ZqNjUKBpi-{lcnGDM(wCHr#sTrEp-hPb@ z$Qk?gask&b+V3KU7vv0ON;o5hK_|3jCjj>^o!0bl8$>aW^O~i3K z%^stp$6oi^agXNc!6tONIfNeIx`Z!Qf3BVETl}}Wu{<(&d5{z5vs#27u=5F-NP-nG?y zBERg*w1B#ThDO||BYMj@I*{uNT>lu43E+*>T3n$y8JQvvYALCcp}79qCNCD)`A%%G z!}b_wLxX^3w&Ro0nUBz4BEV*s2U*ktHEyw>CTJE1r^xSd5snMl90;@?p6^hnoxdX>PokyRzc>jLT?%K@D3?4skZWtq$$%#V!C} z?vBRjf4PU^x@LCa1Arc69;t;b`S^RVsSg3 z{m4lPs4;Tn3uu1uJB$tTjzxpt@cROqAN;QIuF#zKELW;WpD&>847;E%@RPd0mtg_E zkQcE9&1#3eNB!ehs{p=D0(ZZ_W3r$@r|lVcP8~33&Gx$+f4)0JKI;~5*2xF-rk6Z< z0%`$TYBC*-q1z&04cn2&e#akb8CvR@`5{44KrJ;0439o^;FFD^UoRj|G-8E6G-7Ce z!h=re>47T+*no{=0<#&OtYCwHMlC^aH3c1Gdi*19_s~x?b~*ZSx0|^;6&&| z7R1E8Rv{Z+i!nBS&WR2Fwh4$Gxo3|NAAE<_uA8h|UNj8i6^}hS&`l1o`D>0I{74IE zCfnlLC>-<~1;owz7ifH)fOTRCAGVPP{Cc5)7GH-Jdy&K0WiY5Q4IAO_6rj(w16igY z8o*?cJLdQa4gMn=8;LP?k#EM-6|&j{@cRN9J~Rm$1n?1aVhqhefyu&8bfFV~4q0OY zUw|%?buxNqlS@pn+ibx0tbj9z7*PxOYWv)LgU1)pe1U71#T8xvf8gIJK&I6?`y(y5 zR=|CZ(Gm-EA`@E9AI83bM$Cvewr>_7!xzwq4f_ZBc>KY;wrN_;7jY)P#2Q=8=D43) z3T(m`)@HMTIJvrrDYWqU0vdV@(9e3W0N#Jp9>ShW1k??75j*U{FINtB5GU#qUXw!% z-h2!>7Ax1z8^nV=lP3A?%0FOnh9V81V*?F_qWk6+l` zDv0}s9(-}_%xZ4*%^Gv|q7OT;+km)w0{lTgF(t;x`<8P~u|^%y+r1KYU=R9{>*`Nw z&N}ifMsD4Z4?7EN9o^X6E{;2F7E0c?M;Ai2-`ah3Q2Guu(vK-RmaT9dr%}h$l3} zg*qe-$N^ZlJ#RILEaR=m?IBA z;V~Izvo9QtXI;e0?%CkMAH(m^xJv+jwtd6*MC1Vd)Unyj*y4me$n^y@a^l*CPsGL- z(9nthw4GrWtfK=uizPj{=LtBMk((0Wr|oO%2OqHoUUa#!pRYOgn~l(&s2}9m7ts9R zcg=R{1V8Y*ThJrG4gmY`-*Si_)Hl8mzjQRV7*V73_B3Z7055#Kf(8NqUJ$&O2#{&~ z8U}h>)l+xa$eGtEqp%g*Xvl&FyDW#qj%ypu4}OO{DUIX);WK-}6Hr^!$S%QI0`|$h z0_-#$mKWy49-q)l?+a*t@H@Qr5({b+-8lid|Bigls^1|%Cvr@ehC$5HV|CG}G4xjZ z8V0pywa=WGG%!#jp4ex;5p(=PCUro}+`UfSVJ9}ElVPmW8dHA&{z20uXcJHqzJO*n z;0re3=WP40PiyB0$R)NQlkr^wsSWH0M~!1YIfafsZX@*AXns*UwimD$JMnvqV1a;j zH%At4>_rap;DgQ=(C~-2&~^&k+M#BAL8E|pQorm^>^8rM6Ju!5VZM(> zZ204Hd5_F=nrv#!Y7^ZZ0&Jruk&g`WV*8l=NG-C4&8+zXT9-iK3Yv}Ma^RtE7756O z`DA>=%XC7!SpY5d=h8w?t=uSJ3@x$8Z^p!uIC1~MK3Oe5HvZCMzs17nvFA$;J+jgQ z;zKUsK?gm$>1mutYcpD^;oR28-1+;?Cq7kmg~5^bF@ygoMNBhhBPK-!~^?e_LR*v4RUOA*A~`X zdFVz4^6-z^z&`dA{#mUe3%{U+#_(oG+-H$YlL@`6cNqj~$Rf^MJE;4n2$0L%wS{;s zmI3u@2pq97AMAWNQ#kUDJnG7>_4qa>@C7vDfG+6T1Y9?<%@@${-(tTrz=Z3ZmC)fI zJ^6i};5q^K2`8%C7cI>Xe%JKDZ@RM@+x~3T7=O?QfQObkqYfJcZ&FR*lY2HJDUvvB=-o(!Ktm&@zIV~=OoD(LDnGw zdx5-c5fBGtV<$K_$ILGi(9qKujKb?MXD%|w1<3Q&)1V_>ZY-E1KYm|fwi_*W0@y=* z=`C(;8e=~=t0`!(ftscF1+=&yet@m{5Z7nA@O_bhc+=2@-N-iG;GhG?8uq0Hmg8QH z@t6B`YK7Wr60`}74}E~uDr+Vm9%TCh8onXhXx;k#t2#QyM2lV6*(|^wTD@9_4qeEn zhu0U-*qg2$K1ek`_#MV_uEz0LqSy7URde<_*F)lB`_STs4FIv(EFhN5eF4qAK3iU} z*Jn}9;$}5~ZtS*m413xHzJNx}x%(`oIS`L~JV#cC*x4J&_?uY#IR`ic-I(ArvMmn8 z41LHqpRMM=V_$>7WWWy)6KpX3(0;p)ev1*gI4$c~Mz;8L?y1iA< zC`b!-2)Iw;?4Rwtf#1$P`#d1jw9lT+nxl_>3ccmZ_6oX)8FOS2J9J|=v6)RbdCm%K zuWZryY{5nWbuuoP5)gyy1nA}*<6NTc6cAV9fPSk-?2E^wNjUT&|1N>W7#opGLtajR zENrne)8a2wkWaJI;*BhP#uwu?9+P2s^uu?r0KLZN#^9W24LUxnH$-$}>XD1j-GUwg zx&dNF9O$Vza?vaxH^lOV0vfeJLk@D0H6)9NyztOjkGx_+AFT{*m zXWlCyz8}}#jqAZ5%Ui3)#2II0k5hY!SqyiptI063G7VY#!o;lIfyz7~61ck^Pg zhkmwLW7}-8CYG!t6FV)Qn>9u^>n5AH;0KNP+Bru4EJwtYSbZ#ZU27B0_62(2u{k`% z>uq)N;Kmgi!1(E@apFjfUMQe7hF!JJu*Y&ik3ZxZUo3a{f=$Q-tQO~LJU_y*4nI1{ z5p|3`mUpucI&3@=byup#4tfCH>|b9%vl=6w)a|eUdee>O>>I4wXvvdIPO7C&^c&Y8j*GF-X=%~_`*gSo{UTC>IIz+or$87(## zt?h&3*<-xeloePUGz@g210T>&9I&ZD;O5A!ZE{IW&~N_HW1F2N$XhJHR^svs)iN^i zg|%KmO7IQgxrVP6P=CY+9&ALOYXf-rvDfw&b!%}a4*1{;X!x>OfIo3rZVlrLv}PA} z{+sLqhkVvM1@-nG_7D&DoW(V6Gd4j-Z?wPd{*6}T*8O^xE;)U1khpEn80)( z3x9k8jkq=l+_-`_Kap>7K%Uhia*>12!~;AzY>Vdj0S)W6*PAt77~!CG<8->_taC3w zY>`Lpc>-v`6I*m*8$PxRh%2#R{g43vOcrt&!^7D08E#NGnjieG@!9=kewf>NjSrl^-19IdSIEOI z=&=7D0S%jI7AO3qp(7>WoL?#?=*YD%pzRbO3%`lwfFLb^<~l)>0Dg3_4jnX$1mq6+ z4T5?yY%kHfa+%*GU=N`K`S2r)_+_Ipcv{?-+2Td4I8QtQ=gv04?SfYdXeI~!J_t37 z5Bl*Dd$57V^~lEYxYmcW``M?|g4r+|J$`Y9qy@f!hFGC4R~4O!gX*b@6D0XAA(=%M-lai6+zt(Qk)JaCK{6T9EVJ}pR&FQ8eT z|8MM5>~(A3tqrRetBVuar^o`}skaAhpW+MWZ9SU*j{6k5IeX3%v5tiX+b@HYHj&(YR%4QWD)cDbpgAvW47x7ww)ExSe~)j za_DPJvoo>YwO~x^K16Ex-VlsJ-_0&R!XXEnS_Pb~R@?Q?QtURHtS+$&`;bd-cw`wK z9{i=RS6_|7BOAN1hk7FicHe?*8vN+99My|qR_n9j>*dtF4$K!Xy5c$GT9}L0eDyTT zGjYQnWV?L6=J-T?As4%l?F(owKWB?;o4bZ={BdOuYEFX(nXbRS<}}MY-!BnIVvG!{ z7v{uxhX7h^T`3^;$RyVGeFyg7132<`mjHV6$!f+Ij%IVS+jOS1)+RU}pV^MAodU}d zHjfI(hso41sNH7uiv`$4Td04dh@KchPaN^zXt>W95sl3?P5dh2q4rM~AhRCddi}dc z#N#>vvYQ0ZjtStk+9h7#h=Yr>?>(uF27$|Ou_I^5?iCO>zB@3S*+!2(tCzT~?CZaf zt?0lGVu2lu;U&-JD`!7Adg6p$;=NjWnO`Enk2V23_=Y^|ttPvKIv68^F?O09V(RKA zW?6yx=*l!X_~6Q^CqpDbjdZ9-CJmcg1=xWN^>hdw)Qsz2I>J#)alFkrlPnGz26X5k ze&8DfabJkRO#YCXFyRq_l$?{o{0a+ z@Yug)RgdSMS@iJ#5IR{suRjKltB0J}nM{tZ){AMFL9OE_^>#?IY!1zs=A20`->V}& z>WXvJ)~J3^W4F3=6_plIDZ^~dJ?zl4a5$-_>QhwfKK z^3Y{IpywAlr^nP=9^A1jFYZh0V^dR>|F27iYuo2FFG!|~dtZ#^wVIoJVu)P}1jyvv zNk{AGWo=&6bH+2LE?pk>YR@l2nc&fFe8?mQ@7BL72#);?j=1g>&b4z)^AoKxi?75a z%8Ca)^0_YB8ZmyI*63MVC_p#!b&)P|MhwiiHjRy+`-RU$vg35r46>m4iT)qq!HYfk44(HnXyCEQ zjYWJiud5hfeC3eqGeBR}VjOf2e7p@yaD?Z}KM8TB58OM1v)ucd z!*j6!9_)EVv`&4qc7D`*QQxf|T6`agG&z{sqm=7kG&GMVGnBF|e4}G+;jSU!p##7{2~Fg`1sn0*7R)^4w~l(pdt2$L}PYgxA8u#n;pY1 zckmBH_{GAJTi`+G`UxH#eFD>QZ^UD9JJVUaOl#0z9pRAoEJyb?%~|Ju+T=Z|e+(Ae ztX>8p8t&boAy=1*20lK|fkSR<#OKN*P7N`6wlB=yb3_A=<+n4MBNzOVs9zfOe$-Rr ztZxxOi@iH^y|TFO)Z7=)xMnlwdGksci{00eAhjz6oLln*Hwln4F3@dFP_u@EhBbGN zFYcV0b?5l#&Z+xD0%UW>oGN&};99{gf?Wb)iC_2uFEM1yb2VnnscqUu0rKFP5MZD2 z4r|PwrVR<$2dx5Vu*24g#RdTldFY}Zu$>0Za>knRvF6H!#+8drtb;#az;!4sKn8f? zZTjfp#dhf9I&6)2*&6a)KIFM;=rBHFZEMs*qX55=!JHm|?oc#7Q$4W;f4hJj@%L3( z_3*HEmcXuE4H~x!@Q<2$i2z>Ce;P3$ADaZ!lFhLb89f5l+XS{2r^VkmE%CCw)D-dJ zpUca9Ha+!d>**mk#NTp6kKXkHVoxKcy@E9YVtFDxzSgthKf_+r&G$&;jFK56?o1*7mxkmeF3dYz!^ZpuLZ#< z^b6mRQxsr3xhJmJdXE5KjhD3nL5F~K-i{GtBaXxyKP*0s(anCPh66cb zupH@@WJ>5jAF>w$ODI+^yU}*tPKmWg|j2R4v(#4JN{YSF-Eu9 zPHf>vZdyRR$pQLYJNY;Mv%*2!Dlk6wZJL3P&@3>X~>V_f7#hl4*flqtP^|8SG_^dV-!g=MX&P3VVXQs<-_{jNC^aV6O_#N7n(zsjDBY+oxesMHr{R>Wwc4&@W#E*I+_FDxsbP)#tedYsmY6ai1 znfQ^PQw6q{i8=cp{dV4>2f7;s*uvmM+{2ak-q1lUd8nNIvdXOn=29cK!lftE40+r0`nY_OcN zjve4{7jS>`!6*;LBUDgZ$jJ)OO}*d;X9T|C2WJp@L*9wf5p#S)HvASF<`(ZRjj?aG zc$0J1v8h#H@pk38u|{5lfJThn`#185416?xd?aSr6YS?`4LTa~kl!un5nv0=y;mnj z;E_8d@C7u>qaVy_vY=(3PYHYhZ8qBfD!tfbb-?#F*t|$UY{@^ljDMfgD;#wC_&M$S z6|OnNn04BFG-uzETX4kpe&L8oUSM^iVKwK_8|^Kk9n*YXw61QNtmkT-HO>Iz*&>{4 z!#88!8UI6Uet&F!r{?Iyj#dF<^3K?m>x+&WMYmnQuz|SEjn?4f`olVQvd*61|3?Ea zadG*f14ln!06n$5MgI>Q=fIB#YfCh@JiE0g zaaCIxe^2qWGXnqN!3P?90KYayy}MW1gj*0GBdbgsUOX3@tr7JXU{ z>|L(`d|L#ZEBN8Y7@szX#_~z6;lG{Z#FW}0M$`cOZ;j=FyduY!9QetR#ef_U%X+%8 z5#OmN;^F4+g__gQ4IOLPK&%Iauxq&KX%`+n$f8lZ(4(K2xIQEA1p@p$OTgUpkuQ9? zSV(lneIa+OZ#>32^6<-ScI(uwOX`SbwLt9P!*1#XUxy@&{JD1ED?T*|XmOrRv+xj~ zIRVG?YYFE94Ld9c=-w)G43I@bH?)`3q3skNT8ll$0zlmR1;p`E@mbB_mz@*P zp_g-o)+#{H7SU4^u1#&4Lyw$Zfk+Y$%~GS69YY`d06rt9LGY@Woa5CqHeT-Nu=*qx z#LQwrT!0|~@h6VY6A&A4oE6kCHrRQyNn_-1m3+gwaqzT;%$xw3n+4P}KH2>$XZ0?@ zsK66Ihm3Xs=Wtpe@d4kVXl!Qz_}c~73iOrewC}9Yix22BdCZZAFVqz^J0vjMS!W*u z)Vn7@4nC8E4gvMb+2O{Hb@EMouu-PWxGzU1enMyVtkbwvz!@zJbyY|8J9K{ja zh6HXL+cig?)#gr(X>N=z(Y!-|{BA*yfE?xo*kQ3;qcQPEKS13en`ZWt2O4{u_}HA9 zcIPk9oc)7<8`XVMKyIK%_fU-f49&6QazTRtpRW|*JoS9men>!^sCnw@syb`fijU-x z9HNIYIL4MA>>!rd!rI$n_tdY6?uX6R9hzf@&3_u*58M39vH4$W?#ANUXq`PoZQ9vJ zk1h1%pB@{DyXBKPK68z`T2A24Tm^_2T%-B<>harh*r#z?Kx2(K7|pXa<_zV0Xcw?X zeOpbSld}Q8nj)Zfkbk8B`|yj}v^n-~a^}Qo$eH6aH4S|+2DfOwM=+aQo%JJ3OVnPVq&;>sL<%x1>m<~lg&!4VImLnb(MfSb*J@X(G4?D~uj8n$nb z*-m~|3CICwljV-Mw+gVqVjS$DyJ~W=1)dE88vC7`;Ws(~;(4qdebf@Q?+K8J&Zh~e z4eTQ}?6)NXYVBIlvu?KbX$&2@pDsWjF(7Bh(@zb00`#JXdO?N@&=3!3_?q!Ij6@^_$ou8=sJMy=1XJpt(;#Lk|s~$m4VC(6m9Ih7ZP1Y>{p8;Vf+s zY!cMli>_UsXyC=B8|vs=Bs{XZ1w8_h1Td!FYL7gC$L1Xxum@egIyFZ}mmnoDS&bS4 z)E;prx8xsv8wIvc@zrdmZosqep<%zVj_#e(ZFIBOuJ^8F5 zAGy0EmpS12Y$!Ht5xLP7|8<{mq(lc?7c@oV@`f<5+CO=@nJr!Ir45+ zZ}n!i)FwQ9oF~L0UYo=L{Ec;L9lp2^#M$DJkv`_G?d_VwM_w$yA`9#s(EvR3(7Ah= zTEPxva~9xFR`le>mG5Z|9kDi^A&reEcY-{d9G?6M@=%|qXZLY$36%BQlDGc+j}Lz;($zexQ4^mAb3LG_ahtd1vF}%8sMI7pZK{>rbSHc@7LV! zgW~&1%TM`p3;NN?wa^80)Vtp$S9T6?#$PAkEW*YEvaw#RF4P)&?A~Id#;z{L?)@!t zxh@hf7u@^X4=Weg7{9+gIExMV=*nX3`q-{Hda)m0ZkHUpH@#1D8nsWuescW0Iy7w% zsA0eH|E}(B@2I1X8dix^uLq491Dge0qlmpHfCjtq8{4q|`I2WbfTvZ!{UN#96pg7{ z=#6epghvkYkaMTxz-KYFczMEM1981XfR5Sj;r?Wnd>)eQxLkaumfUNgra@iegII#= zo%xRsS%G^dk41Crze@~Of7qB45Q9SknKk2j2`y(MvBfrc@E@D(%*Ri|q2mQH9oUF{ z=wMv$8pyx1iQRS$9M#y)67tb5SRx=E#Mt7|pfR@L19)u2hP$PRy#}wFBkYIgdI6^z z=NdY}4GD-J{4b1rXw#UrjS>DH;cefW+)k~r=Zp@!uM;c~(2xrca$n@gW$)cvM_zpI zy;wByy1*{@Uos0newtp+Fye-dG}rg}A!=IP;|FoTXWI+lkb@7u7y01Ewq1DSQx~+^ zcz=HuUUJ8Nqq+7`TQqzj$H>Komr4%y#BIQDWYLWFWp!xD8MIbM)B*8)xoGhnx%kv4 zARnxQ?-ht7@yIND_!Y^ExqI)TN-@ z_Ahb57jVS5OMrg!9X)`{uW7)~xo-OHy&i0V9=Tft$btr4%xUm3MpuI%t_%8R!3_fT z3$|H4w?^}{`W*u94cMdP9s8{g4r)v+sJX0wJ%SIufCeABX*&hTz;5(GN6dTy&1Cw) zEX=iQ4?3tBYTWf@RC7CLu$$H@Ku50tef%57W9r8RAn=>K#h<4^>z>=t;1h9R4ZdTY zq4DQw#AJhjhW>hED~^!F%5IdURRtTAev-%(3g$nxNOUi&(kW zN@58Q@qp(wnn2Gz8@k#A(6FbVVNC9zy?++@tM#X}&lJ}D4tGArLNpm~@x%NCHpf<>xU6tH8x|ML2T9{eD4B4Pr=bbuQs{p@PJ4-NE5Z8;%rk67tom@BR z;h|q3KrWx#X`TSRc70{+#(%Ts=mw8`c*zxYV0i2T&sn7Z0zC4F{SHBw0DIY2#&2>P z9GuBaML1U;^~kg4FAG))_6g8y`8lXDxgkD4UI3jZgU~@-$PfC<0`i9aB>_0-&};ES zF82Jf@MiM@%^BMn=V^>x>0lUa0`JtZC`zOcIi~Z>B z6`+^erN!gHo`DvbZ#{<0HmxHMJCR3yAo5u9-gW}=@Ri0r+-`xz@^Xzk1muv${vw9d z3VLaATvj;ZN5h}Di_o3FBQ}4h=F}`PAWq2ruFmf<_3;0x5bRG|`?}VUN8PgiF0Bu$ zr}@F}5dUYwv%jFFW}yA^I<)xufPhAPMH1LTzR^i+UZraV_RJHs3h>d55jYxkLA}^{ z(xmZv0rf{?zcF4dc()X}a;_8(IcuWz_h|j)8fV7GOWEPv-ie8WiM@MrnMyvIWXk2t z!Qs(-WjK?|l@qn;?(tHlQkzGk$?1elT|&(x!o9`G%qoUDvxiU|fGYP6hJ49WpE8ixy| zy_G$CE5rLT<9qW7cQRZl4Nq3eh2rQ8^vK@byYuD5?oxRoWAO-_9xm-Ro?hC#3(*9aq_mZxw5CUKX0NZ3&n_5qp@h1Et%aK8M2ZwN{tMesqtrOT$vgz!vPbU zFPO*q+ag@CIvUSMsByD%)G(ul3FB;4QH}b@!AgEIksZ%WP8N0_jKqv)l`2)d`fO=$ zQN=OISUZD`!d5p?D3;2>AahGN*u8gre0aiU!C-iDypYX96==>@3Z-IVEThQmEh=-W z(9A@lP^^`iGalYuE=^d?Ok~QFW0~<`ZP(23Wa0L_xGJGg6?s%qQB6k0M?nde4-BiU zqLDUsG*U4|BNbCLQZX5>WOSLLjpSq~?m%@kIab(R86MB?HccU-To@gzgOSgZh0$WZ zDscC3%|>mh+N8QWLWNoj5*F#VB!-Kjx6#tHO}6p^^IW6IbB!X;HHtjfDDoU!=($Fb z=Ng6nY7lv@(R9zNh^pt)G1ENPlFW>p)uiTmxKedBTyv)(-|_*xt#VeUS}kTOg?;&H zvg0TxdJ<8KUZ^}Op-}!vp)y%JsX|cIHB=}`*{Y!|7d1?j zj~YUPqMT$i6XV0BJ^A8rEx_Di#q6J;Svbx|E^W&4lYP4p8AR zx|~W}c^ZP!4IK(EzSHZQ%9ChgI6sJa?Ws*B+vThkrRtEz*kqs3wz zDA7gF+(xXeh2!c{C~-2Y3*UI5nAhFLf#G~{lwmQyUngdDI+0sp31&!q6WoH0j+aKF z^FC3|b8X^Ml_k8oUkPsELXvw=Ik?kki_#R-jdM(iu;#;8)xWb?WQ*jo&* zK3v%f+2KG$BAV#dAaCPxKFD@ym*2sbqAwqn>2jxVDtQCtc|8KVm*mk2qoION84C#9MX>t8`Dj#kDJ z+2D4~Viv7&X^w_mo}*!S8y8Kgw}8>y_Fgot-WWRbY5eYOVnj3TZgFJ1P%*1^7jPuJ zLsSg*=vJ|k85z$fbfR*jI;@)xS$S}BIDeoJ4%pZMCfJ6-NKzD?1KP8b!MvQGDD6|8 z#HM6tCcw^1*~|igX9GTQ|b_igI6_j%2d8x^pE}Vs#o-DO6y4rLvqK zm1nw}#FJcfm%Trqxpg?qa3UC!&0s)=Z6LGu91LgKvApVYw+^3i1tpZ2$QLK~mh(!0 zY#GjG_GGe!%E3hLU{QNfhXzOJcwwZ92oF9NqZ?>BF+6#2Vx%-)rPD=?R8ADQ##XUG zn4;|`8Iy^7Ui0>k>D$Ts^~vu;`jr1UeHy*DDKY0GiNi~-)M2axeL{&WA3WT>jRGi_ zOXb6zn=^%R*?hQvOHrRU3OQ1yC>1M*dp8wx!9`fraJYY{u&*$wn@F7o!?)+lrNiCN zDd`qhcd5C0O=aUAxk|is@aIu8j&{Uv{kQuhf(SbeIbfs(rT;)c zw=6={FkWwjB1$$UOg#}^aq_9>zKc~VxArdY>tEG7lCNaEWxlWcpFUg&-c_KdMSU{X zPs5W^*6)hw4{09Cx+RbmuHS;Vpq)Nk9ZPQAvE)z3BZCJ1E=SIx0Bib+iDXEm0Ys+{ zhXbjJ4Pr|!SB=>Bnme{C;lYlM$`zMq)-xHssl zEG7>slLx%uyy&}1S5EkExPgLRZc}<)GB{HFfo=IpUwFyjv+8huymC}>RAHU0=;mU! z-XFLkvnR&d2@0NBdS6AM)3$HZ#GcAQ|7dsUfC@Kp{gw+Z4!#uWeOa`U7zJ{#l zy5HKVpR|5DmIs&5-D|v&OwJ4Mk3H4Fr2dPYCEXd1!zG_7F3}NEJ7an>MNf$QXudq_ z!qVyoo6x?_j2B>L!+Wis*HtR!y^<_z>)O!0XvvbX{P>=Z;P>i|$u-{I;;qHf{-Rgf z!^eK_=8nnEzLw@?EbZ4#+Nft|e6Y0ErStUlj4rg3o_uU+ZiB^<;uUp`p7i9EN$6|o zf(Gitp#_H{dlV(Hw}i;%PR|SM^E_{;Fu7+ubI_}d6(&7S8F>;ZnQV!e1Nw;JnDkwq zbnCyC*5|k0(fYjJXbNW0x}w6gzH_iV+IMj#*F}G+0_C@N^bZ`+1#MLKLVeY`@M}jx zZL9J%sM^DW&i+j-z9zU~=~HG`UJ!A)$mIh)HHy{)`s(y+iPZTc*Yu{&{@msZQl~um zi-%Kl{^GK~PqiQTlLu4he|r3qRLAzwM^a~=ci%&)#cz6If2x1wCtj86T-EzT>g=Zb znp3HJFJF*av-yELQm5bd&zGhWU#w(Pr|a-uc?A}!88%ENp4c~nKAEoAPIPlHXIj24A-qh;PU-Ze;`G5F=SErtldvI%N<%1iZ zpK5#0wkuO}fBoYdQp?VpcW0{oJI}c@)%eZV{d;QpPt%`Go&B+|ccq?v^#i%o!o;IJ zsWWbP)kUe))`$N(b8{Q6y~^!Fa>OP%q`zJb&;55D4SsjkK&TT=t2bstSV z;|G_VlREF`>mEtm!ag1fN3;MPbt zi25c`s5Kr#PxpKtDda{}HzZ!E?D0*PuKdmYRn8M-;@)7BuVU@!UwNQoa#dA8cC55V zS7&M9_U3}=_(>fgg#)c?f}f?WeXUD%&1>JK>t1?Sx^gzek?4|H}e z+IVnuf1%iMMJ9XYw)Sg_g##Ve7mCXVj`k9xAZ%QoKfA?0+L_huDreqRSNZ;;;L}a{ za=3>uceBF`M@)B^?YS+^~7NVbwnOkm23j)9Ga@9=AZAN_Bf8nLH(#oRdt> zO(vU?$>wCTC7GO;OrDxdo|a5LEt!0JGWm>T@|nrx>B;07$>f>I!Y0(pyIkWzps^=2(^vr@EJ*&AaB|a{E zJZa$R1@d?T5=y5}Mn4T2hgw-n2EZy~@XdFME#Pbqq=hq{5?X7C2G7>BjWhMUg{NcI z=17X$=IgoDf-0g(Pt?NaN<8)CZI1Kx?{7RkxG8K6sGgQsmr@u`k>f3TtkNU*mgqHt zHF~7HDzRL~$;2s>*E-cO)ivd7zC^z_OTS4SBAGr1a#1oQ+aUB$z#Kf(y+{4T~;!gYSP)mDPhEw#B; zFP=6lX|_i&RK@=KH;Kd*!E7DECIlS3PfXpWr%B(O;^`dE#*~+2G2*(IY*Dl7wL77EKx=J!Y}FmnuhwI!Wh$u#iJe!a zUtFaRr9NHsO##ibl}3|#YL)6-Nj^tE-O|~h@iR3(T^S9zPZQ=eVT>xYslUn{QiZ<< z^eFG5#9BR^3#r22^TgXA+2^Vd&sPyGln+bwkI4jqczU8SnM$hawKp5tnVK~u&y@&_ zeY!9yZPrt@RiBpZNIXN^^mJ{~Gn2hC>7vAfh`v!tm zpE)`VOe(uSl-ek6V1aZtYQ0&2RUvniw6+M&4x}uIY?@!?4ynT5I#R@2vplrFS(dlx zxH%*FGzIundH3|>c}jWn;q7I8HcV^}4!Wq*7vrUJ@a@KSzF^oMeuc6<&sbmCZr8D= zrzzQz9$IYAmv$$%kB{j4say5oetWq((g$~uPGk;_AYI=hicCuM1ec#OMJ(w4vK!K+{dSvtiEvxK56J`wK&myS0eG9sc%o6lK9QkKkE_t zFQyt3Pfq=K>PJ&gOg%pJ*whcFexUz(!1t!UJN4+)ucziFUXuFB6c4knNOUC6Nc``q zoc8Tcr+zl|^Qmj~S?evSIr=9DONpN(znl8y)IEt`O?9MB*IBbBH9zsM$rXu_#D`N^ zz38(p`HY6HhP?hcnccD={LIEn@r~NKQ&S779}}Zbb5m!;FkA>*Vz`jDNvB*=SBg`d zRW6uQvOVSCOfr4*U0f8=AHJAh`=^xybagG9VP8lW$}k>Qxm?Y4w1hI-0!&)JR|KOA z9g0wf&Zeeo5HP)Q&~oMGr!yK&r*LOn;lnF3)J?%P_-Q%-&r*uoffH2;Is2oGRYabkxq#A$&4?M%%1Q$+PSHbjpVg$p#vyt$RA$<3F9cA(;77 zi;kESi|WR+w*I>rxrVNMN*a+s6;KaP z#im}}&%}S+dv)Gts{Qc(nA_Td3HRb*>kIx0bD2%mw>jLsI$x~y>1KR-J2~s0nzuC_ zGx^U6&Q0D^<1J8Y9U3$Sx0u{!xb`X~oudyaGk?N& zQsIR5oG5~P@~NjaKv$zov@PO2IDGgGTh1ZJ^JP?{X~_{}n~ZM{hQUxX|93R2vzdzBaDi9M(qDb5+Cl20B+on%4%s zo3FLH<%s|AKX0u4xT{lB?oEP?&DyXxEIpX%{L^V?&d#288!~f!CdT42b7gjn#bb7g z|94lsp!vPqc{QqUQ}ERKu$~?3d#TZUk(VACesGzdS08O`NH(5xbuc<5+3@zHtOZ08k(Z=Rv!^<5U)t_a@A8Me1&e7{{U3RS%3-WGe7d6CE0UV7-RXO+Ccm!HV% znWqMN*6qoZj!eX|*q*6PuAkJqvFB89o# z>*;Q(W0u}#>QfrJd)j1o@D*Z9Yl}0n2WY`lGrwK#dd*8kDVz00@nV?tj-np>@swQi z;7vJ?mk?PBUeIr8UZkPk9|&ml^=yFk_D<%5Hv&ApDw9)YCR@4`NIh1|dhKi1wzRZ+ z-W@@OELrb$wWPaSn)_$QLFVIn_>xcf>KS^wmMrU*`)SW>Ucsa7Ovve7L~=8Vu{S&% ze2W^q%-O*!dD$9ON3Ny03r~+l6a)Z)?YtA(yxQ~hHzV0GE3=Nt@Xbg{OmAFjk4%O! zvzpsqsEo-PS$G+a7CpH+-M{eFl3`xPh*s7f)1qQa%W@*5GsVP(^iTdP8~VjJc)$x2=oA5jHW)jU8&4O3C&OhNhX zie6Ck(jw!5fv4x>6}>&8SB#74Zm*@Kr8C-l?JX+&l`>_9=!@7+9r`cVg1HxYkxuuJ z(=(FbAY)I47P+g=q1CK+PG%AW?BP?6;1tYp3M$6o&KlOADI5sihc8caclxPWoh@0$ z;pkNqoZ8`NQx?-*J;ABiZP9AsxC~Id5tC8;TH5c>^QMkFI`#Gs$@W(8D;}DbW))pM zf2t1G4M#Ota#9hkC%_3vOWPeCx#nMxrn-fplQ8(xqTq~!O4k!@yqQ6+8l@{%J)QNA z)T;3CV6Dqny^0ZTl&`HzR`vS$RJBT2vP>naXV`Cus#GDEQ45^y1v@G0mfiY#;ox}H zd(3(nL@!h6*NEOjCNQ%IQ#t5jkin^A4w+P`*6_wqkfxS)*DPF z9`FZ``W?X?(%>x*3%}^%pyajm`~Kj?NBwq^Ie18HEN;}3=TdPnnY*Qav`WjEoN^wgz@=;cprT6W7Dv zp~=b%1`{KJ8N5}SFH4aZ8ltIg?KNKs<04IUU>JHGK#HZ7PAm#GPUu+AOEH@v5!X?u~5k+E&R0 zZ?;R}djj@t!8^8tiA&*Lv@LjbSPZ`k>~GV1+JlM91HB!=t%ms0;=5}4Ul0slqCg$J zdiq~24EjO5u9@+N3WFOZVVnIS!{Eh;-(LIcgu%^PzP9!!4}*gUzs~*ZhQT3tuAlKY z4uhM-`rO!`GYnn|@eQ#*Y8c!i(jBqCY#6*ulsk{{=M96Gla`@PmxLRlfp^rkA(DDC zD*2`(N5Zn||AWu}{E_UHzr6Ik|8d*Vd%yLsuQ_sric*2~-~agAdb=NadFy+Z{>{xd zZTh<>j~oeVtN)tMuXy3A7yn}AtNvr&r{DP41HX6V2!++Z`71BE_?Ziq-2aU3v#$Q= z53c#3Gz5FA|K;z$^U&SfKKkkV?>~FjCz}r5D-B^C^ndW4GyY=9-zDz9+gJc!-BUY-gV?iwHo?we)6#|?cVmGBiF82yzQ zi&cpIKYnq~+duG658iuV=llQcZ_j8vQzit3(4V{ItIzsw)2H6L?~hjBaLL)Xzf-QT zG5Sl}N8j7{=IihMgWGbYr+sD4=OrqvvHtgeKld+>ZvMzWY`FT2xj%aEo0qT>)LZ{U zUwzB1UmE|$g}+&LlXqn8gG;p%o*VtAe`?-me$Y31`MGBvIsM%CeC4boM{2vQf7SeF zefR2XF8}^tKXBXl%{`w>iY+`P`m;}-`q6LiyZ!JFC)=*S?>)D@T`S>P(|`73?Js=d zy%R^?JNI+XX3`2d@4x9;zsaRP zc=xwYz3U?%e9@63wnzIoHcpS!Zse%>7)_{RJ8 zeBrd`KKkyf6=^%H`lsG>#anm3>9)Uo_G{l;`c~s<9~D!uN&AOB^y!!0HnjAeT`M}% zfB3&1X_BJoJnX;a(Br#a{l06z__t@={pp8xXWpo#=%njEwXghdcRl=AQ{x-XKJ?I` zZ{MfFxpL%|{?DAf{Xdp`>U%f8`>#LsQ1eTEalO#m%KiJ^eE3B_{z>BA{qt{l`3)ah zd3k8@@`3(WU-;oaZFua#mwoL6AOGfe|6}B4=;eIz{BQki)zklYPX59NuHCf$api?` zzJKlN+dlrCC;#&6KYGz^kA8Rc3e~rBO!cR}@WtoQ;pSB&;O32oKZsCiE zAARfD|GwhXPyX_Om%Vu0-+1NFrbO~*R}F2wihq(MF|>8-Hu|fs*>Z*c1&y1B2DcCD o@2cLl?S?BZ*4r%4+<47KtvB#bvd!J7*O`{BUcLIc{r#){4? env + | id :: rem -> add_vars rem (pos + 1) (add_var id pos env) + +(**** Examination of the continuation ****) + +(* Return a label to the beginning of the given continuation. + If the sequence starts with a branch, use the target of that branch + as the label, thus avoiding a jump to a jump. *) + +let label_code = function + Kbranch lbl :: _ as cont -> (lbl, cont) + | Klabel lbl :: _ as cont -> (lbl, cont) + | cont -> let lbl = new_label() in (lbl, Klabel lbl :: cont) + +(* Return a branch to the continuation. That is, an instruction that, + when executed, branches to the continuation or performs what the + continuation performs. We avoid generating branches to branches and + branches to returns. *) + +let rec make_branch_2 lbl n cont = + function + Kreturn m :: _ -> (Kreturn (n + m), cont) + | Klabel _ :: c -> make_branch_2 lbl n cont c + | Kpop m :: c -> make_branch_2 lbl (n + m) cont c + | _ -> + match lbl with + Some lbl -> (Kbranch lbl, cont) + | None -> let lbl = new_label() in (Kbranch lbl, Klabel lbl :: cont) + +let make_branch cont = + match cont with + (Kbranch _ as branch) :: _ -> (branch, cont) + | (Kreturn _ as return) :: _ -> (return, cont) + | Kraise :: _ -> (Kraise, cont) + | Klabel lbl :: _ -> make_branch_2 (Some lbl) 0 cont cont + | _ -> make_branch_2 (None) 0 cont cont + +(* Avoid a branch to a label that follows immediately *) + +let branch_to label cont = match cont with +| Klabel label0::_ when label = label0 -> cont +| _ -> Kbranch label::cont + +(* Discard all instructions up to the next label. + This function is to be applied to the continuation before adding a + non-terminating instruction (branch, raise, return) in front of it. *) + +let rec discard_dead_code = function + [] -> [] + | (Klabel _ | Krestart | Ksetglobal _) :: _ as cont -> cont + | _ :: cont -> discard_dead_code cont + +(* Check if we're in tailcall position *) + +let rec is_tailcall = function + Kreturn _ :: _ -> true + | Klabel _ :: c -> is_tailcall c + | Kpop _ :: c -> is_tailcall c + | _ -> false + +(* Add a Kpop N instruction in front of a continuation *) + +let rec add_pop n cont = + if n = 0 then cont else + match cont with + Kpop m :: cont -> add_pop (n + m) cont + | Kreturn m :: cont -> Kreturn(n + m) :: cont + | Kraise :: _ -> cont + | _ -> Kpop n :: cont + +(* Add the constant "unit" in front of a continuation *) + +let add_const_unit = function + (Kacc _ | Kconst _ | Kgetglobal _ | Kpush_retaddr _) :: _ as cont -> cont + | cont -> Kconst const_unit :: cont + +let rec push_dummies n k = match n with +| 0 -> k +| _ -> Kconst const_unit::Kpush::push_dummies (n-1) k + + +(**** Auxiliary for compiling "let rec" ****) + +type rhs_kind = + | RHS_block of int + | RHS_nonrec +;; +let rec size_of_lambda = function + | Lfunction(kind, params, body) as funct -> + RHS_block (1 + IdentSet.cardinal(free_variables funct)) + | Llet(str, id, arg, body) -> size_of_lambda body + | Lletrec(bindings, body) -> size_of_lambda body + | Lprim(Pmakeblock(tag, mut), args) -> RHS_block (List.length args) + | Lprim(Pmakearray kind, args) -> RHS_block (List.length args) + | Levent (lam, _) -> size_of_lambda lam + | Lsequence (lam, lam') -> size_of_lambda lam' + | _ -> RHS_nonrec + +(**** Merging consecutive events ****) + +let copy_event ev kind info repr = + { ev_pos = 0; (* patched in emitcode *) + ev_module = ev.ev_module; + ev_char = ev.ev_char; + ev_kind = kind; + ev_info = info; + ev_typenv = ev.ev_typenv; + ev_compenv = ev.ev_compenv; + ev_stacksize = ev.ev_stacksize; + ev_repr = repr } + +let merge_infos ev ev' = + match ev.ev_info, ev'.ev_info with + Event_other, info -> info + | info, Event_other -> info + | _ -> fatal_error "Bytegen.merge_infos" + +let merge_repr ev ev' = + match ev.ev_repr, ev'.ev_repr with + Event_none, x -> x + | x, Event_none -> x + | Event_parent r, Event_child r' when r == r' && !r = 1 -> Event_none + | Event_child r, Event_parent r' when r == r' -> Event_parent r + | _, _ -> fatal_error "Bytegen.merge_repr" + +let merge_events ev ev' = + let (maj, min) = + match ev.ev_kind, ev'.ev_kind with + (* Discard pseudo-events *) + Event_pseudo, _ -> ev', ev + | _, Event_pseudo -> ev, ev' + (* Keep following event, supposedly more informative *) + | Event_before, (Event_after _ | Event_before) -> ev', ev + (* Discard following events, supposedly less informative *) + | Event_after _, (Event_after _ | Event_before) -> ev, ev' + in + copy_event maj maj.ev_kind (merge_infos maj min) (merge_repr maj min) + +let weaken_event ev cont = + match ev.ev_kind with + Event_after _ -> + begin match cont with + Kpush :: Kevent ({ev_repr = Event_none} as ev') :: c -> + begin match ev.ev_info with + Event_return _ -> + (* Weaken event *) + let repr = ref 1 in + let ev = + copy_event ev Event_pseudo ev.ev_info (Event_parent repr) + and ev' = + copy_event ev' ev'.ev_kind ev'.ev_info (Event_child repr) + in + Kevent ev :: Kpush :: Kevent ev' :: c + | _ -> + (* Only keep following event, equivalent *) + cont + end + | _ -> + Kevent ev :: cont + end + | _ -> + Kevent ev :: cont + +let add_event ev = + function + Kevent ev' :: cont -> weaken_event (merge_events ev ev') cont + | cont -> weaken_event ev cont + +(**** Compilation of a lambda expression ****) + +(* association staticraise numbers -> (lbl,size of stack *) + +let sz_static_raises = ref [] +let find_raise_label i = + try + List.assoc i !sz_static_raises + with + | Not_found -> + Misc.fatal_error + ("exit("^string_of_int i^") outside appropriated catch") + +(* Will the translation of l lead to a jump to label ? *) +let code_as_jump l sz = match l with +| Lstaticraise (i,[]) -> + let label,size = find_raise_label i in + if sz = size then + Some label + else + None +| _ -> None + +(* Function bodies that remain to be compiled *) + +type function_to_compile = + { params: Ident.t list; (* function parameters *) + body: lambda; (* the function body *) + label: label; (* the label of the function entry *) + free_vars: Ident.t list; (* free variables of the function *) + num_defs: int; (* number of mutually recursive definitions *) + rec_vars: Ident.t list; (* mutually recursive fn names *) + rec_pos: int } (* rank in recursive definition *) + +let functions_to_compile = (Stack.create () : function_to_compile Stack.t) + +(* Name of current compilation unit (for debugging events) *) + +let compunit_name = ref "" + +(* Maximal stack size reached during the current function body *) + +let max_stack_used = ref 0 + +(* Translate a primitive to a bytecode instruction (possibly a call to a C + function) *) + +let comp_bint_primitive bi suff args = + let pref = + match bi with Pnativeint -> "nativeint_" + | Pint32 -> "int32_" + | Pint64 -> "int64_" in + Kccall(pref ^ suff, List.length args) + +let comp_primitive p args = + match p with + Pgetglobal id -> Kgetglobal id + | Psetglobal id -> Ksetglobal id + | Pintcomp cmp -> Kintcomp cmp + | Pmakeblock(tag, mut) -> Kmakeblock(List.length args, tag) + | Pfield n -> Kgetfield n + | Psetfield(n, ptr) -> Ksetfield n + | Pfloatfield n -> Kgetfloatfield n + | Psetfloatfield n -> Ksetfloatfield n + | Pccall p -> Kccall(p.prim_name, p.prim_arity) + | Pnegint -> Knegint + | Paddint -> Kaddint + | Psubint -> Ksubint + | Pmulint -> Kmulint + | Pdivint -> Kdivint + | Pmodint -> Kmodint + | Pandint -> Kandint + | Porint -> Korint + | Pxorint -> Kxorint + | Plslint -> Klslint + | Plsrint -> Klsrint + | Pasrint -> Kasrint + | Poffsetint n -> Koffsetint n + | Poffsetref n -> Koffsetref n + | Pintoffloat -> Kccall("int_of_float", 1) + | Pfloatofint -> Kccall("float_of_int", 1) + | Pnegfloat -> Kccall("neg_float", 1) + | Pabsfloat -> Kccall("abs_float", 1) + | Paddfloat -> Kccall("add_float", 2) + | Psubfloat -> Kccall("sub_float", 2) + | Pmulfloat -> Kccall("mul_float", 2) + | Pdivfloat -> Kccall("div_float", 2) + | Pfloatcomp Ceq -> Kccall("eq_float", 2) + | Pfloatcomp Cneq -> Kccall("neq_float", 2) + | Pfloatcomp Clt -> Kccall("lt_float", 2) + | Pfloatcomp Cgt -> Kccall("gt_float", 2) + | Pfloatcomp Cle -> Kccall("le_float", 2) + | Pfloatcomp Cge -> Kccall("ge_float", 2) + | Pstringlength -> Kccall("ml_string_length", 1) + | Pstringrefs -> Kccall("string_get", 2) + | Pstringsets -> Kccall("string_set", 3) + | Pstringrefu -> Kgetstringchar + | Pstringsetu -> Ksetstringchar + | Parraylength kind -> Kvectlength + | Parrayrefs Pgenarray -> Kccall("array_get", 2) + | Parrayrefs Pfloatarray -> Kccall("array_get_float", 2) + | Parrayrefs _ -> Kccall("array_get_addr", 2) + | Parraysets Pgenarray -> Kccall("array_set", 3) + | Parraysets Pfloatarray -> Kccall("array_set_float", 3) + | Parraysets _ -> Kccall("array_set_addr", 3) + | Parrayrefu Pgenarray -> Kccall("array_unsafe_get", 2) + | Parrayrefu Pfloatarray -> Kccall("array_unsafe_get_float", 2) + | Parrayrefu _ -> Kgetvectitem + | Parraysetu Pgenarray -> Kccall("array_unsafe_set", 3) + | Parraysetu Pfloatarray -> Kccall("array_unsafe_set_float", 3) + | Parraysetu _ -> Ksetvectitem + | Pisint -> Kisint + | Pisout -> Kisout + | Pbittest -> Kccall("bitvect_test", 2) + | Pbintofint bi -> comp_bint_primitive bi "of_int" args + | Pintofbint bi -> comp_bint_primitive bi "to_int" args + | Pcvtbint(Pint32, Pnativeint) -> Kccall("nativeint_of_int32", 1) + | Pcvtbint(Pnativeint, Pint32) -> Kccall("nativeint_to_int32", 1) + | Pcvtbint(Pint32, Pint64) -> Kccall("int64_of_int32", 1) + | Pcvtbint(Pint64, Pint32) -> Kccall("int64_to_int32", 1) + | Pcvtbint(Pnativeint, Pint64) -> Kccall("int64_of_nativeint", 1) + | Pcvtbint(Pint64, Pnativeint) -> Kccall("int64_to_nativeint", 1) + | Pnegbint bi -> comp_bint_primitive bi "neg" args + | Paddbint bi -> comp_bint_primitive bi "add" args + | Psubbint bi -> comp_bint_primitive bi "sub" args + | Pmulbint bi -> comp_bint_primitive bi "mul" args + | Pdivbint bi -> comp_bint_primitive bi "div" args + | Pmodbint bi -> comp_bint_primitive bi "mod" args + | Pandbint bi -> comp_bint_primitive bi "and" args + | Porbint bi -> comp_bint_primitive bi "or" args + | Pxorbint bi -> comp_bint_primitive bi "xor" args + | Plslbint bi -> comp_bint_primitive bi "shift_left" args + | Plsrbint bi -> comp_bint_primitive bi "shift_right_unsigned" args + | Pasrbint bi -> comp_bint_primitive bi "shift_right" args + | Pbintcomp(bi, Ceq) -> Kccall("equal", 2) + | Pbintcomp(bi, Cneq) -> Kccall("notequal", 2) + | Pbintcomp(bi, Clt) -> Kccall("lessthan", 2) + | Pbintcomp(bi, Cgt) -> Kccall("greaterthan", 2) + | Pbintcomp(bi, Cle) -> Kccall("lessequal", 2) + | Pbintcomp(bi, Cge) -> Kccall("greaterequal", 2) + | Pbigarrayref(n, _, _) -> Kccall("bigarray_get_" ^ string_of_int n, n + 1) + | Pbigarrayset(n, _, _) -> Kccall("bigarray_set_" ^ string_of_int n, n + 2) + | _ -> fatal_error "Bytegen.comp_primitive" + +let is_immed n = immed_min <= n && n <= immed_max + +let explode_isout arg l h = + Lprim + (Psequor, + [Lprim (Pintcomp Clt,[arg ; Lconst (Const_base (Const_int 0))]) ; + Lprim (Pintcomp Cgt,[arg ; Lconst (Const_base (Const_int h))])]) + +(* Compile an expression. + The value of the expression is left in the accumulator. + env = compilation environment + exp = the lambda expression to compile + sz = current size of the stack frame + cont = list of instructions to execute afterwards + Result = list of instructions that evaluate exp, then perform cont. *) + +let rec comp_expr env exp sz cont = + if sz > !max_stack_used then max_stack_used := sz; + match exp with + Lvar id -> + begin try + let pos = Ident.find_same id env.ce_stack in + Kacc(sz - pos) :: cont + with Not_found -> + try + let pos = Ident.find_same id env.ce_heap in + Kenvacc(pos) :: cont + with Not_found -> + try + let ofs = Ident.find_same id env.ce_rec in + Koffsetclosure(ofs) :: cont + with Not_found -> + Format.eprintf "%a@." Ident.print id; + fatal_error ("Bytegen.comp_expr: var " ^ Ident.unique_name id) + end + | Lconst cst -> + Kconst cst :: cont + | Lapply(func, args) -> + let nargs = List.length args in + if is_tailcall cont then + comp_args env args sz + (Kpush :: comp_expr env func (sz + nargs) + (Kappterm(nargs, sz + nargs) :: discard_dead_code cont)) + else + if nargs < 4 then + comp_args env args sz + (Kpush :: comp_expr env func (sz + nargs) (Kapply nargs :: cont)) + else begin + let (lbl, cont1) = label_code cont in + Kpush_retaddr lbl :: + comp_args env args (sz + 3) + (Kpush :: comp_expr env func (sz + 3 + nargs) + (Kapply nargs :: cont1)) + end + | Lsend(met, obj, args) -> + let nargs = List.length args + 1 in + if is_tailcall cont then + comp_args env (met::obj::args) sz + (Kgetmethod :: Kappterm(nargs, sz + nargs) :: discard_dead_code cont) + else + if nargs < 4 then + comp_args env (met::obj::args) sz + (Kgetmethod :: Kapply nargs :: cont) + else begin + let (lbl, cont1) = label_code cont in + Kpush_retaddr lbl :: + comp_args env (met::obj::args) (sz + 3) + (Kgetmethod :: Kapply nargs :: cont1) + end + | Lfunction(kind, params, body) -> (* assume kind = Curried *) + let lbl = new_label() in + let fv = IdentSet.elements(free_variables exp) in + let to_compile = + { params = params; body = body; label = lbl; + free_vars = fv; num_defs = 1; rec_vars = []; rec_pos = 0 } in + Stack.push to_compile functions_to_compile; + comp_args env (List.map (fun n -> Lvar n) fv) sz + (Kclosure(lbl, List.length fv) :: cont) + | Llet(str, id, arg, body) -> + comp_expr env arg sz + (Kpush :: comp_expr (add_var id (sz+1) env) body (sz+1) + (add_pop 1 cont)) + | Lletrec(decl, body) -> + let ndecl = List.length decl in + if List.for_all (function (_, Lfunction(_,_,_)) -> true | _ -> false) + decl then begin + (* let rec of functions *) + let fv = + IdentSet.elements (free_variables (Lletrec(decl, lambda_unit))) in + let rec_idents = List.map (fun (id, lam) -> id) decl in + let rec comp_fun pos = function + [] -> [] + | (id, Lfunction(kind, params, body)) :: rem -> + let lbl = new_label() in + let to_compile = + { params = params; body = body; label = lbl; free_vars = fv; + num_defs = ndecl; rec_vars = rec_idents; rec_pos = pos} in + Stack.push to_compile functions_to_compile; + lbl :: comp_fun (pos + 1) rem + | _ -> assert false in + let lbls = comp_fun 0 decl in + comp_args env (List.map (fun n -> Lvar n) fv) sz + (Kclosurerec(lbls, List.length fv) :: + (comp_expr (add_vars rec_idents (sz+1) env) body (sz + ndecl) + (add_pop ndecl cont))) + end else begin + let decl_size = + List.map (fun (id, exp) -> (id, exp, size_of_lambda exp)) decl in + let rec comp_init new_env sz = function + | [] -> comp_nonrec new_env sz ndecl decl_size + | (id, exp, RHS_block blocksize) :: rem -> + Kconst(Const_base(Const_int blocksize)) :: + Kccall("alloc_dummy", 1) :: Kpush :: + comp_init (add_var id (sz+1) new_env) (sz+1) rem + | (id, exp, RHS_nonrec) :: rem -> + Kconst(Const_base(Const_int 0)) :: Kpush :: + comp_init (add_var id (sz+1) new_env) (sz+1) rem + and comp_nonrec new_env sz i = function + | [] -> comp_rec new_env sz ndecl decl_size + | (id, exp, RHS_block blocksize) :: rem -> + comp_nonrec new_env sz (i-1) rem + | (id, exp, RHS_nonrec) :: rem -> + comp_expr new_env exp sz + (Kassign (i-1) :: comp_nonrec new_env sz (i-1) rem) + and comp_rec new_env sz i = function + | [] -> comp_expr new_env body sz (add_pop ndecl cont) + | (id, exp, RHS_block blocksize) :: rem -> + comp_expr new_env exp sz + (Kpush :: Kacc i :: Kccall("update_dummy", 2) :: + comp_rec new_env sz (i-1) rem) + | (id, exp, RHS_nonrec) :: rem -> + comp_rec new_env sz (i-1) rem + in + comp_init env sz decl_size + end + | Lprim(Pidentity, [arg]) -> + comp_expr env arg sz cont + | Lprim(Pignore, [arg]) -> + comp_expr env arg sz (add_const_unit cont) + | Lprim(Pnot, [arg]) -> + let newcont = + match cont with + Kbranchif lbl :: cont1 -> Kbranchifnot lbl :: cont1 + | Kbranchifnot lbl :: cont1 -> Kbranchif lbl :: cont1 + | _ -> Kboolnot :: cont in + comp_expr env arg sz newcont + | Lprim(Psequand, [exp1; exp2]) -> + begin match cont with + Kbranchifnot lbl :: _ -> + comp_expr env exp1 sz (Kbranchifnot lbl :: + comp_expr env exp2 sz cont) + | Kbranchif lbl :: cont1 -> + let (lbl2, cont2) = label_code cont1 in + comp_expr env exp1 sz (Kbranchifnot lbl2 :: + comp_expr env exp2 sz (Kbranchif lbl :: cont2)) + | _ -> + let (lbl, cont1) = label_code cont in + comp_expr env exp1 sz (Kstrictbranchifnot lbl :: + comp_expr env exp2 sz cont1) + end + | Lprim(Psequor, [exp1; exp2]) -> + begin match cont with + Kbranchif lbl :: _ -> + comp_expr env exp1 sz (Kbranchif lbl :: + comp_expr env exp2 sz cont) + | Kbranchifnot lbl :: cont1 -> + let (lbl2, cont2) = label_code cont1 in + comp_expr env exp1 sz (Kbranchif lbl2 :: + comp_expr env exp2 sz (Kbranchifnot lbl :: cont2)) + | _ -> + let (lbl, cont1) = label_code cont in + comp_expr env exp1 sz (Kstrictbranchif lbl :: + comp_expr env exp2 sz cont1) + end + | Lprim(Praise, [arg]) -> + comp_expr env arg sz (Kraise :: discard_dead_code cont) + | Lprim(Paddint, [arg; Lconst(Const_base(Const_int n))]) + when is_immed n -> + comp_expr env arg sz (Koffsetint n :: cont) + | Lprim(Psubint, [arg; Lconst(Const_base(Const_int n))]) + when is_immed (-n) -> + comp_expr env arg sz (Koffsetint (-n) :: cont) + | Lprim (Poffsetint n, [arg]) + when not (is_immed n) -> + comp_expr env arg sz + (Kpush:: + Kconst (Const_base (Const_int n)):: + Kaddint::cont) + | Lprim(Pmakearray kind, args) -> + begin match kind with + Pintarray | Paddrarray -> + comp_args env args sz (Kmakeblock(List.length args, 0) :: cont) + | Pfloatarray -> + comp_args env args sz (Kmakefloatblock(List.length args) :: cont) + | Pgenarray -> + if args = [] + then Kmakeblock(0, 0) :: cont + else comp_args env args sz + (Kmakeblock(List.length args, 0) :: + Kccall("make_array", 1) :: cont) + end +(* Integer first for enabling futher optimization (cf. emitcode.ml) *) + | Lprim (Pintcomp c, [arg ; (Lconst _ as k)]) -> + let p = Pintcomp (commute_comparison c) + and args = [k ; arg] in + comp_args env args sz (comp_primitive p args :: cont) + | Lprim(p, args) -> + comp_args env args sz (comp_primitive p args :: cont) + | Lstaticcatch (body, (i, vars) , handler) -> + let nvars = List.length vars in + let branch1, cont1 = make_branch cont in + let r = + if nvars <> 1 then begin (* general case *) + let lbl_handler, cont2 = + label_code + (comp_expr + (add_vars vars (sz+1) env) + handler (sz+nvars) (add_pop nvars cont1)) in + sz_static_raises := + (i, (lbl_handler, sz+nvars)) :: !sz_static_raises ; + push_dummies nvars + (comp_expr env body (sz+nvars) + (add_pop nvars (branch1 :: cont2))) + end else begin (* small optimization for nvars = 1 *) + let var = match vars with [var] -> var | _ -> assert false in + let lbl_handler, cont2 = + label_code + (Kpush::comp_expr + (add_var var (sz+1) env) + handler (sz+1) (add_pop 1 cont1)) in + sz_static_raises := + (i, (lbl_handler, sz)) :: !sz_static_raises ; + comp_expr env body sz (branch1 :: cont2) + end in + sz_static_raises := List.tl !sz_static_raises ; + r + | Lstaticraise (i, args) -> + let cont = discard_dead_code cont in + let label,size = find_raise_label i in + begin match args with + | [arg] -> (* optim, argument passed in accumulator *) + comp_expr env arg sz + (add_pop (sz-size) (branch_to label cont)) + | _ -> + comp_exit_args env args sz size + (add_pop (sz-size) (branch_to label cont)) + end + | Ltrywith(body, id, handler) -> + let (branch1, cont1) = make_branch cont in + let lbl_handler = new_label() in + Kpushtrap lbl_handler :: + comp_expr env body (sz+4) (Kpoptrap :: branch1 :: + Klabel lbl_handler :: Kpush :: + comp_expr (add_var id (sz+1) env) handler (sz+1) (add_pop 1 cont1)) + | Lifthenelse(cond, ifso, ifnot) -> + comp_binary_test env cond ifso ifnot sz cont + | Lsequence(exp1, exp2) -> + comp_expr env exp1 sz (comp_expr env exp2 sz cont) + | Lwhile(cond, body) -> + let lbl_loop = new_label() in + let lbl_test = new_label() in + Kbranch lbl_test :: Klabel lbl_loop :: Kcheck_signals :: + comp_expr env body sz + (Klabel lbl_test :: + comp_expr env cond sz (Kbranchif lbl_loop :: add_const_unit cont)) + | Lfor(param, start, stop, dir, body) -> + let lbl_loop = new_label() in + let lbl_exit = new_label() in + let offset = match dir with Upto -> 1 | Downto -> -1 in + let comp = match dir with Upto -> Cgt | Downto -> Clt in + comp_expr env start sz + (Kpush :: comp_expr env stop (sz+1) + (Kpush :: Kpush :: Kacc 2 :: Kintcomp comp :: Kbranchif lbl_exit :: + Klabel lbl_loop :: Kcheck_signals :: + comp_expr (add_var param (sz+1) env) body (sz+2) + (Kacc 1 :: Kpush :: Koffsetint offset :: Kassign 2 :: + Kacc 1 :: Kintcomp Cneq :: Kbranchif lbl_loop :: + Klabel lbl_exit :: add_const_unit (add_pop 2 cont)))) + | Lswitch(arg, sw) -> + let (branch, cont1) = make_branch cont in + let c = ref (discard_dead_code cont1) in +(* Build indirection vectors *) + let store = mk_store (=) in + let act_consts = Array.create sw.sw_numconsts 0 + and act_blocks = Array.create sw.sw_numblocks 0 in + begin match sw.sw_failaction with (* default is index 0 *) + | Some fail -> ignore (store.act_store fail) + | None -> () + end ; + List.iter + (fun (n, act) -> act_consts.(n) <- store.act_store act) sw.sw_consts; + List.iter + (fun (n, act) -> act_blocks.(n) <- store.act_store act) sw.sw_blocks; + +(* Compile and label actions *) + let acts = store.act_get () in + let lbls = Array.create (Array.length acts) 0 in + for i = Array.length acts-1 downto 0 do + let lbl,c1 = label_code (comp_expr env acts.(i) sz (branch :: !c)) in + lbls.(i) <- lbl ; + c := discard_dead_code c1 + done ; + +(* Build label vectors *) + let lbl_blocks = Array.create sw.sw_numblocks 0 in + for i = sw.sw_numblocks - 1 downto 0 do + lbl_blocks.(i) <- lbls.(act_blocks.(i)) + done; + let lbl_consts = Array.create sw.sw_numconsts 0 in + for i = sw.sw_numconsts - 1 downto 0 do + lbl_consts.(i) <- lbls.(act_consts.(i)) + done; + comp_expr env arg sz (Kswitch(lbl_consts, lbl_blocks) :: !c) + | Lassign(id, expr) -> + begin try + let pos = Ident.find_same id env.ce_stack in + comp_expr env expr sz (Kassign(sz - pos) :: cont) + with Not_found -> + fatal_error "Bytegen.comp_expr: assign" + end + | Levent(lam, lev) -> + let event kind info = + { ev_pos = 0; (* patched in emitcode *) + ev_module = !compunit_name; + ev_char = lev.lev_pos; + ev_kind = kind; + ev_info = info; + ev_typenv = lev.lev_env; + ev_compenv = env; + ev_stacksize = sz; + ev_repr = + begin match lev.lev_repr with + None -> + Event_none + | Some ({contents = 1} as repr) when lev.lev_kind = Lev_function -> + Event_child repr + | Some ({contents = 1} as repr) -> + Event_parent repr + | Some repr when lev.lev_kind = Lev_function -> + Event_parent repr + | Some repr -> + Event_child repr + end } + in + begin match lev.lev_kind with + Lev_before -> + let c = comp_expr env lam sz cont in + let ev = event Event_before Event_other in + add_event ev c + | Lev_function -> + let c = comp_expr env lam sz cont in + let ev = event Event_pseudo Event_function in + add_event ev c + | Lev_after _ when is_tailcall cont -> (* don't destroy tail call opt *) + comp_expr env lam sz cont + | Lev_after ty -> + let info = + match lam with + Lapply(_, args) -> Event_return (List.length args) + | Lsend(_, _, args) -> Event_return (List.length args + 1) + | _ -> Event_other + in + let ev = event (Event_after ty) info in + let cont1 = add_event ev cont in + comp_expr env lam sz cont1 + end + | Lifused (_, exp) -> + comp_expr env exp sz cont + +(* Compile a list of arguments [e1; ...; eN] to a primitive operation. + The values of eN ... e2 are pushed on the stack, e2 at top of stack, + then e3, then ... The value of e1 is left in the accumulator. *) + +and comp_args env argl sz cont = + comp_expr_list env (List.rev argl) sz cont + +and comp_expr_list env exprl sz cont = match exprl with + [] -> cont + | [exp] -> comp_expr env exp sz cont + | exp :: rem -> + comp_expr env exp sz (Kpush :: comp_expr_list env rem (sz+1) cont) + +and comp_exit_args env argl sz pos cont = + comp_expr_list_assign env (List.rev argl) sz pos cont + +and comp_expr_list_assign env exprl sz pos cont = match exprl with + | [] -> cont + | exp :: rem -> + comp_expr env exp sz + (Kassign (sz-pos)::comp_expr_list_assign env rem sz (pos-1) cont) + +(* Compile an if-then-else test. *) + +and comp_binary_test env cond ifso ifnot sz cont = + let cont_cond = + if ifnot = Lconst const_unit then begin + let (lbl_end, cont1) = label_code cont in + Kstrictbranchifnot lbl_end :: comp_expr env ifso sz cont1 + end else + match code_as_jump ifso sz with + | Some label -> + let cont = comp_expr env ifnot sz cont in + Kbranchif label :: cont + | _ -> + match code_as_jump ifnot sz with + | Some label -> + let cont = comp_expr env ifso sz cont in + Kbranchifnot label :: cont + | _ -> + let (branch_end, cont1) = make_branch cont in + let (lbl_not, cont2) = label_code(comp_expr env ifnot sz cont1) in + Kbranchifnot lbl_not :: + comp_expr env ifso sz (branch_end :: cont2) in + + comp_expr env cond sz cont_cond + +(**** Compilation of a code block (with tracking of stack usage) ****) + +let comp_block env exp sz cont = + max_stack_used := 0; + let code = comp_expr env exp sz cont in + (* +1 because comp_expr may have pushed one more word *) + if !max_stack_used + 1 > Config.stack_threshold then + Kconst(Const_base(Const_int(!max_stack_used + 1))) :: + Kccall("ensure_stack_capacity", 1) :: + code + else + code + +(**** Compilation of functions ****) + +let comp_function tc cont = + let arity = List.length tc.params in + let rec positions pos delta = function + [] -> Ident.empty + | id :: rem -> Ident.add id pos (positions (pos + delta) delta rem) in + let env = + { ce_stack = positions arity (-1) tc.params; + ce_heap = positions (2 * (tc.num_defs - tc.rec_pos) - 1) 1 tc.free_vars; + ce_rec = positions (-2 * tc.rec_pos) 2 tc.rec_vars } in + let cont = + comp_block env tc.body arity (Kreturn arity :: cont) in + if arity > 1 then + Krestart :: Klabel tc.label :: Kgrab(arity - 1) :: cont + else + Klabel tc.label :: cont + +let comp_remainder cont = + let c = ref cont in + begin try + while true do + c := comp_function (Stack.pop functions_to_compile) !c + done + with Stack.Empty -> + () + end; + !c + +(**** Compilation of a lambda phrase ****) + +let compile_implementation modulename expr = + Stack.clear functions_to_compile; + label_counter := 0; + sz_static_raises := [] ; + compunit_name := modulename; + let init_code = comp_block empty_env expr 0 [] in + if Stack.length functions_to_compile > 0 then begin + let lbl_init = new_label() in + Kbranch lbl_init :: comp_remainder (Klabel lbl_init :: init_code) + end else + init_code + +let compile_phrase expr = + Stack.clear functions_to_compile; + label_counter := 0; + sz_static_raises := [] ; + let init_code = comp_block empty_env expr 1 [Kreturn 1] in + let fun_code = comp_remainder [] in + (init_code, fun_code) + diff --git a/bytecomp/bytegen.mli b/bytecomp/bytegen.mli new file mode 100644 index 00000000..b414e900 --- /dev/null +++ b/bytecomp/bytegen.mli @@ -0,0 +1,21 @@ +(***********************************************************************) +(* *) +(* 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: bytegen.mli,v 1.6 1999/11/17 18:56:59 xleroy Exp $ *) + +(* Generation of bytecode from lambda terms *) + +open Lambda +open Instruct + +val compile_implementation: string -> lambda -> instruction list +val compile_phrase: lambda -> instruction list * instruction list diff --git a/bytecomp/bytelibrarian.ml b/bytecomp/bytelibrarian.ml new file mode 100644 index 00000000..85d8eb92 --- /dev/null +++ b/bytecomp/bytelibrarian.ml @@ -0,0 +1,122 @@ +(***********************************************************************) +(* *) +(* 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: bytelibrarian.ml,v 1.18 2002/04/18 22:55:36 garrigue Exp $ *) + +(* Build libraries of .cmo files *) + +open Misc +open Config +open Emitcode + +type error = + File_not_found of string + | Not_an_object_file of string + +exception Error of error + +(* Copy a compilation unit from a .cmo or .cma into the archive *) +let copy_compunit ic oc compunit = + seek_in ic compunit.cu_pos; + compunit.cu_pos <- pos_out oc; + compunit.cu_force_link <- !Clflags.link_everything; + copy_file_chunk ic oc compunit.cu_codesize; + if compunit.cu_debug > 0 then begin + seek_in ic compunit.cu_debug; + compunit.cu_debug <- pos_out oc; + copy_file_chunk ic oc compunit.cu_debugsize + end + +(* Add C objects and options and "custom" info from a library descriptor *) + +let lib_sharedobjs = ref [] +let lib_ccobjs = ref [] +let lib_ccopts = ref [] +let lib_dllibs = ref [] + +(* See Bytelink.add_ccobjs for explanations on how options are ordered. + Notice that here we scan .cma files given on the command line from + left to right, hence options must be added after. *) + +let add_ccobjs l = + if not !Clflags.no_auto_link then begin + if l.lib_custom then Clflags.custom_runtime := true; + lib_ccobjs := !lib_ccobjs @ l.lib_ccobjs; + lib_ccopts := !lib_ccopts @ l.lib_ccopts; + lib_dllibs := !lib_dllibs @ l.lib_dllibs + end + +let copy_object_file oc name = + let file_name = + try + find_in_path !load_path name + with Not_found -> + raise(Error(File_not_found name)) in + let ic = open_in_bin file_name in + try + let buffer = String.create (String.length cmo_magic_number) in + really_input ic buffer 0 (String.length cmo_magic_number); + if buffer = cmo_magic_number then begin + let compunit_pos = input_binary_int ic in + seek_in ic compunit_pos; + let compunit = (input_value ic : compilation_unit) in + Bytelink.check_consistency file_name compunit; + copy_compunit ic oc compunit; + close_in ic; + [compunit] + end else + if buffer = cma_magic_number then begin + let toc_pos = input_binary_int ic in + seek_in ic toc_pos; + let toc = (input_value ic : library) in + List.iter (Bytelink.check_consistency file_name) toc.lib_units; + add_ccobjs toc; + List.iter (copy_compunit ic oc) toc.lib_units; + close_in ic; + toc.lib_units + end else + raise(Error(Not_an_object_file file_name)) + with + End_of_file -> close_in ic; raise(Error(Not_an_object_file file_name)) + | x -> close_in ic; raise x + +let create_archive file_list lib_name = + let outchan = open_out_bin lib_name in + try + output_string outchan cma_magic_number; + let ofs_pos_toc = pos_out outchan in + output_binary_int outchan 0; + let units = List.flatten(List.map (copy_object_file outchan) file_list) in + let toc = + { lib_units = units; + lib_custom = !Clflags.custom_runtime; + lib_ccobjs = !Clflags.ccobjs @ !lib_ccobjs; + lib_ccopts = !Clflags.ccopts @ !lib_ccopts; + lib_dllibs = !Clflags.dllibs @ !lib_dllibs } in + let pos_toc = pos_out outchan in + output_value outchan toc; + seek_out outchan ofs_pos_toc; + output_binary_int outchan pos_toc; + close_out outchan + with x -> + close_out outchan; + remove_file lib_name; + raise x + +open Format + +let report_error ppf = function + | File_not_found name -> + fprintf ppf "Cannot find file %s" name + | Not_an_object_file name -> + fprintf ppf "The file %s is not a bytecode object file" name + diff --git a/bytecomp/bytelibrarian.mli b/bytecomp/bytelibrarian.mli new file mode 100644 index 00000000..c9f14316 --- /dev/null +++ b/bytecomp/bytelibrarian.mli @@ -0,0 +1,34 @@ +(***********************************************************************) +(* *) +(* 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: bytelibrarian.mli,v 1.6 2000/03/06 22:11:06 weis Exp $ *) + +(* Build libraries of .cmo files *) + +(* Format of a library file: + magic number (Config.cma_magic_number) + absolute offset of content table + blocks of relocatable bytecode + content table = list of compilation units +*) + +val create_archive: string list -> string -> unit + +type error = + File_not_found of string + | Not_an_object_file of string + +exception Error of error + +open Format + +val report_error: formatter -> error -> unit diff --git a/bytecomp/bytelink.ml b/bytecomp/bytelink.ml new file mode 100644 index 00000000..830b2b2b --- /dev/null +++ b/bytecomp/bytelink.ml @@ -0,0 +1,575 @@ +(***********************************************************************) +(* *) +(* 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: bytelink.ml,v 1.80 2002/11/17 16:42:10 xleroy Exp $ *) + +(* Link a set of .cmo files and produce a bytecode executable. *) + +open Sys +open Misc +open Config +open Instruct +open Emitcode + +type error = + File_not_found of string + | Not_an_object_file of string + | Symbol_error of string * Symtable.error + | Inconsistent_import of string * string * string + | Custom_runtime + | File_exists of string + | Cannot_open_dll of string + +exception Error of error + +type link_action = + Link_object of string * compilation_unit + (* Name of .cmo file and descriptor of the unit *) + | Link_archive of string * compilation_unit list + (* Name of .cma file and descriptors of the units to be linked. *) + +(* Add C objects and options from a library descriptor *) +(* Ignore them if -noautolink or -use-runtime or -use-prim was given *) + +let lib_ccobjs = ref [] +let lib_ccopts = ref [] +let lib_dllibs = ref [] + +let add_ccobjs l = + if not !Clflags.no_auto_link + && String.length !Clflags.use_runtime = 0 + && String.length !Clflags.use_prims = 0 + then begin + if l.lib_custom then Clflags.custom_runtime := true; + lib_ccobjs := l.lib_ccobjs @ !lib_ccobjs; + lib_ccopts := l.lib_ccopts @ !lib_ccopts; + lib_dllibs := l.lib_dllibs @ !lib_dllibs + end + +(* A note on ccobj ordering: + - Clflags.ccobjs is in reverse order w.r.t. what was given on the + ocamlc command line; + - l.lib_ccobjs is also in reverse order w.r.t. what was given on the + ocamlc -a command line when the library was created; + - Clflags.ccobjs is reversed just before calling the C compiler for the + custom link; + - .cma files on the command line of ocamlc are scanned right to left; + - Before linking, we add lib_ccobjs after Clflags.ccobjs. + Thus, for ocamlc a.cma b.cma obj1 obj2 + where a.cma was built with ocamlc -i ... obja1 obja2 + and b.cma was built with ocamlc -i ... objb1 objb2 + lib_ccobjs starts as [], + becomes objb2 objb1 when b.cma is scanned, + then obja2 obja1 objb2 objb1 when a.cma is scanned. + Clflags.ccobjs was initially obj2 obj1. + and is set to obj2 obj1 obja2 obja1 objb2 objb1. + Finally, the C compiler is given objb1 objb2 obja1 obja2 obj1 obj2, + which is what we need. (If b depends on a, a.cma must appear before + b.cma, but b's C libraries must appear before a's C libraries.) +*) + +(* First pass: determine which units are needed *) + +module IdentSet = + Set.Make(struct + type t = Ident.t + let compare = compare + end) + +let missing_globals = ref IdentSet.empty + +let is_required (rel, pos) = + match rel with + Reloc_setglobal id -> + IdentSet.mem id !missing_globals + | _ -> false + +let add_required (rel, pos) = + match rel with + Reloc_getglobal id -> + missing_globals := IdentSet.add id !missing_globals + | _ -> () + +let remove_required (rel, pos) = + match rel with + Reloc_setglobal id -> + missing_globals := IdentSet.remove id !missing_globals + | _ -> () + +let scan_file obj_name tolink = + let file_name = + try + find_in_path !load_path obj_name + with Not_found -> + raise(Error(File_not_found obj_name)) in + let ic = open_in_bin file_name in + try + let buffer = String.create (String.length cmo_magic_number) in + really_input ic buffer 0 (String.length cmo_magic_number); + if buffer = cmo_magic_number then begin + (* This is a .cmo file. It must be linked in any case. + Read the relocation information to see which modules it + requires. *) + let compunit_pos = input_binary_int ic in (* Go to descriptor *) + seek_in ic compunit_pos; + let compunit = (input_value ic : compilation_unit) in + close_in ic; + List.iter add_required compunit.cu_reloc; + Link_object(file_name, compunit) :: tolink + end + else if buffer = cma_magic_number then begin + (* This is an archive file. Each unit contained in it will be linked + in only if needed. *) + let pos_toc = input_binary_int ic in (* Go to table of contents *) + seek_in ic pos_toc; + let toc = (input_value ic : library) in + close_in ic; + add_ccobjs toc; + let required = + List.fold_right + (fun compunit reqd -> + if compunit.cu_force_link + || !Clflags.link_everything + || List.exists is_required compunit.cu_reloc + then begin + List.iter remove_required compunit.cu_reloc; + List.iter add_required compunit.cu_reloc; + compunit :: reqd + end else + reqd) + toc.lib_units [] in + Link_archive(file_name, required) :: tolink + end + else raise(Error(Not_an_object_file file_name)) + with + End_of_file -> close_in ic; raise(Error(Not_an_object_file file_name)) + | x -> close_in ic; raise x + +(* Second pass: link in the required units *) + +(* Consistency check between interfaces *) + +let crc_interfaces = Consistbl.create () + +let check_consistency file_name cu = + try + List.iter + (fun (name, crc) -> + if name = cu.cu_name + then Consistbl.set crc_interfaces name crc file_name + else Consistbl.check crc_interfaces name crc file_name) + cu.cu_imports + with Consistbl.Inconsistency(name, user, auth) -> + raise(Error(Inconsistent_import(name, user, auth))) + +let extract_crc_interfaces () = + Consistbl.extract crc_interfaces + +(* Record compilation events *) + +let debug_info = ref ([] : (int * string) list) + +(* Link in a compilation unit *) + +let link_compunit output_fun currpos_fun inchan file_name compunit = + check_consistency file_name compunit; + seek_in inchan compunit.cu_pos; + let code_block = String.create compunit.cu_codesize in + really_input inchan code_block 0 compunit.cu_codesize; + Symtable.patch_object code_block compunit.cu_reloc; + if !Clflags.debug && compunit.cu_debug > 0 then begin + seek_in inchan compunit.cu_debug; + let buffer = String.create compunit.cu_debugsize in + really_input inchan buffer 0 compunit.cu_debugsize; + debug_info := (currpos_fun(), buffer) :: !debug_info + end; + output_fun code_block; + if !Clflags.link_everything then + List.iter Symtable.require_primitive compunit.cu_primitives + +(* Link in a .cmo file *) + +let link_object output_fun currpos_fun file_name compunit = + let inchan = open_in_bin file_name in + try + link_compunit output_fun currpos_fun inchan file_name compunit; + close_in inchan + with + Symtable.Error msg -> + close_in inchan; raise(Error(Symbol_error(file_name, msg))) + | x -> + close_in inchan; raise x + +(* Link in a .cma file *) + +let link_archive output_fun currpos_fun file_name units_required = + let inchan = open_in_bin file_name in + try + List.iter + (fun cu -> + let name = file_name ^ "(" ^ cu.cu_name ^ ")" in + try + link_compunit output_fun currpos_fun inchan name cu + with Symtable.Error msg -> + raise(Error(Symbol_error(name, msg)))) + units_required; + close_in inchan + with x -> close_in inchan; raise x + +(* Link in a .cmo or .cma file *) + +let link_file output_fun currpos_fun = function + Link_object(file_name, unit) -> + link_object output_fun currpos_fun file_name unit + | Link_archive(file_name, units) -> + link_archive output_fun currpos_fun file_name units + +(* Output the debugging information *) +(* Format is: + number of event lists + offset of first event list + first event list + ... + offset of last event list + last event list *) + +let output_debug_info oc = + output_binary_int oc (List.length !debug_info); + List.iter + (fun (ofs, evl) -> output_binary_int oc ofs; output_string oc evl) + !debug_info; + debug_info := [] + +(* Output a list of strings with 0-termination *) + +let output_stringlist oc l = + List.iter (fun s -> output_string oc s; output_byte oc 0) l + +(* Transform a file name into an absolute file name *) + +let make_absolute file = + if Filename.is_relative file + then Filename.concat (Sys.getcwd()) file + else file + +(* Create a bytecode executable file *) + +let link_bytecode tolink exec_name standalone = + if Sys.os_type = "MacOS" then begin + (* Create it as a text file for bytecode scripts *) + let c = open_out_gen [Open_wronly; Open_creat] 0o777 exec_name in + close_out c + end; + let outchan = open_out_gen [Open_wronly; Open_trunc; Open_creat; Open_binary] + 0o777 exec_name in + try + if standalone then begin + (* Copy the header *) + try + let header = + if String.length !Clflags.use_runtime > 0 + then "camlheader_ur" else "camlheader" in + let inchan = open_in_bin (find_in_path !load_path header) in + copy_file inchan outchan; + close_in inchan + with Not_found | Sys_error _ -> () + end; + Bytesections.init_record outchan; + (* The path to the bytecode interpreter (in use_runtime mode) *) + if String.length !Clflags.use_runtime > 0 then begin + output_string outchan (make_absolute !Clflags.use_runtime); + output_char outchan '\n'; + Bytesections.record outchan "RNTM" + end; + (* The bytecode *) + let start_code = pos_out outchan in + Symtable.init(); + Consistbl.clear crc_interfaces; + let sharedobjs = List.map Dll.extract_dll_name !Clflags.dllibs in + if standalone then begin + (* Initialize the DLL machinery *) + Dll.init_compile !Clflags.no_std_include; + Dll.add_path !load_path; + try Dll.open_dlls sharedobjs + with Failure reason -> raise(Error(Cannot_open_dll reason)) + end; + let output_fun = output_string outchan + and currpos_fun () = pos_out outchan - start_code in + List.iter (link_file output_fun currpos_fun) tolink; + if standalone then Dll.close_all_dlls(); + (* The final STOP instruction *) + output_byte outchan Opcodes.opSTOP; + output_byte outchan 0; output_byte outchan 0; output_byte outchan 0; + Bytesections.record outchan "CODE"; + (* DLL stuff *) + if standalone then begin + (* The extra search path for DLLs *) + output_stringlist outchan !Clflags.dllpaths; + Bytesections.record outchan "DLPT"; + (* The names of the DLLs *) + output_stringlist outchan sharedobjs; + Bytesections.record outchan "DLLS" + end; + (* The names of all primitives *) + Symtable.output_primitive_names outchan; + Bytesections.record outchan "PRIM"; + (* The table of global data *) + output_value outchan (Symtable.initial_global_table()); + Bytesections.record outchan "DATA"; + (* The map of global identifiers *) + Symtable.output_global_map outchan; + Bytesections.record outchan "SYMB"; + (* CRCs for modules *) + output_value outchan (extract_crc_interfaces()); + Bytesections.record outchan "CRCS"; + (* Debug info *) + if !Clflags.debug then begin + output_debug_info outchan; + Bytesections.record outchan "DBUG" + end; + (* The table of contents and the trailer *) + Bytesections.write_toc_and_trailer outchan; + close_out outchan + with x -> + close_out outchan; + remove_file exec_name; + raise x + +(* Output a string as a C array of unsigned ints *) + +let output_code_string_counter = ref 0 + +let output_code_string outchan code = + let pos = ref 0 in + let len = String.length code in + while !pos < len do + let c1 = Char.code(code.[!pos]) in + let c2 = Char.code(code.[!pos + 1]) in + let c3 = Char.code(code.[!pos + 2]) in + let c4 = Char.code(code.[!pos + 3]) in + pos := !pos + 4; + Printf.fprintf outchan "0x%02x%02x%02x%02x, " c4 c3 c2 c1; + incr output_code_string_counter; + if !output_code_string_counter >= 6 then begin + output_char outchan '\n'; + output_code_string_counter := 0 + end + done + +(* Output a string as a C string *) + +let output_data_string outchan data = + let counter = ref 0 in + for i = 0 to String.length data - 1 do + Printf.fprintf outchan "%d, " (Char.code(data.[i])); + incr counter; + if !counter >= 12 then begin + output_string outchan "\n"; + counter := 0 + end + done + +(* Output a bytecode executable as a C file *) + +let link_bytecode_as_c tolink outfile = + let outchan = open_out outfile in + try + (* The bytecode *) + output_string outchan "static int caml_code[] = {\n"; + Symtable.init(); + Consistbl.clear crc_interfaces; + let output_fun = output_code_string outchan + and currpos_fun () = 0 in + List.iter (link_file output_fun currpos_fun) tolink; + (* The final STOP instruction *) + Printf.fprintf outchan "\n0x%x};\n\n" Opcodes.opSTOP; + (* The table of global data *) + output_string outchan "static char caml_data[] = {\n"; + output_data_string outchan + (Marshal.to_string (Symtable.initial_global_table()) []); + Printf.fprintf outchan "\n};\n\n"; + (* The table of primitives *) + Symtable.output_primitive_table outchan; + (* The entry point *) + output_string outchan "\n +void caml_startup(argv) + char ** argv; +{ + caml_startup_code(caml_code, sizeof(caml_code), caml_data, argv); +}\n"; + close_out outchan + with x -> + close_out outchan; + raise x + +(* Build a custom runtime *) + +let rec extract suffix l = + match l with + | [] -> [] + | h::t when Filename.check_suffix h suffix -> h :: (extract suffix t) + | h::t -> extract suffix t +;; + +let build_custom_runtime prim_name exec_name = + match Config.ccomp_type with + "cc" -> + Ccomp.command + (Printf.sprintf + "%s -o %s %s %s %s %s %s -lcamlrun %s" + !Clflags.c_linker + (Filename.quote exec_name) + (Clflags.std_include_flag "-I") + (String.concat " " (List.rev !Clflags.ccopts)) + prim_name + (Ccomp.quote_files + (List.map (fun dir -> if dir = "" then "" else "-L" ^ dir) + !load_path)) + (Ccomp.quote_files (List.rev !Clflags.ccobjs)) + Config.bytecomp_c_libraries) + | "msvc" -> + let retcode = + Ccomp.command + (Printf.sprintf + "%s /Fe%s %s %s %s %s %s %s" + !Clflags.c_linker + (Filename.quote exec_name) + (Clflags.std_include_flag "-I") + prim_name + (Ccomp.quote_files + (List.rev_map Ccomp.expand_libname !Clflags.ccobjs)) + (Filename.quote (Ccomp.expand_libname "-lcamlrun")) + Config.bytecomp_c_libraries + (String.concat " " (List.rev !Clflags.ccopts))) in + (* C compiler doesn't clean up after itself. Note that the .obj + file is created in the current working directory. *) + remove_file + (Filename.chop_suffix (Filename.basename prim_name) ".c" ^ ".obj"); + retcode + | "mrc" -> + let cppc = "mrc" + and libsppc = "\"{sharedlibraries}MathLib\" \ + \"{ppclibraries}PPCCRuntime.o\" \ + \"{ppclibraries}PPCToolLibs.o\" \ + \"{sharedlibraries}StdCLib\" \ + \"{ppclibraries}StdCRuntime.o\" \ + \"{sharedlibraries}InterfaceLib\"" + and linkppc = "ppclink -d" + and objsppc = extract ".x" (List.rev !Clflags.ccobjs) + and q_prim_name = Filename.quote prim_name + and q_exec_name = Filename.quote exec_name + in + Ccomp.run_command (Printf.sprintf "%s %s %s %s -o %s.x" + cppc + (Clflags.std_include_flag "-i ") + (String.concat " " (List.rev_map Filename.quote !Clflags.ccopts)) + q_prim_name + q_prim_name); + Ccomp.run_command ("delete -i " ^ q_exec_name); + Ccomp.command (Printf.sprintf + "%s -t MPST -c 'MPS ' -o %s %s.x %s %s %s" + linkppc + q_exec_name + q_prim_name + (String.concat " " (List.map Filename.quote objsppc)) + (Filename.quote + (Filename.concat Config.standard_library "libcamlrun.x")) + libsppc) + | _ -> assert false + +let append_bytecode_and_cleanup bytecode_name exec_name prim_name = + let oc = open_out_gen [Open_wronly; Open_append; Open_binary] 0 exec_name in + let ic = open_in_bin bytecode_name in + copy_file ic oc; + close_in ic; + close_out oc; + remove_file bytecode_name; + remove_file prim_name + +(* Fix the name of the output file, if the C compiler changes it behind + our back. *) + +let fix_exec_name name = + match Sys.os_type with + "Win32" | "Cygwin" -> + if String.contains name '.' then name else name ^ ".exe" + | _ -> name + +(* Main entry point (build a custom runtime if needed) *) + +let link objfiles output_name = + let objfiles = + if !Clflags.nopervasives then objfiles + else if !Clflags.output_c_object then "stdlib.cma" :: objfiles + else "stdlib.cma" :: (objfiles @ ["std_exit.cmo"]) in + let tolink = List.fold_right scan_file objfiles [] in + Clflags.ccobjs := !Clflags.ccobjs @ !lib_ccobjs; (* put user's libs last *) + Clflags.ccopts := !lib_ccopts @ !Clflags.ccopts; (* put user's opts first *) + Clflags.dllibs := !lib_dllibs @ !Clflags.dllibs; (* put user's DLLs first *) + if not !Clflags.custom_runtime then + link_bytecode tolink output_name true + else if not !Clflags.output_c_object then begin + let bytecode_name = Filename.temp_file "camlcode" "" in + let prim_name = Filename.temp_file "camlprim" ".c" in + try + link_bytecode tolink bytecode_name false; + let poc = open_out prim_name in + Symtable.output_primitive_table poc; + close_out poc; + let exec_name = fix_exec_name output_name in + if build_custom_runtime prim_name exec_name <> 0 + then raise(Error Custom_runtime); + if !Clflags.make_runtime + then (remove_file bytecode_name; remove_file prim_name) + else append_bytecode_and_cleanup bytecode_name exec_name prim_name + with x -> + remove_file bytecode_name; + remove_file prim_name; + raise x + end else begin + let c_file = + Filename.chop_suffix output_name Config.ext_obj ^ ".c" in + if Sys.file_exists c_file then raise(Error(File_exists c_file)); + try + link_bytecode_as_c tolink c_file; + if Ccomp.compile_file c_file <> 0 + then raise(Error Custom_runtime); + remove_file c_file + with x -> + remove_file c_file; + remove_file output_name; + raise x + end + +(* Error report *) + +open Format + +let report_error ppf = function + | File_not_found name -> + fprintf ppf "Cannot find file %s" name + | Not_an_object_file name -> + fprintf ppf "The file %s is not a bytecode object file" name + | Symbol_error(name, err) -> + fprintf ppf "Error while linking %s:@ %a" name + Symtable.report_error err + | Inconsistent_import(intf, file1, file2) -> + fprintf ppf + "@[Files %s@ and %s@ \ + make inconsistent assumptions over interface %s@]" + file1 file2 intf + | Custom_runtime -> + fprintf ppf "Error while building custom runtime system" + | File_exists file -> + fprintf ppf "Cannot overwrite existing file %s" file + | Cannot_open_dll file -> + fprintf ppf "Error on dynamically loaded library: %s" file diff --git a/bytecomp/bytelink.mli b/bytecomp/bytelink.mli new file mode 100644 index 00000000..244ef75a --- /dev/null +++ b/bytecomp/bytelink.mli @@ -0,0 +1,36 @@ +(***********************************************************************) +(* *) +(* 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: bytelink.mli,v 1.11 2002/06/11 14:15:11 xleroy Exp $ *) + +(* Link .cmo files and produce a bytecode executable. *) + +val link: string list -> string -> unit + +val check_consistency: string -> Emitcode.compilation_unit -> unit + +val extract_crc_interfaces: unit -> (string * Digest.t) list + +type error = + File_not_found of string + | Not_an_object_file of string + | Symbol_error of string * Symtable.error + | Inconsistent_import of string * string * string + | Custom_runtime + | File_exists of string + | Cannot_open_dll of string + +exception Error of error + +open Format + +val report_error: formatter -> error -> unit diff --git a/bytecomp/bytepackager.ml b/bytecomp/bytepackager.ml new file mode 100644 index 00000000..33841c5b --- /dev/null +++ b/bytecomp/bytepackager.ml @@ -0,0 +1,224 @@ +(***********************************************************************) +(* *) +(* 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: bytepackager.ml,v 1.3 2003/03/10 16:56:22 xleroy Exp $ *) + +(* "Package" a set of .cmo files into one .cmo file having the + original compilation units as sub-modules. *) + +open Misc +open Instruct +open Emitcode + +type error = + Forward_reference of string * Ident.t + | Multiple_definition of string * Ident.t + | Not_an_object_file of string + | Illegal_renaming of string * string + | File_not_found of string + +exception Error of error + +(* References accumulating informations on the .cmo files *) + +let relocs = ref ([] : (reloc_info * int) list) +let events = ref ([] : debug_event list) +let primitives = ref ([] : string list) +let force_link = ref false + +(* Record a relocation. Update its offset, and rename GETGLOBAL and + SETGLOBAL relocations that correspond to one of the units being + consolidated. *) + +let rename_relocation objfile mapping defined base (rel, ofs) = + let rel' = + match rel with + Reloc_getglobal id -> + begin try + let id' = List.assoc id mapping in + if List.mem id defined + then Reloc_getglobal id' + else raise(Error(Forward_reference(objfile, id))) + with Not_found -> + rel + end + | Reloc_setglobal id -> + begin try + let id' = List.assoc id mapping in + if List.mem id defined + then raise(Error(Multiple_definition(objfile, id))) + else Reloc_setglobal id' + with Not_found -> + rel + end + | _ -> + rel in + relocs := (rel', base + ofs) :: !relocs + +(* Record and relocate a debugging event *) + +let relocate_debug base ev = + ev.ev_pos <- base + ev.ev_pos; + events := ev :: !events + +(* Read the unit information from a .cmo file. *) + +let read_unit_info objfile = + let ic = open_in_bin objfile in + try + let buffer = String.create (String.length Config.cmo_magic_number) in + really_input ic buffer 0 (String.length Config.cmo_magic_number); + if buffer <> Config.cmo_magic_number then + raise(Error(Not_an_object_file objfile)); + let compunit_pos = input_binary_int ic in + seek_in ic compunit_pos; + let compunit = (input_value ic : compilation_unit) in + if compunit.cu_name + <> String.capitalize(Filename.basename(chop_extension_if_any objfile)) + then raise(Error(Illegal_renaming(objfile, compunit.cu_name))); + close_in ic; + compunit + with x -> + close_in ic; + raise x + +(* Read the bytecode from a .cmo file. + Write bytecode to channel [oc]. + Rename globals as indicated by [mapping] in reloc info. + Accumulate relocs, debug info, etc. + Return size of bytecode. *) + +let rename_append_bytecode oc mapping defined ofs (objfile, compunit) = + let ic = open_in_bin objfile in + try + Bytelink.check_consistency objfile compunit; + List.iter + (rename_relocation objfile mapping defined ofs) + compunit.cu_reloc; + primitives := compunit.cu_primitives @ !primitives; + if compunit.cu_force_link then force_link := true; + seek_in ic compunit.cu_pos; + Misc.copy_file_chunk ic oc compunit.cu_codesize; + if !Clflags.debug && compunit.cu_debug > 0 then begin + seek_in ic compunit.cu_debug; + List.iter (relocate_debug ofs) (input_value ic); + end; + close_in ic; + compunit.cu_codesize + with x -> + close_in ic; + raise x + +(* Same, for a list of .cmo files. Return total size of bytecode. *) + +let rec rename_append_bytecode_list oc mapping defined ofs = function + [] -> + ofs + | ((objfile, compunit) as obj_unit) :: rem -> + let size = rename_append_bytecode oc mapping defined ofs obj_unit in + rename_append_bytecode_list + oc mapping (Ident.create_persistent compunit.cu_name :: defined) + (ofs + size) rem + +(* Generate the code that builds the tuple representing the package module *) + +let build_global_target oc target_name mapping pos coercion = + let lam = + Translmod.transl_package (List.map snd mapping) + (Ident.create_persistent target_name) coercion in + let instrs = + Bytegen.compile_implementation target_name lam in + let rel = + Emitcode.to_packed_file oc instrs in + relocs := List.map (fun (r, ofs) -> (r, pos + ofs)) rel @ !relocs + +(* Build the .cmo file obtained by packaging the given .cmo files. *) + +let package_object_files objfiles targetfile targetname coercion = + let units = + List.map (fun f -> (f, read_unit_info f)) objfiles in + let unit_names = + List.map (fun (_, cu) -> cu.cu_name) units in + let mapping = + List.map + (fun name -> + (Ident.create_persistent name, + Ident.create_persistent(targetname ^ "." ^ name))) + unit_names in + let oc = open_out_bin targetfile in + try + output_string oc Config.cmo_magic_number; + let pos_depl = pos_out oc in + output_binary_int oc 0; + let pos_code = pos_out oc in + let ofs = rename_append_bytecode_list oc mapping [] 0 units in + build_global_target oc targetname mapping ofs coercion; + let pos_debug = pos_out oc in + if !Clflags.debug && !events <> [] then + output_value oc (List.rev !events); + let pos_final = pos_out oc in + let imports = + List.filter + (fun (name, crc) -> not (List.mem name unit_names)) + (Bytelink.extract_crc_interfaces()) in + let compunit = + { cu_name = targetname; + cu_pos = pos_code; + cu_codesize = pos_debug - pos_code; + cu_reloc = List.rev !relocs; + cu_imports = (targetname, Env.crc_of_unit targetname) :: imports; + cu_primitives = !primitives; + cu_force_link = !force_link; + cu_debug = if pos_final > pos_debug then pos_debug else 0; + cu_debugsize = pos_final - pos_debug } in + output_value oc compunit; + seek_out oc pos_depl; + output_binary_int oc pos_final; + close_out oc + with x -> + close_out oc; + raise x + +(* The entry point *) + +let package_files files targetfile = + let objfiles = + List.map + (fun f -> + try find_in_path !Config.load_path f + with Not_found -> raise(Error(File_not_found f))) + files in + let prefix = chop_extension_if_any targetfile in + let targetcmi = prefix ^ ".cmi" in + let targetname = String.capitalize(Filename.basename prefix) in + try + let coercion = Typemod.package_units objfiles targetcmi targetname in + package_object_files objfiles targetfile targetname coercion + with x -> + remove_file targetfile; raise x + +(* Error report *) + +open Format + +let report_error ppf = function + Forward_reference(file, ident) -> + fprintf ppf "Forward reference to %s in file %s" (Ident.name ident) file + | Multiple_definition(file, ident) -> + fprintf ppf "File %s redefines %s" file (Ident.name ident) + | Not_an_object_file file -> + fprintf ppf "%s is not a bytecode object file" file + | Illegal_renaming(file, id) -> + fprintf ppf "Wrong file naming: %s@ contains the code for@ %s" + file id + | File_not_found file -> + fprintf ppf "File %s not found" file diff --git a/bytecomp/bytepackager.mli b/bytecomp/bytepackager.mli new file mode 100644 index 00000000..914cd59b --- /dev/null +++ b/bytecomp/bytepackager.mli @@ -0,0 +1,29 @@ +(***********************************************************************) +(* *) +(* 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: bytepackager.mli,v 1.1 2002/02/08 16:55:42 xleroy Exp $ *) + +(* "Package" a set of .cmo files into one .cmo file having the + original compilation units as sub-modules. *) + +val package_files: string list -> string -> unit + +type error = + Forward_reference of string * Ident.t + | Multiple_definition of string * Ident.t + | Not_an_object_file of string + | Illegal_renaming of string * string + | File_not_found of string + +exception Error of error + +val report_error: Format.formatter -> error -> unit diff --git a/bytecomp/bytesections.ml b/bytecomp/bytesections.ml new file mode 100644 index 00000000..97fbf7a2 --- /dev/null +++ b/bytecomp/bytesections.ml @@ -0,0 +1,93 @@ +(***********************************************************************) +(* *) +(* 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 Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: bytesections.ml,v 1.2 2001/08/28 14:47:06 xleroy Exp $ *) + +(* Handling of sections in bytecode executable files *) + +(* List of all sections, in reverse order *) + +let section_table = ref ([] : (string * int) list) + +(* Recording sections *) + +let section_beginning = ref 0 + +let init_record outchan = + section_beginning := pos_out outchan; + section_table := [] + +let record outchan name = + let pos = pos_out outchan in + section_table := (name, pos - !section_beginning) :: !section_table; + section_beginning := pos + +let write_toc_and_trailer outchan = + List.iter + (fun (name, len) -> + output_string outchan name; output_binary_int outchan len) + (List.rev !section_table); + output_binary_int outchan (List.length !section_table); + output_string outchan Config.exec_magic_number; + section_table := []; + +(* Read the table of sections from a bytecode executable *) + +exception Bad_magic_number + +let read_toc ic = + let pos_trailer = in_channel_length ic - 16 in + seek_in ic pos_trailer; + let num_sections = input_binary_int ic in + let header = String.create(String.length Config.exec_magic_number) in + really_input ic header 0 (String.length Config.exec_magic_number); + if header <> Config.exec_magic_number then raise Bad_magic_number; + seek_in ic (pos_trailer - 8 * num_sections); + section_table := []; + for i = 1 to num_sections do + let name = String.create 4 in + really_input ic name 0 4; + let len = input_binary_int ic in + section_table := (name, len) :: !section_table + done + +(* Return the current table of contents *) + +let toc () = List.rev !section_table + +(* Position ic at the beginning of the section named "name", + and return the length of that section. Raise Not_found if no + such section exists. *) + +let seek_section ic name = + let rec seek_sec curr_ofs = function + [] -> raise Not_found + | (n, len) :: rem -> + if n = name + then begin seek_in ic (curr_ofs - len); len end + else seek_sec (curr_ofs - len) rem in + seek_sec (in_channel_length ic - 16 - 8 * List.length !section_table) + !section_table + +(* Return the contents of a section, as a string *) + +let read_section ic name = + let len = seek_section ic name in + let res = String.create len in + really_input ic res 0 len; + res + +(* Return the position of the beginning of the first section *) + +let pos_first_section ic = + in_channel_length ic - 16 - 8 * List.length !section_table - + List.fold_left (fun total (name, len) -> total + len) 0 !section_table diff --git a/bytecomp/bytesections.mli b/bytecomp/bytesections.mli new file mode 100644 index 00000000..e7418b64 --- /dev/null +++ b/bytecomp/bytesections.mli @@ -0,0 +1,51 @@ +(***********************************************************************) +(* *) +(* 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 Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: bytesections.mli,v 1.2 2001/08/28 14:47:06 xleroy Exp $ *) + +(* Handling of sections in bytecode executable files *) + +(** Recording sections written to a bytecode executable file *) + +val init_record: out_channel -> unit + (* Start recording sections from the current position in out_channel *) + +val record: out_channel -> string -> unit + (* Record the current position in the out_channel as the end of + the section with the given name *) + +val write_toc_and_trailer: out_channel -> unit + (* Write the table of contents and the standard trailer for bytecode + executable files *) + +(** Reading sections from a bytecode executable file *) + +val read_toc: in_channel -> unit + (* Read the table of sections from a bytecode executable *) + +exception Bad_magic_number + (* Raised by [read_toc] if magic number doesn't match *) + +val toc: unit -> (string * int) list + (* Return the current table of contents as a list of + (section name, section length) pairs. *) + +val seek_section: in_channel -> string -> int + (* Position the input channel at the beginning of the section named "name", + and return the length of that section. Raise Not_found if no + such section exists. *) + +val read_section: in_channel -> string -> string + (* Return the contents of a section, as a string *) + +val pos_first_section: in_channel -> int + (* Return the position of the beginning of the first section *) diff --git a/bytecomp/dll.ml b/bytecomp/dll.ml new file mode 100644 index 00000000..ce66421a --- /dev/null +++ b/bytecomp/dll.ml @@ -0,0 +1,168 @@ +(***********************************************************************) +(* *) +(* 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 Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: dll.ml,v 1.10 2002/07/02 16:13:12 weis Exp $ *) + +(* Handling of dynamically-linked libraries *) + +type dll_handle +type dll_address + +external dll_open: string -> dll_handle = "dynlink_open_lib" +external dll_close: dll_handle -> unit = "dynlink_close_lib" +external dll_sym: dll_handle -> string -> dll_address = "dynlink_lookup_symbol" + (* returned dll_address may be Val_unit *) +external add_primitive: dll_address -> int = "dynlink_add_primitive" +external get_current_dlls: unit -> dll_handle array + = "dynlink_get_current_libs" + +(* Current search path for DLLs *) +let search_path = ref ([] : string list) + +(* DLLs currently opened *) +let opened_dlls = ref ([] : dll_handle list) + +(* File names for those DLLs *) +let names_of_opened_dlls = ref ([] : string list) + +(* Add the given directories to the search path for DLLs. *) +let add_path dirs = + search_path := dirs @ !search_path + +(* Extract the name of a DLLs from its external name (xxx.so or -lxxx) *) + +let extract_dll_name file = + if Filename.check_suffix file Config.ext_dll then + Filename.chop_suffix file Config.ext_dll + else if String.length file >= 2 && String.sub file 0 2 = "-l" then + "dll" ^ String.sub file 2 (String.length file - 2) + else + file (* will cause error later *) + +(* Open a list of DLLs, adding them to opened_dlls. + Raise [Failure msg] in case of error. *) + +let open_dll name = + let name = name ^ Config.ext_dll in + let fullname = + try + let fullname = Misc.find_in_path !search_path name in + if Filename.is_implicit fullname then + Filename.concat Filename.current_dir_name fullname + else fullname + with Not_found -> name in + if not (List.mem fullname !names_of_opened_dlls) then begin + let dll = dll_open fullname in + names_of_opened_dlls := fullname :: !names_of_opened_dlls; + opened_dlls := dll :: !opened_dlls + end + +let open_dlls names = + List.iter open_dll names + +(* Close all DLLs *) + +let close_all_dlls () = + List.iter dll_close !opened_dlls; + opened_dlls := []; + names_of_opened_dlls := [] + +(* Find a primitive in the currently opened DLLs. + Raise [Not_found] if not found. *) + +let find_primitive prim_name = + let rec find = function + [] -> + raise Not_found + | dll :: rem -> + let addr = dll_sym dll prim_name in + if addr == Obj.magic () then find rem else addr in + find !opened_dlls + +(* If linking in core (dynlink or toplevel), synchronize the VM + table of primitive with the linker's table of primitive + by storing the given primitive function at the given position + in the VM table of primitives. *) + +let linking_in_core = ref false + +let synchronize_primitive num symb = + if !linking_in_core then begin + let actual_num = add_primitive symb in + assert (actual_num = num) + end + +(* Read the [ld.conf] file and return the corresponding list of directories *) + +let ld_conf_contents () = + let path = ref [] in + begin try + let ic = open_in (Filename.concat Config.standard_library "ld.conf") in + begin try + while true do + path := input_line ic :: !path + done + with End_of_file -> () + end; + close_in ic + with Sys_error _ -> () + end; + List.rev !path + +(* Split the CAML_LD_LIBRARY_PATH environment variable and return + the corresponding list of directories. *) + +let split str sep = + let rec split_rec pos = + if pos >= String.length str then [] else begin + try + let newpos = String.index_from str pos sep in + String.sub str pos (newpos - pos) :: + split_rec (newpos + 1) + with Not_found -> + [String.sub str pos (String.length str - pos)] + end in + split_rec 0 + +let ld_library_path_contents () = + let path_separator = + match Sys.os_type with + | "Unix" | "Cygwin" -> ':' + | "Win32" -> ';' + | "MacOS" -> ',' + | _ -> assert false in + try + split (Sys.getenv "CAML_LD_LIBRARY_PATH") path_separator + with Not_found -> + [] + +let split_dll_path path = + split path '\000' + +(* Initialization for separate compilation *) + +let init_compile nostdlib = + search_path := + ld_library_path_contents() @ + (if nostdlib then [] else ld_conf_contents()) + +(* Initialization for linking in core (dynlink or toplevel) *) + +let init_toplevel dllpath = + search_path := + ld_library_path_contents() @ + split_dll_path dllpath @ + ld_conf_contents(); + opened_dlls := Array.to_list (get_current_dlls()); + names_of_opened_dlls := []; + linking_in_core := true + diff --git a/bytecomp/dll.mli b/bytecomp/dll.mli new file mode 100644 index 00000000..389e1fab --- /dev/null +++ b/bytecomp/dll.mli @@ -0,0 +1,55 @@ +(***********************************************************************) +(* *) +(* 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 Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: dll.mli,v 1.5 2002/07/02 16:13:12 weis Exp $ *) + +(* Handling of dynamically-linked libraries *) + +(* Extract the name of a DLLs from its external name (xxx.so or -lxxx) *) +val extract_dll_name: string -> string + +(* Open a list of DLLs, adding them to opened_dlls. + Raise [Failure msg] in case of error. *) +val open_dlls: string list -> unit + +(* Close all DLLs *) +val close_all_dlls: unit -> unit + +(* The abstract type representing C function pointers *) +type dll_address + +(* Find a primitive in the currently opened DLLs and return its address. + Raise [Not_found] if not found. *) +val find_primitive: string -> dll_address + +(* If linking in core (dynlink or toplevel), synchronize the VM + table of primitive with the linker's table of primitive + by storing the given primitive function at the given position + in the VM table of primitives. *) +val synchronize_primitive: int -> dll_address -> unit + +(* Add the given directories at the head of the search path for DLLs *) +val add_path: string list -> unit + +(* Initialization for separate compilation. + Initialize the DLL search path to the directories given in the + environment variable CAML_LD_LIBRARY_PATH, plus contents of ld.conf file + if argument is [false]. If argument is [true], ignore ld.conf. *) +val init_compile: bool -> unit + +(* Initialization for linking in core (dynlink or toplevel). + Initialize the search path to the same path that was used to start + the running program (CAML_LD_LIBRARY_PATH + directories in executable + + contents of ld.conf file). Take note of the DLLs that were opened + when starting the running program. *) +val init_toplevel: string -> unit + diff --git a/bytecomp/emitcode.ml b/bytecomp/emitcode.ml new file mode 100644 index 00000000..05f15285 --- /dev/null +++ b/bytecomp/emitcode.ml @@ -0,0 +1,437 @@ +(***********************************************************************) +(* *) +(* 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: emitcode.ml,v 1.31 2003/03/06 15:59:54 xleroy Exp $ *) + +(* Generation of bytecode + relocation information *) + +open Config +open Misc +open Asttypes +open Lambda +open Instruct +open Opcodes + + +(* Relocation information *) + +type reloc_info = + Reloc_literal of structured_constant (* structured constant *) + | Reloc_getglobal of Ident.t (* reference to a global *) + | Reloc_setglobal of Ident.t (* definition of a global *) + | Reloc_primitive of string (* C primitive number *) + +(* Descriptor for compilation units *) + +type compilation_unit = + { cu_name: string; (* Name of compilation unit *) + mutable cu_pos: int; (* Absolute position in file *) + cu_codesize: int; (* Size of code block *) + cu_reloc: (reloc_info * int) list; (* Relocation information *) + cu_imports: (string * Digest.t) list; (* Names and CRC of intfs imported *) + cu_primitives: string list; (* Primitives declared inside *) + mutable cu_force_link: bool; (* Must be linked even if unref'ed *) + mutable cu_debug: int; (* Position of debugging info, or 0 *) + cu_debugsize: int } (* Length of debugging info *) + +(* Descriptor for libraries *) + +type library = + { lib_units: compilation_unit list; (* List of compilation units *) + lib_custom: bool; (* Requires custom mode linking? *) + lib_ccobjs: string list; (* C object files needed for -custom *) + lib_ccopts: string list; (* Extra opts to C compiler *) + lib_dllibs: string list } (* DLLs needed *) + +(* Buffering of bytecode *) + +let out_buffer = ref(String.create 1024) +and out_position = ref 0 + +let out_word b1 b2 b3 b4 = + let p = !out_position in + if p >= String.length !out_buffer then begin + let len = String.length !out_buffer in + let new_buffer = String.create (2 * len) in + String.blit !out_buffer 0 new_buffer 0 len; + out_buffer := new_buffer + end; + String.unsafe_set !out_buffer p (Char.unsafe_chr b1); + String.unsafe_set !out_buffer (p+1) (Char.unsafe_chr b2); + String.unsafe_set !out_buffer (p+2) (Char.unsafe_chr b3); + String.unsafe_set !out_buffer (p+3) (Char.unsafe_chr b4); + out_position := p + 4 + +let out opcode = + out_word opcode 0 0 0 + + +exception AsInt + +let const_as_int = function + | Const_base(Const_int i) -> i + | Const_base(Const_char c) -> Char.code c + | Const_pointer i -> i + | _ -> raise AsInt + +let is_immed i = immed_min <= i && i <= immed_max +let is_immed_const k = + try + is_immed (const_as_int k) + with + | AsInt -> false + + +let out_int n = + out_word n (n asr 8) (n asr 16) (n asr 24) + +let out_const c = + try + out_int (const_as_int c) + with + | AsInt -> Misc.fatal_error "Emitcode.const_as_int" + + +(* Handling of local labels and backpatching *) + +type label_definition = + Label_defined of int + | Label_undefined of (int * int) list + +let label_table = ref ([| |] : label_definition array) + +let extend_label_table needed = + let new_size = ref(Array.length !label_table) in + while needed >= !new_size do new_size := 2 * !new_size done; + let new_table = Array.create !new_size (Label_undefined []) in + Array.blit !label_table 0 new_table 0 (Array.length !label_table); + label_table := new_table + +let backpatch (pos, orig) = + let displ = (!out_position - orig) asr 2 in + !out_buffer.[pos] <- Char.unsafe_chr displ; + !out_buffer.[pos+1] <- Char.unsafe_chr (displ asr 8); + !out_buffer.[pos+2] <- Char.unsafe_chr (displ asr 16); + !out_buffer.[pos+3] <- Char.unsafe_chr (displ asr 24) + +let define_label lbl = + if lbl >= Array.length !label_table then extend_label_table lbl; + match (!label_table).(lbl) with + Label_defined _ -> + fatal_error "Emitcode.define_label" + | Label_undefined patchlist -> + List.iter backpatch patchlist; + (!label_table).(lbl) <- Label_defined !out_position + +let out_label_with_orig orig lbl = + if lbl >= Array.length !label_table then extend_label_table lbl; + match (!label_table).(lbl) with + Label_defined def -> + out_int((def - orig) asr 2) + | Label_undefined patchlist -> + (!label_table).(lbl) <- + Label_undefined((!out_position, orig) :: patchlist); + out_int 0 + +let out_label l = out_label_with_orig !out_position l + +(* Relocation information *) + +let reloc_info = ref ([] : (reloc_info * int) list) + +let enter info = + reloc_info := (info, !out_position) :: !reloc_info + +let slot_for_literal sc = + enter (Reloc_literal sc); + out_int 0 +and slot_for_getglobal id = + enter (Reloc_getglobal id); + out_int 0 +and slot_for_setglobal id = + enter (Reloc_setglobal id); + out_int 0 +and slot_for_c_prim name = + enter (Reloc_primitive name); + out_int 0 + +(* Debugging events *) + +let events = ref ([] : debug_event list) + +let record_event ev = + ev.ev_pos <- !out_position; + events := ev :: !events + +(* Initialization *) + +let init () = + out_position := 0; + label_table := Array.create 16 (Label_undefined []); + reloc_info := []; + events := [] + +(* Emission of one instruction *) + +let emit_comp = function +| Ceq -> out opEQ | Cneq -> out opNEQ +| Clt -> out opLTINT | Cle -> out opLEINT +| Cgt -> out opGTINT | Cge -> out opGEINT + +and emit_branch_comp = function +| Ceq -> out opBEQ | Cneq -> out opBNEQ +| Clt -> out opBLTINT | Cle -> out opBLEINT +| Cgt -> out opBGTINT | Cge -> out opBGEINT + +let emit_instr = function + Klabel lbl -> define_label lbl + | Kacc n -> + if n < 8 then out(opACC0 + n) else (out opACC; out_int n) + | Kenvacc n -> + if n >= 1 && n <= 4 + then out(opENVACC1 + n - 1) + else (out opENVACC; out_int n) + | Kpush -> + out opPUSH + | Kpop n -> + out opPOP; out_int n + | Kassign n -> + out opASSIGN; out_int n + | Kpush_retaddr lbl -> out opPUSH_RETADDR; out_label lbl + | Kapply n -> + if n < 4 then out(opAPPLY1 + n - 1) else (out opAPPLY; out_int n) + | Kappterm(n, sz) -> + if n < 4 then (out(opAPPTERM1 + n - 1); out_int sz) + else (out opAPPTERM; out_int n; out_int sz) + | Kreturn n -> out opRETURN; out_int n + | Krestart -> out opRESTART + | Kgrab n -> out opGRAB; out_int n + | Kclosure(lbl, n) -> out opCLOSURE; out_int n; out_label lbl + | Kclosurerec(lbls, n) -> + out opCLOSUREREC; out_int (List.length lbls); out_int n; + let org = !out_position in + List.iter (out_label_with_orig org) lbls + | Koffsetclosure ofs -> + if ofs = -2 || ofs = 0 || ofs = 2 + then out (opOFFSETCLOSURE0 + ofs / 2) + else (out opOFFSETCLOSURE; out_int ofs) + | Kgetglobal q -> out opGETGLOBAL; slot_for_getglobal q + | Ksetglobal q -> out opSETGLOBAL; slot_for_setglobal q + | Kconst sc -> + begin match sc with + Const_base(Const_int i) when is_immed i -> + if i >= 0 && i <= 3 + then out (opCONST0 + i) + else (out opCONSTINT; out_int i) + | Const_base(Const_char c) -> + out opCONSTINT; out_int (Char.code c) + | Const_pointer i -> + if i >= 0 && i <= 3 + then out (opCONST0 + i) + else (out opCONSTINT; out_int i) + | Const_block(t, []) -> + if t = 0 then out opATOM0 else (out opATOM; out_int t) + | _ -> + out opGETGLOBAL; slot_for_literal sc + end + | Kmakeblock(n, t) -> + if n = 0 then + if t = 0 then out opATOM0 else (out opATOM; out_int t) + else if n < 4 then (out(opMAKEBLOCK1 + n - 1); out_int t) + else (out opMAKEBLOCK; out_int n; out_int t) + | Kgetfield n -> + if n < 4 then out(opGETFIELD0 + n) else (out opGETFIELD; out_int n) + | Ksetfield n -> + if n < 4 then out(opSETFIELD0 + n) else (out opSETFIELD; out_int n) + | Kmakefloatblock(n) -> + if n = 0 then out opATOM0 else (out opMAKEFLOATBLOCK; out_int n) + | Kgetfloatfield n -> out opGETFLOATFIELD; out_int n + | Ksetfloatfield n -> out opSETFLOATFIELD; out_int n + | Kvectlength -> out opVECTLENGTH + | Kgetvectitem -> out opGETVECTITEM + | Ksetvectitem -> out opSETVECTITEM + | Kgetstringchar -> out opGETSTRINGCHAR + | Ksetstringchar -> out opSETSTRINGCHAR + | Kbranch lbl -> out opBRANCH; out_label lbl + | Kbranchif lbl -> out opBRANCHIF; out_label lbl + | Kbranchifnot lbl -> out opBRANCHIFNOT; out_label lbl + | Kstrictbranchif lbl -> out opBRANCHIF; out_label lbl + | Kstrictbranchifnot lbl -> out opBRANCHIFNOT; out_label lbl + | Kswitch(tbl_const, tbl_block) -> + out opSWITCH; + out_int (Array.length tbl_const + (Array.length tbl_block lsl 16)); + let org = !out_position in + Array.iter (out_label_with_orig org) tbl_const; + Array.iter (out_label_with_orig org) tbl_block + | Kboolnot -> out opBOOLNOT + | Kpushtrap lbl -> out opPUSHTRAP; out_label lbl + | Kpoptrap -> out opPOPTRAP + | Kraise -> out opRAISE + | Kcheck_signals -> out opCHECK_SIGNALS + | Kccall(name, n) -> + if n <= 5 + then (out (opC_CALL1 + n - 1); slot_for_c_prim name) + else (out opC_CALLN; out_int n; slot_for_c_prim name) + | Knegint -> out opNEGINT | Kaddint -> out opADDINT + | Ksubint -> out opSUBINT | Kmulint -> out opMULINT + | Kdivint -> out opDIVINT | Kmodint -> out opMODINT + | Kandint -> out opANDINT | Korint -> out opORINT + | Kxorint -> out opXORINT | Klslint -> out opLSLINT + | Klsrint -> out opLSRINT | Kasrint -> out opASRINT + | Kintcomp c -> emit_comp c + | Koffsetint n -> out opOFFSETINT; out_int n + | Koffsetref n -> out opOFFSETREF; out_int n + | Kisint -> out opISINT + | Kisout -> out opULTINT + | Kgetmethod -> out opGETMETHOD + | Kevent ev -> record_event ev + | Kstop -> out opSTOP + +(* Emission of a list of instructions. Include some peephole optimization. *) + +let rec emit = function + [] -> () + (* Peephole optimizations *) +(* optimization of integer tests *) + | Kpush::Kconst k::Kintcomp c::Kbranchif lbl::rem + when is_immed_const k -> + emit_branch_comp c ; + out_const k ; + out_label lbl ; + emit rem + | Kpush::Kconst k::Kintcomp c::Kbranchifnot lbl::rem + when is_immed_const k -> + emit_branch_comp (negate_comparison c) ; + out_const k ; + out_label lbl ; + emit rem +(* same for range tests *) + | Kpush::Kconst k::Kisout::Kbranchif lbl::rem + when is_immed_const k -> + out opBULTINT ; + out_const k ; + out_label lbl ; + emit rem + | Kpush::Kconst k::Kisout::Kbranchifnot lbl::rem + when is_immed_const k -> + out opBUGEINT ; + out_const k ; + out_label lbl ; + emit rem +(* Some special case of push ; i ; ret generated by the match compiler *) + | Kpush :: Kacc 0 :: Kreturn m :: c -> + emit (Kreturn (m-1) :: c) +(* General push then access scheme *) + | Kpush :: Kacc n :: c -> + if n < 8 then out(opPUSHACC0 + n) else (out opPUSHACC; out_int n); + emit c + | Kpush :: Kenvacc n :: c -> + if n >= 1 && n < 4 + then out(opPUSHENVACC1 + n - 1) + else (out opPUSHENVACC; out_int n); + emit c + | Kpush :: Koffsetclosure ofs :: c -> + if ofs = -2 || ofs = 0 || ofs = 2 + then out(opPUSHOFFSETCLOSURE0 + ofs / 2) + else (out opPUSHOFFSETCLOSURE; out_int ofs); + emit c + | Kpush :: Kgetglobal id :: Kgetfield n :: c -> + out opPUSHGETGLOBALFIELD; slot_for_getglobal id; out_int n; emit c + | Kpush :: Kgetglobal id :: c -> + out opPUSHGETGLOBAL; slot_for_getglobal id; emit c + | Kpush :: Kconst sc :: c -> + begin match sc with + Const_base(Const_int i) when is_immed i -> + if i >= 0 && i <= 3 + then out (opPUSHCONST0 + i) + else (out opPUSHCONSTINT; out_int i) + | Const_base(Const_char c) -> + out opPUSHCONSTINT; out_int(Char.code c) + | Const_pointer i -> + if i >= 0 && i <= 3 + then out (opPUSHCONST0 + i) + else (out opPUSHCONSTINT; out_int i) + | Const_block(t, []) -> + if t = 0 then out opPUSHATOM0 else (out opPUSHATOM; out_int t) + | _ -> + out opPUSHGETGLOBAL; slot_for_literal sc + end; + emit c + | Kpush :: (Kevent {ev_kind = Event_before} as ev) :: + (Kgetglobal _ as instr1) :: (Kgetfield _ as instr2) :: c -> + emit (Kpush :: instr1 :: instr2 :: ev :: c) + | Kpush :: (Kevent {ev_kind = Event_before} as ev) :: + (Kacc _ | Kenvacc _ | Koffsetclosure _ | Kgetglobal _ | Kconst _ as instr) :: c -> + emit (Kpush :: instr :: ev :: c) + | Kgetglobal id :: Kgetfield n :: c -> + out opGETGLOBALFIELD; slot_for_getglobal id; out_int n; emit c + (* Default case *) + | instr :: c -> + emit_instr instr; emit c + +(* Emission to a file *) + +let to_file outchan unit_name code = + init(); + output_string outchan cmo_magic_number; + let pos_depl = pos_out outchan in + output_binary_int outchan 0; + let pos_code = pos_out outchan in + emit code; + output outchan !out_buffer 0 !out_position; + let (pos_debug, size_debug) = + if !Clflags.debug then begin + let p = pos_out outchan in + output_value outchan !events; + (p, pos_out outchan - p) + end else + (0, 0) in + let compunit = + { cu_name = unit_name; + cu_pos = pos_code; + cu_codesize = !out_position; + cu_reloc = List.rev !reloc_info; + cu_imports = Env.imported_units(); + cu_primitives = !Translmod.primitive_declarations; + cu_force_link = false; + cu_debug = pos_debug; + cu_debugsize = size_debug } in + init(); (* Free out_buffer and reloc_info *) + Btype.cleanup_abbrev (); (* Remove any cached abbreviation + expansion before saving *) + let pos_compunit = pos_out outchan in + output_value outchan compunit; + seek_out outchan pos_depl; + output_binary_int outchan pos_compunit + +(* Emission to a memory block *) + +let to_memory init_code fun_code = + init(); + emit init_code; + emit fun_code; + let code = Meta.static_alloc !out_position in + String.unsafe_blit !out_buffer 0 code 0 !out_position; + let reloc = List.rev !reloc_info + and code_size = !out_position in + init(); + (code, code_size, reloc) + +(* Emission to a file for a packed library *) + +let to_packed_file outchan code = + init(); + emit code; + output outchan !out_buffer 0 !out_position; + let reloc = !reloc_info in + init(); + reloc diff --git a/bytecomp/emitcode.mli b/bytecomp/emitcode.mli new file mode 100644 index 00000000..72dcea4c --- /dev/null +++ b/bytecomp/emitcode.mli @@ -0,0 +1,85 @@ +(***********************************************************************) +(* *) +(* 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: emitcode.mli,v 1.14 2003/03/06 15:59:54 xleroy Exp $ *) + +(* Generation of bytecode for .cmo files *) + +open Lambda +open Instruct + +(* Relocation information *) + +type reloc_info = + Reloc_literal of structured_constant (* structured constant *) + | Reloc_getglobal of Ident.t (* reference to a global *) + | Reloc_setglobal of Ident.t (* definition of a global *) + | Reloc_primitive of string (* C primitive number *) + +(* Descriptor for compilation units *) + +type compilation_unit = + { cu_name: string; (* Name of compilation unit *) + mutable cu_pos: int; (* Absolute position in file *) + cu_codesize: int; (* Size of code block *) + cu_reloc: (reloc_info * int) list; (* Relocation information *) + cu_imports: (string * Digest.t) list; (* Names and CRC of intfs imported *) + cu_primitives: string list; (* Primitives declared inside *) + mutable cu_force_link: bool; (* Must be linked even if unref'ed *) + mutable cu_debug: int; (* Position of debugging info, or 0 *) + cu_debugsize: int } (* Length of debugging info *) + +(* Format of a .cmo file: + magic number (Config.cmo_magic_number) + absolute offset of compilation unit descriptor + block of relocatable bytecode + debugging information if any + compilation unit descriptor *) + +(* Descriptor for libraries *) + +type library = + { lib_units: compilation_unit list; (* List of compilation units *) + lib_custom: bool; (* Requires custom mode linking? *) + lib_ccobjs: string list; (* C object files needed for -custom *) + lib_ccopts: string list; (* Extra opts to C compiler *) + lib_dllibs: string list } (* DLLs needed *) + +(* Format of a .cma file: + magic number (Config.cma_magic_number) + absolute offset of library descriptor + object code for first library member + ... + object code for last library member + library descriptor *) + +val to_file: out_channel -> string -> instruction list -> unit + (* Arguments: + channel on output file + name of compilation unit implemented + list of instructions to emit *) +val to_memory: instruction list -> instruction list -> + string * int * (reloc_info * int) list + (* Arguments: + initialization code (terminated by STOP) + function code + Results: + block of relocatable bytecode + size of this block + relocation information *) +val to_packed_file: + out_channel -> instruction list -> (reloc_info * int) list + (* Arguments: + channel on output file + list of instructions to emit + Result: + relocation information (reversed) *) diff --git a/bytecomp/instruct.ml b/bytecomp/instruct.ml new file mode 100644 index 00000000..02c9747f --- /dev/null +++ b/bytecomp/instruct.ml @@ -0,0 +1,108 @@ +(***********************************************************************) +(* *) +(* 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: instruct.ml,v 1.20 2002/11/02 22:36:41 doligez Exp $ *) + +open Lambda + +type compilation_env = + { ce_stack: int Ident.tbl; + ce_heap: int Ident.tbl; + ce_rec: int Ident.tbl } + +type debug_event = + { mutable ev_pos: int; (* Position in bytecode *) + ev_module: string; (* Name of defining module *) + ev_char: Lexing.position; (* Position in source file *) + ev_kind: debug_event_kind; (* Before/after event *) + ev_info: debug_event_info; (* Extra information *) + ev_typenv: Env.summary; (* Typing environment *) + ev_compenv: compilation_env; (* Compilation environment *) + ev_stacksize: int; (* Size of stack frame *) + ev_repr: debug_event_repr } (* Position of the representative *) + +and debug_event_kind = + Event_before + | Event_after of Types.type_expr + | Event_pseudo + +and debug_event_info = + Event_function + | Event_return of int + | Event_other + +and debug_event_repr = + Event_none + | Event_parent of int ref + | Event_child of int ref + +type label = int (* Symbolic code labels *) + +type instruction = + Klabel of label + | Kacc of int + | Kenvacc of int + | Kpush + | Kpop of int + | Kassign of int + | Kpush_retaddr of label + | Kapply of int (* number of arguments *) + | Kappterm of int * int (* number of arguments, slot size *) + | Kreturn of int (* slot size *) + | Krestart + | Kgrab of int (* number of arguments *) + | Kclosure of label * int + | Kclosurerec of label list * int + | Koffsetclosure of int + | Kgetglobal of Ident.t + | Ksetglobal of Ident.t + | Kconst of structured_constant + | Kmakeblock of int * int (* size, tag *) + | Kmakefloatblock of int + | Kgetfield of int + | Ksetfield of int + | Kgetfloatfield of int + | Ksetfloatfield of int + | Kvectlength + | Kgetvectitem + | Ksetvectitem + | Kgetstringchar + | Ksetstringchar + | Kbranch of label + | Kbranchif of label + | Kbranchifnot of label + | Kstrictbranchif of label + | Kstrictbranchifnot of label + | Kswitch of label array * label array + | Kboolnot + | Kpushtrap of label + | Kpoptrap + | Kraise + | Kcheck_signals + | Kccall of string * int + | Knegint | Kaddint | Ksubint | Kmulint | Kdivint | Kmodint + | Kandint | Korint | Kxorint | Klslint | Klsrint | Kasrint + | Kintcomp of comparison + | Koffsetint of int + | Koffsetref of int + | Kisint + | Kisout + | Kgetmethod + | Kevent of debug_event + | Kstop + +let immed_min = -0x40000000 +and immed_max = 0x3FFFFFFF + +(* Actually the abstract machine accomodates -0x80000000 to 0x7FFFFFFF, + but these numbers overflow the Caml type int if the compiler runs on + a 32-bit processor. *) diff --git a/bytecomp/instruct.mli b/bytecomp/instruct.mli new file mode 100644 index 00000000..01669530 --- /dev/null +++ b/bytecomp/instruct.mli @@ -0,0 +1,123 @@ +(***********************************************************************) +(* *) +(* 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: instruct.mli,v 1.19 2002/11/02 22:36:41 doligez Exp $ *) + +(* The type of the instructions of the abstract machine *) + +open Lambda + +(* Structure of compilation environments *) + +type compilation_env = + { ce_stack: int Ident.tbl; (* Positions of variables in the stack *) + ce_heap: int Ident.tbl; (* Structure of the heap-allocated env *) + ce_rec: int Ident.tbl } (* Functions bound by the same let rec *) + +(* The ce_stack component gives locations of variables residing + in the stack. The locations are offsets w.r.t. the origin of the + stack frame. + The ce_heap component gives the positions of variables residing in the + heap-allocated environment. + The ce_rec component associate offsets to identifiers for functions + bound by the same let rec as the current function. The offsets + are used by the OFFSETCLOSURE instruction to recover the closure + pointer of the desired function from the env register (which + points to the closure for the current function). *) + +(* Debugging events *) + +type debug_event = + { mutable ev_pos: int; (* Position in bytecode *) + ev_module: string; (* Name of defining module *) + ev_char: Lexing.position; (* Position in source file *) + ev_kind: debug_event_kind; (* Before/after event *) + ev_info: debug_event_info; (* Extra information *) + ev_typenv: Env.summary; (* Typing environment *) + ev_compenv: compilation_env; (* Compilation environment *) + ev_stacksize: int; (* Size of stack frame *) + ev_repr: debug_event_repr } (* Position of the representative *) + +and debug_event_kind = + Event_before + | Event_after of Types.type_expr + | Event_pseudo + +and debug_event_info = + Event_function + | Event_return of int + | Event_other + +and debug_event_repr = + Event_none + | Event_parent of int ref + | Event_child of int ref + +(* Abstract machine instructions *) + +type label = int (* Symbolic code labels *) + +type instruction = + Klabel of label + | Kacc of int + | Kenvacc of int + | Kpush + | Kpop of int + | Kassign of int + | Kpush_retaddr of label + | Kapply of int (* number of arguments *) + | Kappterm of int * int (* number of arguments, slot size *) + | Kreturn of int (* slot size *) + | Krestart + | Kgrab of int (* number of arguments *) + | Kclosure of label * int + | Kclosurerec of label list * int + | Koffsetclosure of int + | Kgetglobal of Ident.t + | Ksetglobal of Ident.t + | Kconst of structured_constant + | Kmakeblock of int * int (* size, tag *) + | Kmakefloatblock of int + | Kgetfield of int + | Ksetfield of int + | Kgetfloatfield of int + | Ksetfloatfield of int + | Kvectlength + | Kgetvectitem + | Ksetvectitem + | Kgetstringchar + | Ksetstringchar + | Kbranch of label + | Kbranchif of label + | Kbranchifnot of label + | Kstrictbranchif of label + | Kstrictbranchifnot of label + | Kswitch of label array * label array + | Kboolnot + | Kpushtrap of label + | Kpoptrap + | Kraise + | Kcheck_signals + | Kccall of string * int + | Knegint | Kaddint | Ksubint | Kmulint | Kdivint | Kmodint + | Kandint | Korint | Kxorint | Klslint | Klsrint | Kasrint + | Kintcomp of comparison + | Koffsetint of int + | Koffsetref of int + | Kisint + | Kisout + | Kgetmethod + | Kevent of debug_event + | Kstop + +val immed_min: int +val immed_max: int diff --git a/bytecomp/lambda.ml b/bytecomp/lambda.ml new file mode 100644 index 00000000..fbb7a209 --- /dev/null +++ b/bytecomp/lambda.ml @@ -0,0 +1,337 @@ +(***********************************************************************) +(* *) +(* 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: lambda.ml,v 1.39 2002/11/01 17:06:41 doligez Exp $ *) + +open Misc +open Path +open Asttypes + +type primitive = + Pidentity + | Pignore + (* Globals *) + | Pgetglobal of Ident.t + | Psetglobal of Ident.t + (* Operations on heap blocks *) + | Pmakeblock of int * mutable_flag + | Pfield of int + | Psetfield of int * bool + | Pfloatfield of int + | Psetfloatfield of int + (* External call *) + | Pccall of Primitive.description + (* Exceptions *) + | Praise + (* Boolean operations *) + | Psequand | Psequor | Pnot + (* Integer operations *) + | Pnegint | Paddint | Psubint | Pmulint | Pdivint | Pmodint + | Pandint | Porint | Pxorint + | Plslint | Plsrint | Pasrint + | Pintcomp of comparison + | Poffsetint of int + | Poffsetref of int + (* Float operations *) + | Pintoffloat | Pfloatofint + | Pnegfloat | Pabsfloat + | Paddfloat | Psubfloat | Pmulfloat | Pdivfloat + | Pfloatcomp of comparison + (* String operations *) + | Pstringlength | Pstringrefu | Pstringsetu | Pstringrefs | Pstringsets + (* Array operations *) + | Pmakearray of array_kind + | Parraylength of array_kind + | Parrayrefu of array_kind + | Parraysetu of array_kind + | Parrayrefs of array_kind + | Parraysets of array_kind + (* Test if the argument is a block or an immediate integer *) + | Pisint + (* Test if the (integer) argument is outside an interval *) + | Pisout + (* Bitvect operations *) + | Pbittest + (* Operations on boxed integers (Nativeint.t, Int32.t, Int64.t) *) + | Pbintofint of boxed_integer + | Pintofbint of boxed_integer + | Pcvtbint of boxed_integer (*source*) * boxed_integer (*destination*) + | Pnegbint of boxed_integer + | Paddbint of boxed_integer + | Psubbint of boxed_integer + | Pmulbint of boxed_integer + | Pdivbint of boxed_integer + | Pmodbint of boxed_integer + | Pandbint of boxed_integer + | Porbint of boxed_integer + | Pxorbint of boxed_integer + | Plslbint of boxed_integer + | Plsrbint of boxed_integer + | Pasrbint of boxed_integer + | Pbintcomp of boxed_integer * comparison + (* Operations on big arrays *) + | Pbigarrayref of int * bigarray_kind * bigarray_layout + | Pbigarrayset of int * bigarray_kind * bigarray_layout + +and comparison = + Ceq | Cneq | Clt | Cgt | Cle | Cge + +and array_kind = + Pgenarray | Paddrarray | Pintarray | Pfloatarray + +and boxed_integer = + Pnativeint | Pint32 | Pint64 + +and bigarray_kind = + Pbigarray_unknown + | Pbigarray_float32 | Pbigarray_float64 + | Pbigarray_sint8 | Pbigarray_uint8 + | Pbigarray_sint16 | Pbigarray_uint16 + | Pbigarray_int32 | Pbigarray_int64 + | Pbigarray_caml_int | Pbigarray_native_int + | Pbigarray_complex32 | Pbigarray_complex64 + +and bigarray_layout = + Pbigarray_unknown_layout + | Pbigarray_c_layout + | Pbigarray_fortran_layout + +type structured_constant = + Const_base of constant + | Const_pointer of int + | Const_block of int * structured_constant list + | Const_float_array of string list + +type function_kind = Curried | Tupled + +type let_kind = Strict | Alias | StrictOpt | Variable + +type shared_code = (int * int) list + +type lambda = + Lvar of Ident.t + | Lconst of structured_constant + | Lapply of lambda * lambda list + | Lfunction of function_kind * Ident.t list * lambda + | Llet of let_kind * Ident.t * lambda * lambda + | Lletrec of (Ident.t * lambda) list * lambda + | Lprim of primitive * lambda list + | Lswitch of lambda * lambda_switch + | Lstaticraise of int * lambda list + | Lstaticcatch of lambda * (int * Ident.t list) * lambda + | Ltrywith of lambda * Ident.t * lambda + | Lifthenelse of lambda * lambda * lambda + | Lsequence of lambda * lambda + | Lwhile of lambda * lambda + | Lfor of Ident.t * lambda * lambda * direction_flag * lambda + | Lassign of Ident.t * lambda + | Lsend of lambda * lambda * lambda list + | Levent of lambda * lambda_event + | Lifused of Ident.t * lambda + +and lambda_switch = + { sw_numconsts: int; + sw_consts: (int * lambda) list; + sw_numblocks: int; + sw_blocks: (int * lambda) list; + sw_failaction : lambda option} + +and lambda_event = + { lev_pos: Lexing.position; + lev_kind: lambda_event_kind; + lev_repr: int ref option; + lev_env: Env.summary } + +and lambda_event_kind = + Lev_before + | Lev_after of Types.type_expr + | Lev_function + +let const_unit = Const_pointer 0 + +let lambda_unit = Lconst const_unit + +let name_lambda arg fn = + match arg with + Lvar id -> fn id + | _ -> let id = Ident.create "let" in Llet(Strict, id, arg, fn id) + +let name_lambda_list args fn = + let rec name_list names = function + [] -> fn (List.rev names) + | (Lvar id as arg) :: rem -> + name_list (arg :: names) rem + | arg :: rem -> + let id = Ident.create "let" in + Llet(Strict, id, arg, name_list (Lvar id :: names) rem) in + name_list [] args + +module IdentSet = + Set.Make(struct + type t = Ident.t + let compare = compare + end) + +let free_variables l = + let fv = ref IdentSet.empty in + let rec freevars = function + Lvar id -> + fv := IdentSet.add id !fv + | Lconst sc -> () + | Lapply(fn, args) -> + freevars fn; List.iter freevars args + | Lfunction(kind, params, body) -> + freevars body; + List.iter (fun param -> fv := IdentSet.remove param !fv) params + | Llet(str, id, arg, body) -> + freevars arg; freevars body; fv := IdentSet.remove id !fv + | Lletrec(decl, body) -> + freevars body; + List.iter (fun (id, exp) -> freevars exp) decl; + List.iter (fun (id, exp) -> fv := IdentSet.remove id !fv) decl + | Lprim(p, args) -> + List.iter freevars args + | Lswitch(arg, sw) -> + freevars arg; + List.iter (fun (key, case) -> freevars case) sw.sw_consts; + List.iter (fun (key, case) -> freevars case) sw.sw_blocks; + begin match sw.sw_failaction with + | None -> () + | Some l -> freevars l + end + | Lstaticraise (_,args) -> + List.iter freevars args + | Lstaticcatch(e1, (_,vars), e2) -> + freevars e1; freevars e2 ; + List.iter (fun id -> fv := IdentSet.remove id !fv) vars + | Ltrywith(e1, exn, e2) -> + freevars e1; freevars e2; fv := IdentSet.remove exn !fv + | Lifthenelse(e1, e2, e3) -> + freevars e1; freevars e2; freevars e3 + | Lsequence(e1, e2) -> + freevars e1; freevars e2 + | Lwhile(e1, e2) -> + freevars e1; freevars e2 + | Lfor(v, e1, e2, dir, e3) -> + freevars e1; freevars e2; freevars e3; fv := IdentSet.remove v !fv + | Lassign(id, e) -> + fv := IdentSet.add id !fv; freevars e + | Lsend (met, obj, args) -> + List.iter freevars (met::obj::args) + | Levent (lam, evt) -> + freevars lam + | Lifused (v, e) -> + freevars e + in freevars l; !fv + +(* Check if an action has a "when" guard *) +let raise_count = ref 0 + +let next_raise_count () = + incr raise_count ; + !raise_count + +(* Anticipated staticraise, for guards *) +let staticfail = Lstaticraise (0,[]) + +let rec is_guarded = function + | Lifthenelse( cond, body, Lstaticraise (0,[])) -> true + | Llet(str, id, lam, body) -> is_guarded body + | Levent(lam, ev) -> is_guarded lam + | _ -> false + +let rec patch_guarded patch = function + | Lifthenelse (cond, body, Lstaticraise (0,[])) -> + Lifthenelse (cond, body, patch) + | Llet(str, id, lam, body) -> + Llet (str, id, lam, patch_guarded patch body) + | Levent(lam, ev) -> + Levent (patch_guarded patch lam, ev) + | _ -> fatal_error "Lambda.patch_guarded" + +(* Translate an access path *) + +let rec transl_path = function + Pident id -> + if Ident.global id then Lprim(Pgetglobal id, []) else Lvar id + | Pdot(p, s, pos) -> + Lprim(Pfield pos, [transl_path p]) + | Papply(p1, p2) -> + fatal_error "Lambda.transl_path" + +(* Compile a sequence of expressions *) + +let rec make_sequence fn = function + [] -> lambda_unit + | [x] -> fn x + | x::rem -> + let lam = fn x in Lsequence(lam, make_sequence fn rem) + +(* Apply a substitution to a lambda-term. + Assumes that the bound variables of the lambda-term do not + belong to the domain of the substitution. + Assumes that the image of the substitution is out of reach + of the bound variables of the lambda-term (no capture). *) + +let subst_lambda s lam = + let rec subst = function + Lvar id as l -> + begin try Ident.find_same id s with Not_found -> l end + | Lconst sc as l -> l + | Lapply(fn, args) -> Lapply(subst fn, List.map subst args) + | Lfunction(kind, params, body) -> Lfunction(kind, params, subst body) + | Llet(str, id, arg, body) -> Llet(str, id, subst arg, subst body) + | Lletrec(decl, body) -> Lletrec(List.map subst_decl decl, subst body) + | Lprim(p, args) -> Lprim(p, List.map subst args) + | Lswitch(arg, sw) -> + Lswitch(subst arg, + {sw with sw_consts = List.map subst_case sw.sw_consts; + sw_blocks = List.map subst_case sw.sw_blocks; + sw_failaction = + match sw.sw_failaction with + | None -> None + | Some l -> Some (subst l)}) + + | Lstaticraise (i,args) -> Lstaticraise (i, List.map subst args) + | Lstaticcatch(e1, io, e2) -> Lstaticcatch(subst e1, io, subst e2) + | Ltrywith(e1, exn, e2) -> Ltrywith(subst e1, exn, subst e2) + | Lifthenelse(e1, e2, e3) -> Lifthenelse(subst e1, subst e2, subst e3) + | Lsequence(e1, e2) -> Lsequence(subst e1, subst e2) + | Lwhile(e1, e2) -> Lwhile(subst e1, subst e2) + | Lfor(v, e1, e2, dir, e3) -> Lfor(v, subst e1, subst e2, dir, subst e3) + | Lassign(id, e) -> Lassign(id, subst e) + | Lsend (met, obj, args) -> Lsend (subst met, subst obj, List.map subst args) + | Levent (lam, evt) -> Levent (subst lam, evt) + | Lifused (v, e) -> Lifused (v, subst e) + and subst_decl (id, exp) = (id, subst exp) + and subst_case (key, case) = (key, subst case) + in subst lam + + +(* To let-bind expressions to variables *) + +let bind str var exp body = + match exp with + Lvar var' when Ident.same var var' -> body + | _ -> Llet(str, var, exp, body) + +and commute_comparison = function +| Ceq -> Ceq| Cneq -> Cneq +| Clt -> Cgt | Cle -> Cge +| Cgt -> Clt | Cge -> Cle + +and negate_comparison = function +| Ceq -> Cneq| Cneq -> Ceq +| Clt -> Cge | Cle -> Cgt +| Cgt -> Cle | Cge -> Clt + + diff --git a/bytecomp/lambda.mli b/bytecomp/lambda.mli new file mode 100644 index 00000000..376d1900 --- /dev/null +++ b/bytecomp/lambda.mli @@ -0,0 +1,199 @@ +(***********************************************************************) +(* *) +(* 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: lambda.mli,v 1.37 2002/11/01 17:06:41 doligez Exp $ *) + +(* The "lambda" intermediate code *) + +open Asttypes + +type primitive = + Pidentity + | Pignore + (* Globals *) + | Pgetglobal of Ident.t + | Psetglobal of Ident.t + (* Operations on heap blocks *) + | Pmakeblock of int * mutable_flag + | Pfield of int + | Psetfield of int * bool + | Pfloatfield of int + | Psetfloatfield of int + (* External call *) + | Pccall of Primitive.description + (* Exceptions *) + | Praise + (* Boolean operations *) + | Psequand | Psequor | Pnot + (* Integer operations *) + | Pnegint | Paddint | Psubint | Pmulint | Pdivint | Pmodint + | Pandint | Porint | Pxorint + | Plslint | Plsrint | Pasrint + | Pintcomp of comparison + | Poffsetint of int + | Poffsetref of int + (* Float operations *) + | Pintoffloat | Pfloatofint + | Pnegfloat | Pabsfloat + | Paddfloat | Psubfloat | Pmulfloat | Pdivfloat + | Pfloatcomp of comparison + (* String operations *) + | Pstringlength | Pstringrefu | Pstringsetu | Pstringrefs | Pstringsets + (* Array operations *) + | Pmakearray of array_kind + | Parraylength of array_kind + | Parrayrefu of array_kind + | Parraysetu of array_kind + | Parrayrefs of array_kind + | Parraysets of array_kind + (* Test if the argument is a block or an immediate integer *) + | Pisint + (* Test if the (integer) argument is outside an interval *) + | Pisout + (* Bitvect operations *) + | Pbittest + (* Operations on boxed integers (Nativeint.t, Int32.t, Int64.t) *) + | Pbintofint of boxed_integer + | Pintofbint of boxed_integer + | Pcvtbint of boxed_integer (*source*) * boxed_integer (*destination*) + | Pnegbint of boxed_integer + | Paddbint of boxed_integer + | Psubbint of boxed_integer + | Pmulbint of boxed_integer + | Pdivbint of boxed_integer + | Pmodbint of boxed_integer + | Pandbint of boxed_integer + | Porbint of boxed_integer + | Pxorbint of boxed_integer + | Plslbint of boxed_integer + | Plsrbint of boxed_integer + | Pasrbint of boxed_integer + | Pbintcomp of boxed_integer * comparison + (* Operations on big arrays *) + | Pbigarrayref of int * bigarray_kind * bigarray_layout + | Pbigarrayset of int * bigarray_kind * bigarray_layout + +and comparison = + Ceq | Cneq | Clt | Cgt | Cle | Cge + +and array_kind = + Pgenarray | Paddrarray | Pintarray | Pfloatarray + +and boxed_integer = + Pnativeint | Pint32 | Pint64 + +and bigarray_kind = + Pbigarray_unknown + | Pbigarray_float32 | Pbigarray_float64 + | Pbigarray_sint8 | Pbigarray_uint8 + | Pbigarray_sint16 | Pbigarray_uint16 + | Pbigarray_int32 | Pbigarray_int64 + | Pbigarray_caml_int | Pbigarray_native_int + | Pbigarray_complex32 | Pbigarray_complex64 + +and bigarray_layout = + Pbigarray_unknown_layout + | Pbigarray_c_layout + | Pbigarray_fortran_layout + +type structured_constant = + Const_base of constant + | Const_pointer of int + | Const_block of int * structured_constant list + | Const_float_array of string list + +type function_kind = Curried | Tupled + +type let_kind = Strict | Alias | StrictOpt | Variable +(* Meaning of kinds for let x = e in e': + Strict: e may have side-effets; always evaluate e first + (If e is a simple expression, e.g. a variable or constant, + we may still substitute e'[x/e].) + Alias: e is pure, we can substitute e'[x/e] if x has 0 or 1 occurrences + in e' + StrictOpt: e does not have side-effects, but depend on the store; + we can discard e if x does not appear in e' + Variable: the variable x is assigned later in e' *) + +type shared_code = (int * int) list (* stack size -> code label *) + +type lambda = + Lvar of Ident.t + | Lconst of structured_constant + | Lapply of lambda * lambda list + | Lfunction of function_kind * Ident.t list * lambda + | Llet of let_kind * Ident.t * lambda * lambda + | Lletrec of (Ident.t * lambda) list * lambda + | Lprim of primitive * lambda list + | Lswitch of lambda * lambda_switch + | Lstaticraise of int * lambda list + | Lstaticcatch of lambda * (int * Ident.t list) * lambda + | Ltrywith of lambda * Ident.t * lambda + | Lifthenelse of lambda * lambda * lambda + | Lsequence of lambda * lambda + | Lwhile of lambda * lambda + | Lfor of Ident.t * lambda * lambda * direction_flag * lambda + | Lassign of Ident.t * lambda + | Lsend of lambda * lambda * lambda list + | Levent of lambda * lambda_event + | Lifused of Ident.t * lambda + +and lambda_switch = + { sw_numconsts: int; (* Number of integer cases *) + sw_consts: (int * lambda) list; (* Integer cases *) + sw_numblocks: int; (* Number of tag block cases *) + sw_blocks: (int * lambda) list; (* Tag block cases *) + sw_failaction : lambda option} (* Action to take if failure *) +and lambda_event = + { lev_pos: Lexing.position; + lev_kind: lambda_event_kind; + lev_repr: int ref option; + lev_env: Env.summary } + +and lambda_event_kind = + Lev_before + | Lev_after of Types.type_expr + | Lev_function + +val const_unit: structured_constant +val lambda_unit: lambda +val name_lambda: lambda -> (Ident.t -> lambda) -> lambda +val name_lambda_list: lambda list -> (lambda list -> lambda) -> lambda +val is_guarded: lambda -> bool +val patch_guarded : lambda -> lambda -> lambda + +module IdentSet: Set.S with type elt = Ident.t +val free_variables: lambda -> IdentSet.t + +val transl_path: Path.t -> lambda +val make_sequence: ('a -> lambda) -> 'a list -> lambda + +val subst_lambda: lambda Ident.tbl -> lambda -> lambda +val bind : let_kind -> Ident.t -> lambda -> lambda -> lambda + +val commute_comparison : comparison -> comparison +val negate_comparison : comparison -> comparison + +(***********************) +(* For static failures *) +(***********************) + +(* Get a new static failure ident *) +val next_raise_count : unit -> int + + +val staticfail : lambda (* Anticipated static failure *) + +(* Check anticipated failure, substitute its final value *) +val is_guarded: lambda -> bool +val patch_guarded : lambda -> lambda -> lambda + diff --git a/bytecomp/matching.ml b/bytecomp/matching.ml new file mode 100644 index 00000000..c04da97c --- /dev/null +++ b/bytecomp/matching.ml @@ -0,0 +1,2547 @@ +(***********************************************************************) +(* *) +(* 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: matching.ml,v 1.58 2003/07/18 13:37:36 maranget Exp $ *) + +(* Compilation of pattern matching *) + +open Misc +open Asttypes +open Primitive +open Types +open Typedtree +open Lambda +open Parmatch +open Printf + +(* See Peyton-Jones, ``The Implementation of functional programming + languages'', chapter 5. *) +(* + Bon, au commencement du monde c'etait vrai. + Now, see Lefessant-Maranget ``Optimizing Pattern-Matching'' ICFP'2001 +*) + + +(* + Many functions on the various data structures ofthe algorithm : + - Pattern matrices. + - Default environments: mapping from matrices to exit numbers. + - Contexts: matrices whose column are partitioned into + left and right. + - Jump sumaries: mapping from exit numbers to contexts +*) + +type matrix = pattern list list + +let add_omega_column pss = List.map (fun ps -> omega::ps) pss + +type ctx = {left:pattern list ; right:pattern list} + +let pretty_ctx ctx = + List.iter + (fun {left=left ; right=right} -> + prerr_string "LEFT:" ; + pretty_line left ; + prerr_string " RIGHT:" ; + pretty_line right ; + prerr_endline "") + ctx + +let le_ctx c1 c2 = + le_pats c1.left c2.left && + le_pats c1.right c2.right + +let lshift {left=left ; right=right} = match right with +| x::xs -> {left=x::left ; right=xs} +| _ -> assert false + +let lforget {left=left ; right=right} = match right with +| x::xs -> {left=omega::left ; right=xs} +| _ -> assert false + +let rec small_enough n = function + | [] -> true + | _::rem -> + if n <= 0 then false + else small_enough (n-1) rem + +let ctx_lshift ctx = + if small_enough 31 ctx then + List.map lshift ctx + else (* Context pruning *) begin + get_mins le_ctx (List.map lforget ctx) + end + +let rshift {left=left ; right=right} = match left with +| p::ps -> {left=ps ; right=p::right} +| _ -> assert false + +let ctx_rshift ctx = List.map rshift ctx + +let rec nchars n ps = + if n <= 0 then [],ps + else match ps with + | p::rem -> + let chars, cdrs = nchars (n-1) rem in + p::chars,cdrs + | _ -> assert false + +let rshift_num n {left=left ; right=right} = + let shifted,left = nchars n left in + {left=left ; right = shifted@right} + +let ctx_rshift_num n ctx = List.map (rshift_num n) ctx + +let combine {left=left ; right=right} = match left with +| p::ps -> {left=ps ; right=set_args p right} +| _ -> assert false + +let ctx_combine ctx = List.map combine ctx + +let ncols = function + | [] -> 0 + | ps::_ -> List.length ps + + +exception NoMatch +exception OrPat + +let filter_matrix matcher pss = + + let rec filter_rec = function + | (p::ps)::rem -> + begin match p.pat_desc with + | Tpat_alias (p,_) -> + filter_rec ((p::ps)::rem) + | Tpat_var _ -> + filter_rec ((omega::ps)::rem) + | _ -> + begin + let rem = filter_rec rem in + try + matcher p ps::rem + with + | NoMatch -> rem + | OrPat -> + match p.pat_desc with + | Tpat_or (p1,p2,_) -> filter_rec [(p1::ps) ;(p2::ps)]@rem + | _ -> assert false + end + end + | [] -> [] + | _ -> + pretty_matrix pss ; + fatal_error "Matching.filter_matrix" in + filter_rec pss + +let make_default matcher env = + let rec make_rec = function + | [] -> [] + | ([[]],i)::_ -> [[[]],i] + | (pss,i)::rem -> + let rem = make_rec rem in + match filter_matrix matcher pss with + | [] -> rem + | ([]::_) -> ([[]],i)::rem + | pss -> (pss,i)::rem in + make_rec env + +let ctx_matcher p = + let p = normalize_pat p in + match p.pat_desc with + | Tpat_construct (cstr,omegas) -> + (fun q rem -> match q.pat_desc with + | Tpat_construct (cstr',args) when cstr.cstr_tag=cstr'.cstr_tag -> + p,args @ rem + | Tpat_any -> p,omegas @ rem + | _ -> raise NoMatch) + | Tpat_constant cst -> + (fun q rem -> match q.pat_desc with + | Tpat_constant cst' when cst=cst' -> + p,rem + | Tpat_any -> p,rem + | _ -> raise NoMatch) + | Tpat_variant (lab,Some omega,_) -> + (fun q rem -> match q.pat_desc with + | Tpat_variant (lab',Some arg,_) when lab=lab' -> + p,arg::rem + | Tpat_any -> p,omega::rem + | _ -> raise NoMatch) + | Tpat_variant (lab,None,_) -> + (fun q rem -> match q.pat_desc with + | Tpat_variant (lab',None,_) when lab=lab' -> + p,rem + | Tpat_any -> p,rem + | _ -> raise NoMatch) + | Tpat_array omegas -> + let len = List.length omegas in + (fun q rem -> match q.pat_desc with + | Tpat_array args when List.length args=len -> + p,args @ rem + | Tpat_any -> p, omegas @ rem + | _ -> raise NoMatch) + | Tpat_tuple omegas -> + (fun q rem -> match q.pat_desc with + | Tpat_tuple args -> p,args @ rem + | _ -> p, omegas @ rem) + | Tpat_record l -> (* Records are normalized *) + (fun q rem -> match q.pat_desc with + | Tpat_record l' -> + let l' = all_record_args l' in + p, List.fold_right (fun (_,p) r -> p::r) l' rem + | _ -> p,List.fold_right (fun (_,p) r -> p::r) l rem) + | _ -> fatal_error "Matching.ctx_matcher" + + + + +let filter_ctx q ctx = + + let matcher = ctx_matcher q in + + let rec filter_rec = function + | ({right=p::ps} as l)::rem -> + begin match p.pat_desc with + | Tpat_or (p1,p2,_) -> + filter_rec ({l with right=p1::ps}::{l with right=p2::ps}::rem) + | Tpat_alias (p,_) -> + filter_rec ({l with right=p::ps}::rem) + | Tpat_var _ -> + filter_rec ({l with right=omega::ps}::rem) + | _ -> + begin let rem = filter_rec rem in + try + let to_left, right = matcher p ps in + {left=to_left::l.left ; right=right}::rem + with + | NoMatch -> rem + end + end + | [] -> [] + | _ -> fatal_error "Matching.filter_ctx" in + + filter_rec ctx + +let select_columns pss ctx = + let n = ncols pss in + List.fold_right + (fun ps r -> + List.fold_right + (fun {left=left ; right=right} r -> + let transfert, right = nchars n right in + try + {left = lubs transfert ps @ left ; right=right}::r + with + | Empty -> r) + ctx r) + pss [] + +let ctx_lub p ctx = + List.fold_right + (fun {left=left ; right=right} r -> + match right with + | q::rem -> + begin try + {left=left ; right = lub p q::rem}::r + with + | Empty -> r + end + | _ -> fatal_error "Matching.ctx_lub") + ctx [] + +let ctx_match ctx pss = + List.exists + (fun {right=qs} -> + List.exists + (fun ps -> compats qs ps) + pss) + ctx + +type jumps = (int * ctx ) list + +let pretty_jumps env = match env with +| [] -> () +| _ -> + List.iter + (fun (i,ctx) -> + Printf.fprintf stderr "jump for %d\n" i ; + pretty_ctx ctx) + env + + +let rec jumps_extract i = function + | [] -> [],[] + | (j,pss) as x::rem as all -> + if i=j then pss,rem + else if j < i then [],all + else + let r,rem = jumps_extract i rem in + r,(x::rem) + +let rec jumps_remove i = function + | [] -> [] + | (j,_)::rem when i=j -> rem + | x::rem -> x::jumps_remove i rem + +let jumps_empty = [] +and jumps_is_empty = function + | [] -> true + | _ -> false + +let jumps_singleton i = function + | [] -> [] + | ctx -> [i,ctx] + +let jumps_add i pss jumps = match pss with +| [] -> jumps +| _ -> + let rec add = function + | [] -> [i,pss] + | (j,qss) as x::rem as all -> + if j > i then x::add rem + else if j < i then (i,pss)::all + else (i,(get_mins le_ctx (pss@qss)))::rem in + add jumps + + +let rec jumps_union env1 env2 = match env1,env2 with +| [],_ -> env2 +| _,[] -> env1 +| ((i1,pss1) as x1::rem1), ((i2,pss2) as x2::rem2) -> + if i1=i2 then + (i1,get_mins le_ctx (pss1@pss2))::jumps_union rem1 rem2 + else if i1 > i2 then + x1::jumps_union rem1 env2 + else + x2::jumps_union env1 rem2 + + +let rec merge = function + | env1::env2::rem -> jumps_union env1 env2::merge rem + | envs -> envs + +let rec jumps_unions envs = match envs with + | [] -> [] + | [env] -> env + | _ -> jumps_unions (merge envs) + +let rec jumps_map f env = + List.map + (fun (i,pss) -> i,f pss) + env + +(* Pattern matching before any compilation *) + +type pattern_matching = + { mutable cases : (pattern list * lambda) list; + args : (lambda * let_kind) list ; + default : (matrix * int) list} + +(* Pattern matching after application of both the or-pat rule and the + mixture rule *) + +type pm_or_compiled = + {body : pattern_matching ; + handlers : (matrix * int * Ident.t list * pattern_matching) list ; + or_matrix : matrix ; } + +type pm_half_compiled = + | PmOr of pm_or_compiled + | PmVar of pm_var_compiled + | Pm of pattern_matching + +and pm_var_compiled = + {inside : pm_half_compiled ; var_arg : lambda ; } + +type pm_half_compiled_info = + {me : pm_half_compiled ; + matrix : matrix ; + top_default : (matrix * int) list ; } + +let pretty_cases cases = + List.iter + (fun ((ps),l) -> + List.iter + (fun p -> + Parmatch.top_pretty Format.str_formatter p ; + prerr_string " " ; + prerr_string (Format.flush_str_formatter ())) + ps ; +(* + prerr_string " -> " ; + Printlambda.lambda Format.str_formatter l ; + prerr_string (Format.flush_str_formatter ()) ; +*) + prerr_endline "") + cases + +let pretty_def def = + prerr_endline "+++++ Defaults +++++" ; + List.iter + (fun (pss,i) -> + Printf.fprintf stderr "Matrix for %d\n" i ; + pretty_matrix pss) + def ; + prerr_endline "+++++++++++++++++++++" + +let pretty_pm pm = pretty_cases pm.cases + + +let rec pretty_precompiled = function + | Pm pm -> + prerr_endline "++++ PM ++++" ; + pretty_pm pm + | PmVar x -> + prerr_endline "++++ VAR ++++" ; + pretty_precompiled x.inside + | PmOr x -> + prerr_endline "++++ OR ++++" ; + pretty_pm x.body ; + List.iter + (fun (_,i,_,pm) -> + eprintf "++ Handler %d ++\n" i ; + pretty_pm pm) + x.handlers + +let pretty_precompiled_res first nexts = + pretty_precompiled first ; + List.iter + (fun (e, pmh) -> + eprintf "** DEFAULT %d **\n" e ; + pretty_precompiled pmh) + nexts + + + +(* A slight attempt to identify semantically equivalent lambda-expressions *) +exception Not_simple + +let rec raw_rec env = function + | Llet(Alias,x,ex, body) -> raw_rec ((x,raw_rec env ex)::env) body + | Lvar id as l -> + begin try List.assoc id env with + | Not_found -> l + end + | Lprim (Pfield i,args) -> + Lprim (Pfield i, List.map (raw_rec env) args) + | Lconst _ as l -> l + | Lstaticraise (i,args) -> + Lstaticraise (i, List.map (raw_rec env) args) + | _ -> raise Not_simple + +let raw_action l = try raw_rec [] l with Not_simple -> l + +let same_actions = function + | [] -> None + | [_,act] -> Some act + | (_,act0) :: rem -> + try + let raw_act0 = raw_rec [] act0 in + let rec s_rec = function + | [] -> Some act0 + | (_,act)::rem -> + if raw_act0 = raw_rec [] act then + s_rec rem + else + None in + s_rec rem + with + | Not_simple -> None + +let equal_action act1 act2 = + try + let raw1 = raw_rec [] act1 + and raw2 = raw_rec [] act2 in + raw1 = raw2 + with + | Not_simple -> false + +(* Test for swapping two clauses *) + +let up_ok_action act1 act2 = + try + let raw1 = raw_rec [] act1 + and raw2 = raw_rec [] act2 in + match raw1, raw2 with + | Lstaticraise (i1,[]), Lstaticraise (i2,[]) -> i1=i2 + | _,_ -> raw1 = raw2 + with + | Not_simple -> false + +let up_ok (ps,act_p) l = + List.for_all + (fun (qs,act_q) -> + up_ok_action act_p act_q || + not (Parmatch.compats ps qs)) + l + + +(* + Simplify fonction normalize the first column of the match + - records are expanded so that they posses all fields + - aliases are removed and replaced by bindings in actions. + However or-patterns are simplified differently, + - aliases are not removed + - or patterns (_|p) are changed into _ +*) + +exception Var of pattern + +let simplify_or p = + let rec simpl_rec p = match p with + | {pat_desc = Tpat_any|Tpat_var _} -> raise (Var p) + | {pat_desc = Tpat_alias (q,id)} -> + begin try + {p with pat_desc = Tpat_alias (simpl_rec q,id)} + with + | Var q -> raise (Var {p with pat_desc = Tpat_alias (q,id)}) + end + | {pat_desc = Tpat_or (p1,p2,o)} -> + let q1 = simpl_rec p1 in + begin try + let q2 = simpl_rec p2 in + {p with pat_desc = Tpat_or (q1, q2, o)} + with + | Var q2 -> raise (Var {p with pat_desc = Tpat_or (q1, q2, o)}) + end + | {pat_desc = Tpat_record lbls} -> + let all_lbls = all_record_args lbls in + {p with pat_desc=Tpat_record all_lbls} + | _ -> p in + try + simpl_rec p + with + | Var p -> p + +let rec simplify_cases args cls = match args with +| [] -> assert false +| (arg,_)::_ -> + let rec simplify = function + | [] -> [] + | ((pat :: patl, action) as cl) :: rem -> + begin match pat.pat_desc with + | Tpat_var id -> + (omega :: patl, bind Alias id arg action) :: + simplify rem + | Tpat_any -> + cl :: simplify rem + | Tpat_alias(p, id) -> + simplify ((p :: patl, bind Alias id arg action) :: rem) + | Tpat_record [] -> + (omega :: patl, action):: + simplify rem + | Tpat_record lbls -> + let all_lbls = all_record_args lbls in + let full_pat = {pat with pat_desc=Tpat_record all_lbls} in + (full_pat::patl,action):: + simplify rem + | Tpat_or _ -> + let pat_simple = simplify_or pat in + begin match pat_simple.pat_desc with + | Tpat_or _ -> + (pat_simple :: patl, action) :: + simplify rem + | _ -> + simplify ((pat_simple::patl,action) :: rem) + end + | _ -> cl :: simplify rem + end + | _ -> assert false in + + simplify cls + + + +(* Once matchings are simplified one easily finds + their nature *) + +let rec what_is_cases cases = match cases with +| ({pat_desc=Tpat_any} :: _, _) :: rem -> what_is_cases rem +| (({pat_desc=(Tpat_var _|Tpat_or (_,_,_)|Tpat_alias (_,_))}::_),_)::_ + -> assert false (* applies to simplified matchings only *) +| (p::_,_)::_ -> p +| [] -> omega +| _ -> assert false + + + +(* A few operation on default environments *) +let as_matrix cases = get_mins le_pats (List.map (fun (ps,_) -> ps) cases) + +let cons_default matrix raise_num default = + match matrix with + | [] -> default + | _ -> (matrix,raise_num)::default + +let default_compat p def = + List.fold_right + (fun (pss,i) r -> + let qss = + List.fold_right + (fun qs r -> match qs with + | q::rem when Parmatch.compat p q -> rem::r + | _ -> r) + pss [] in + match qss with + | [] -> r + | _ -> (qss,i)::r) + def [] + +(* Or-pattern expansion, variables are a complication w.r.t. the article *) +let rec extract_vars r p = match p.pat_desc with +| Tpat_var id -> IdentSet.add id r +| Tpat_alias (p, id) -> + extract_vars (IdentSet.add id r) p +| Tpat_tuple pats -> + List.fold_left extract_vars r pats +| Tpat_record lpats -> + List.fold_left + (fun r (_,p) -> extract_vars r p) + r lpats +| Tpat_construct (_,pats) -> + List.fold_left extract_vars r pats +| Tpat_array pats -> + List.fold_left extract_vars r pats +| Tpat_variant (_,Some p, _) -> extract_vars r p +| Tpat_or (p,_,_) -> extract_vars r p +| Tpat_constant _|Tpat_any|Tpat_variant (_,None,_) -> r + +exception Cannot_flatten + +let mk_alpha_env arg aliases ids = + List.map + (fun id -> id, + if List.mem id aliases then + match arg with + | Some v -> v + | _ -> raise Cannot_flatten + else + Ident.create (Ident.name id)) + ids + +let rec explode_or_pat arg patl mk_action rem vars aliases = function + | {pat_desc = Tpat_or (p1,p2,_)} -> + explode_or_pat + arg patl mk_action + (explode_or_pat arg patl mk_action rem vars aliases p2) + vars aliases p1 + | {pat_desc = Tpat_alias (p,id)} -> + explode_or_pat arg patl mk_action rem vars (id::aliases) p + | {pat_desc = Tpat_var x} -> + let env = mk_alpha_env arg (x::aliases) vars in + (omega::patl,mk_action (List.map snd env))::rem + | p -> + let env = mk_alpha_env arg aliases vars in + (alpha_pat env p::patl,mk_action (List.map snd env))::rem + +let pm_free_variables {cases=cases} = + List.fold_right + (fun (_,act) r -> IdentSet.union (free_variables act) r) + cases IdentSet.empty + + +(* Basic grouping predicates *) + +let group_constant = function + | {pat_desc= Tpat_constant _} -> true + | _ -> false + +and group_constructor = function + | {pat_desc = Tpat_construct (_, _)} -> true + | _ -> false + +and group_variant = function + | {pat_desc = Tpat_variant (_, _, _)} -> true + | _ -> false + +and group_var = function + | {pat_desc=Tpat_any} -> true + | _ -> false + +and group_tuple = function + | {pat_desc = (Tpat_tuple _|Tpat_any)} -> true + | _ -> false + +and group_record = function + | {pat_desc = (Tpat_record _|Tpat_any)} -> true + | _ -> false + +and group_array = function + | {pat_desc=Tpat_array _} -> true + | _ -> false + +let get_group p = match p.pat_desc with +| Tpat_any -> group_var +| Tpat_constant _ -> group_constant +| Tpat_construct (_, _) -> group_constructor +| Tpat_tuple _ -> group_tuple +| Tpat_record _ -> group_record +| Tpat_array _ -> group_array +| Tpat_variant (_,_,_) -> group_variant +| _ -> fatal_error "Matching.get_group" + + + +let is_or p = match p.pat_desc with +| Tpat_or _ -> true +| _ -> false + +(* Conditions for appending to the Or matrix *) +let conda p q = not (compat p q) +and condb act ps qs = not (is_guarded act) && Parmatch.le_pats qs ps + +let or_ok p ps l = + List.for_all + (function + | ({pat_desc=Tpat_or _} as q::qs,act) -> + conda p q || condb act ps qs + | _ -> true) + l + +(* Insert or append a pattern in the Or matrix *) + +let equiv_pat p q = le_pat p q && le_pat q p + +let rec get_equiv p l = match l with + | (q::_,_) as cl::rem -> + if equiv_pat p q then + let others,rem = get_equiv p rem in + cl::others,rem + else + [],l + | _ -> [],l + + +let insert_or_append p ps act ors no = + let rec attempt seen = function + | (q::qs,act_q) as cl::rem -> + if is_or q then begin + if compat p q then + if + IdentSet.is_empty (extract_vars IdentSet.empty p) && + IdentSet.is_empty (extract_vars IdentSet.empty q) && + equiv_pat p q + then (* attempt insert, for equivalent orpats with no variables *) + let _, not_e = get_equiv q rem in + if + or_ok p ps not_e && (* check append condition for head of O *) + List.for_all (* check insert condition for tail of O *) + (fun cl -> match cl with + | (q::_,_) -> not (compat p q) + | _ -> assert false) + seen + then (* insert *) + List.rev_append seen ((p::ps,act)::cl::rem), no + else (* fail to insert or append *) + ors,(p::ps,act)::no + else if condb act_q ps qs then (* check condition (b) for append *) + attempt (cl::seen) rem + else + ors,(p::ps,act)::no + else (* p # q, go on with append/insert *) + attempt (cl::seen) rem + end else (* q is not a or-pat, go on with append/insert *) + attempt (cl::seen) rem + | _ -> (* [] in fact *) + (p::ps,act)::ors,no in (* success in appending *) + attempt [] ors + +(* Reconstruct default information from half_compiled pm list *) + +let rec rebuild_matrix pmh = match pmh with + | Pm pm -> as_matrix pm.cases + | PmOr {or_matrix=m} -> m + | PmVar x -> add_omega_column (rebuild_matrix x.inside) + +let rec rebuild_default nexts def = match nexts with +| [] -> def +| (e, pmh)::rem -> + (add_omega_column (rebuild_matrix pmh), e):: + rebuild_default rem def + +let rebuild_nexts arg nexts k = + List.fold_right + (fun (e, pm) k -> (e, PmVar {inside=pm ; var_arg=arg})::k) + nexts k + + +(* + Split a matching. + Splitting is first directed by or-patterns, then by + must test (e.g. constructors)/variable transitions. + + The approach is greedy, every split function attempt to + raise rows as much as possible in the top matrix, + then splitting applies again to the remaining rows. + + Some precompilation of or-patterns and + variable pattern occurs. Mostly this means that bindings + are performed now, being replaced by let-bindings + in actions (cf. simplify_cases). + + Additionally, if the match argument is a variable, matchings whose + first column is made of variables only are splitted further + (cf. precompile_var). + +*) + + +let rec split_or argo cls args def = + + let cls = simplify_cases args cls in + + let rec do_split before ors no = function + | [] -> + cons_next + (List.rev before) (List.rev ors) (List.rev no) + | ((p::ps,act) as cl)::rem -> + if up_ok cl no then + if is_or p then + let ors, no = insert_or_append p ps act ors no in + do_split before ors no rem + else begin + if up_ok cl ors then + do_split (cl::before) ors no rem + else if or_ok p ps ors then + do_split before (cl::ors) no rem + else + do_split before ors (cl::no) rem + end + else + do_split before ors (cl::no) rem + | _ -> assert false + + and cons_next yes yesor = function + | [] -> + precompile_or argo yes yesor args def [] + | rem -> + let {me=next ; matrix=matrix ; top_default=def},nexts = + do_split [] [] [] rem in + let idef = next_raise_count () in + precompile_or + argo yes yesor args + (cons_default matrix idef def) + ((idef,next)::nexts) in + + do_split [] [] [] cls + +and split_constr cls args def k = + let ex_pat = what_is_cases cls in + match ex_pat.pat_desc with + | Tpat_any -> precompile_var args cls def k + | _ -> + + let group = get_group ex_pat in + + let rec split_ex yes no = function + | [] -> + let yes = List.rev yes and no = List.rev no in + begin match no with + | [] -> + {me = Pm {cases=yes ; args=args ; default=def} ; + matrix = as_matrix yes ; + top_default = def}, + k + | cl::rem -> + begin match yes with + | [] -> + (* Could not success in raising up a constr matching up *) + split_noex [cl] [] rem + | _ -> + let {me=next ; matrix=matrix ; top_default=def}, nexts = + split_noex [cl] [] rem in + let idef = next_raise_count () in + let def = cons_default matrix idef def in + {me = Pm {cases=yes ; args=args ; default=def} ; + matrix = as_matrix yes ; + top_default = def }, + (idef, next)::nexts + end + end + | (p::_,_) as cl::rem -> + if group p && up_ok cl no then + split_ex (cl::yes) no rem + else + split_ex yes (cl::no) rem + | _ -> assert false + + and split_noex yes no = function + | [] -> + let yes = List.rev yes and no = List.rev no in + begin match no with + | [] -> precompile_var args yes def k + | cl::rem -> + let {me=next ; matrix=matrix ; top_default=def}, nexts = + split_ex [cl] [] rem in + let idef = next_raise_count () in + precompile_var + args yes + (cons_default matrix idef def) + ((idef,next)::nexts) + end + | [ps,_ as cl] + when List.for_all group_var ps && yes <> [] -> + (* This enables an extra division in some frequent case : + last row is made of variables only *) + split_noex yes (cl::no) [] + | (p::_,_) as cl::rem -> + if not (group p) && up_ok cl no then + split_noex (cl::yes) no rem + else + split_noex yes (cl::no) rem + | _ -> assert false in + + match cls with + | ((p::_,_) as cl)::rem -> + if group p then split_ex [cl] [] rem + else split_noex [cl] [] rem + | _ -> assert false + +and precompile_var args cls def k = match args with +| [] -> assert false +| _::((Lvar v as av,_) as arg)::rargs -> + begin match cls with + | [ps,_] -> (* as splitted as it can *) + dont_precompile_var args cls def k + | _ -> +(* Precompile *) + let var_cls = + List.map + (fun (ps,act) -> match ps with + | _::ps -> ps,act | _ -> assert false) + cls + and var_def = make_default (fun _ rem -> rem) def in + let {me=first ; matrix=matrix}, nexts = + split_or (Some v) var_cls (arg::rargs) var_def in + +(* Compute top information *) + match nexts with + | [] -> (* If you need *) + dont_precompile_var args cls def k + | _ -> + let rfirst = + {me = PmVar {inside=first ; var_arg = av} ; + matrix = add_omega_column matrix ; + top_default = rebuild_default nexts def ; } + and rnexts = rebuild_nexts av nexts k in + rfirst, rnexts + end +| _ -> + dont_precompile_var args cls def k + +and dont_precompile_var args cls def k = + {me = Pm {cases = cls ; args = args ; default = def } ; + matrix=as_matrix cls ; + top_default=def},k + +and precompile_or argo cls ors args def k = match ors with +| [] -> split_constr cls args def k +| _ -> + let rec do_cases = function + | ({pat_desc=Tpat_or _} as orp::patl, action)::rem -> + let others,rem = get_equiv orp rem in + let orpm = + {cases = + (patl, action):: + List.map + (function + | (_::ps,action) -> ps,action + | _ -> assert false) + others ; + args = (match args with _::r -> r | _ -> assert false) ; + default = default_compat orp def} in + let vars = + IdentSet.elements + (IdentSet.inter + (extract_vars IdentSet.empty orp) + (pm_free_variables orpm)) in + let or_num = next_raise_count () in + let new_patl = Parmatch.omega_list patl in + + let mk_new_action vs = + Lstaticraise + (or_num, List.map (fun v -> Lvar v) vs) in + + let body,handlers = do_cases rem in + explode_or_pat + argo new_patl mk_new_action body vars [] orp, + (([[orp]], or_num, vars , orpm):: handlers) + | cl::rem -> + let new_ord,new_to_catch = do_cases rem in + cl::new_ord,new_to_catch + | [] -> [],[] in + + let end_body, handlers = do_cases ors in + let matrix = as_matrix (cls@ors) + and body = {cases=cls@end_body ; args=args ; default=def} in + {me = PmOr {body=body ; handlers=handlers ; or_matrix=matrix} ; + matrix=matrix ; + top_default=def}, + k + +let split_precompile argo pm = + let {me=next}, nexts = split_or argo pm.cases pm.args pm.default in +(* + if nexts <> [] || (match next with PmOr _ -> true | _ -> false) then begin + prerr_endline "** SPLIT **" ; + pretty_pm pm ; + pretty_precompiled_res next nexts + end ; +*) + next, nexts + + +(* General divide functions *) + +let add_line patl_action pm = pm.cases <- patl_action :: pm.cases; pm + +type cell = + {pm : pattern_matching ; + ctx : ctx list ; + pat : pattern} + +let add make_matching_fun division key patl_action args = + try + let cell = List.assoc key division in + cell.pm.cases <- patl_action :: cell.pm.cases; + division + with Not_found -> + let cell = make_matching_fun args in + cell.pm.cases <- [patl_action] ; + (key, cell) :: division + + +let divide make get_key get_args ctx pm = + + let rec divide_rec = function + | (p::patl,action) :: rem -> + let this_match = divide_rec rem in + add + (make p pm.default ctx) + this_match (get_key p) (get_args p patl,action) pm.args + | _ -> [] in + + divide_rec pm.cases + + +let divide_line make_ctx make get_args pat ctx pm = + let rec divide_rec = function + | (p::patl,action) :: rem -> + let this_match = divide_rec rem in + add_line (get_args p patl, action) this_match + | _ -> make pm.default pm.args in + + {pm = divide_rec pm.cases ; + ctx=make_ctx ctx ; + pat=pat} + + + +(* Then come various functions, + There is one set of functions per matching style + (constants, constructors etc.) + + - matcher function are arguments to make_default (for defaukt handlers) + They may raise NoMatch or OrPat and perform the full + matching (selection + arguments). + + + - get_args and get_key are for the compiled matrices, note that + selection and geting arguments are separed. + + - make_ _matching combines the previous functions for produicing + new ``pattern_matching'' records. +*) + + + +let rec matcher_const cst p rem = match p.pat_desc with +| Tpat_or (p1,p2,_) -> + begin try + matcher_const cst p1 rem with + | NoMatch -> matcher_const cst p2 rem + end +| Tpat_constant c1 when c1=cst -> rem +| Tpat_any -> rem +| _ -> raise NoMatch + +let get_key_constant caller = function + | {pat_desc= Tpat_constant cst} as p -> cst + | p -> + prerr_endline ("BAD: "^caller) ; + pretty_pat p ; + assert false + +let get_args_constant _ rem = rem + +let make_constant_matching p def ctx = function + [] -> fatal_error "Matching.make_constant_matching" + | (_ :: argl) -> + let def = + make_default + (matcher_const (get_key_constant "make" p)) def + and ctx = + filter_ctx p ctx in + {pm = {cases = []; args = argl ; default = def} ; + ctx = ctx ; + pat = normalize_pat p} + + + + +let divide_constant ctx m = + divide + make_constant_matching (get_key_constant "divide") + get_args_constant + ctx m + +(* Matching against a constructor *) + + +let make_field_args binding_kind arg first_pos last_pos argl = + let rec make_args pos = + if pos > last_pos + then argl + else (Lprim(Pfield pos, [arg]), binding_kind) :: make_args (pos + 1) + in make_args first_pos + +let get_key_constr = function + | {pat_desc=Tpat_construct (cstr,_)} -> cstr.cstr_tag + | _ -> assert false + +let get_args_constr p rem = match p with +| {pat_desc=Tpat_construct (_,args)} -> args @ rem +| _ -> assert false + +let pat_as_constr = function + | {pat_desc=Tpat_construct (cstr,_)} -> cstr + | _ -> fatal_error "Matching.pat_as_constr" + + +let matcher_constr cstr = match cstr.cstr_arity with +| 0 -> + let rec matcher_rec q rem = match q.pat_desc with + | Tpat_or (p1,p2,_) -> + begin + try + matcher_rec p1 rem + with + | NoMatch -> matcher_rec p2 rem + end + | Tpat_construct (cstr1, []) when cstr.cstr_tag = cstr1.cstr_tag -> + rem + | Tpat_any -> rem + | _ -> raise NoMatch in + matcher_rec +| 1 -> + let rec matcher_rec q rem = match q.pat_desc with + | Tpat_or (p1,p2,_) -> + let r1 = try Some (matcher_rec p1 rem) with NoMatch -> None + and r2 = try Some (matcher_rec p2 rem) with NoMatch -> None in + begin match r1,r2 with + | None, None -> raise NoMatch + | Some r1, None -> r1 + | None, Some r2 -> r2 + | Some (a1::rem1), Some (a2::_) -> + {a1 with +pat_loc = Location.none ; +pat_desc = Tpat_or (a1, a2, None)}:: + rem + | _, _ -> assert false + end + | Tpat_construct (cstr1, [arg]) when cstr.cstr_tag = cstr1.cstr_tag -> + arg::rem + | Tpat_any -> omega::rem + | _ -> raise NoMatch in + matcher_rec +| _ -> + fun q rem -> match q.pat_desc with + | Tpat_or (_,_,_) -> raise OrPat + | Tpat_construct (cstr1, args) + when cstr.cstr_tag = cstr1.cstr_tag -> args @ rem + | Tpat_any -> Parmatch.omegas cstr.cstr_arity @ rem + | _ -> raise NoMatch + +let make_constr_matching p def ctx = function + [] -> fatal_error "Matching.make_constr_matching" + | ((arg, mut) :: argl) -> + let cstr = pat_as_constr p in + let newargs = + match cstr.cstr_tag with + Cstr_constant _ | Cstr_block _ -> + make_field_args Alias arg 0 (cstr.cstr_arity - 1) argl + | Cstr_exception _ -> + make_field_args Alias arg 1 cstr.cstr_arity argl in + {pm= + {cases = []; args = newargs; + default = make_default (matcher_constr cstr) def} ; + ctx = filter_ctx p ctx ; + pat=normalize_pat p} + + +let divide_constructor ctx pm = + divide + make_constr_matching + get_key_constr get_args_constr + ctx pm + +(* Matching against a variant *) + +let rec matcher_variant_const lab p rem = match p.pat_desc with +| Tpat_or (p1, p2, _) -> + begin + try + matcher_variant_const lab p1 rem + with + | NoMatch -> matcher_variant_const lab p2 rem + end +| Tpat_variant (lab1,_,_) when lab1=lab -> rem +| Tpat_any -> rem +| _ -> raise NoMatch + + +let make_variant_matching_constant p lab def ctx = function + [] -> fatal_error "Matching.make_variant_matching_constant" + | ((arg, mut) :: argl) -> + let def = make_default (matcher_variant_const lab) def + and ctx = filter_ctx p ctx in + {pm={ cases = []; args = argl ; default=def} ; + ctx=ctx ; + pat = normalize_pat p} + +let matcher_variant_nonconst lab p rem = match p.pat_desc with +| Tpat_or (_,_,_) -> raise OrPat +| Tpat_variant (lab1,Some arg,_) when lab1=lab -> arg::rem +| Tpat_any -> omega::rem +| _ -> raise NoMatch + + +let make_variant_matching_nonconst p lab def ctx = function + [] -> fatal_error "Matching.make_variant_matching_nonconst" + | ((arg, mut) :: argl) -> + let def = make_default (matcher_variant_nonconst lab) def + and ctx = filter_ctx p ctx in + {pm= + {cases = []; args = (Lprim(Pfield 1, [arg]), Alias) :: argl; + default=def} ; + ctx=ctx ; + pat = normalize_pat p} + +let get_key_variant p = match p.pat_desc with +| Tpat_variant(lab, Some _ , _) -> Cstr_block (Btype.hash_variant lab) +| Tpat_variant(lab, None , _) -> Cstr_constant (Btype.hash_variant lab) +| _ -> assert false + +let divide_variant row ctx ({cases = cl; args = al; default=def} as pm) = + let row = Btype.row_repr row in + let rec divide = function + ({pat_desc = Tpat_variant(lab, pato, _)} as p:: patl, action) :: rem -> + let variants = divide rem in + if try Btype.row_field_repr (List.assoc lab row.row_fields) = Rabsent + with Not_found -> true + then + variants + else begin + let tag = Btype.hash_variant lab in + match pato with + None -> + add (make_variant_matching_constant p lab def ctx) variants + (Cstr_constant tag) (patl, action) al + | Some pat -> + add (make_variant_matching_nonconst p lab def ctx) variants + (Cstr_block tag) (pat :: patl, action) al + end + | cl -> [] + in + divide cl + +(* + Three ``no-test'' cases + *) + +(* Matching against a variable *) + +let get_args_var _ rem = rem + + +let make_var_matching def = function + | [] -> fatal_error "Matching.make_var_matching" + | _::argl -> + {cases=[] ; + args = argl ; + default= make_default get_args_var def} + +let divide_var ctx pm = + divide_line ctx_lshift make_var_matching get_args_var omega ctx pm + +(* Matching against a tuple pattern *) + + +let get_args_tuple arity p rem = match p with +| {pat_desc = Tpat_any} -> omegas arity @ rem +| {pat_desc = Tpat_tuple args} -> + args @ rem +| _ -> assert false + +let matcher_tuple arity p rem = match p.pat_desc with +| Tpat_or (_,_,_) -> raise OrPat +| Tpat_var _ -> get_args_tuple arity omega rem +| _ -> get_args_tuple arity p rem + +let make_tuple_matching arity def = function + [] -> fatal_error "Matching.make_tuple_matching" + | (arg, mut) :: argl -> + let rec make_args pos = + if pos >= arity + then argl + else (Lprim(Pfield pos, [arg]), Alias) :: make_args (pos + 1) in + {cases = []; args = make_args 0 ; + default=make_default (matcher_tuple arity) def} + + +let divide_tuple arity p ctx pm = + divide_line + (filter_ctx p) + (make_tuple_matching arity) + (get_args_tuple arity) p ctx pm + +(* Matching against a record pattern *) + + +let record_matching_line num_fields lbl_pat_list = + let patv = Array.create num_fields omega in + List.iter (fun (lbl, pat) -> patv.(lbl.lbl_pos) <- pat) lbl_pat_list; + Array.to_list patv + +let get_args_record num_fields p rem = match p with +| {pat_desc=Tpat_any} -> + record_matching_line num_fields [] @ rem +| {pat_desc=Tpat_record lbl_pat_list} -> + record_matching_line num_fields lbl_pat_list @ rem +| _ -> assert false + +let matcher_record num_fields p rem = match p.pat_desc with +| Tpat_or (_,_,_) -> raise OrPat +| Tpat_var _ -> get_args_record num_fields omega rem +| _ -> get_args_record num_fields p rem + +let make_record_matching all_labels def = function + [] -> fatal_error "Matching.make_record_matching" + | ((arg, mut) :: argl) -> + let rec make_args pos = + if pos >= Array.length all_labels then argl else begin + let lbl = all_labels.(pos) in + let access = + match lbl.lbl_repres with + Record_regular -> Pfield lbl.lbl_pos + | Record_float -> Pfloatfield lbl.lbl_pos in + let str = + match lbl.lbl_mut with + Immutable -> Alias + | Mutable -> StrictOpt in + (Lprim(access, [arg]), str) :: make_args(pos + 1) + end in + let nfields = Array.length all_labels in + let def= make_default (matcher_record nfields) def in + {cases = []; args = make_args 0 ; default = def} + + +let divide_record all_labels p ctx pm = + let get_args = get_args_record (Array.length all_labels) in + divide_line + (filter_ctx p) + (make_record_matching all_labels) + get_args + p ctx pm + +(* Matching against an array pattern *) + +let get_key_array = function + | {pat_desc=Tpat_array patl} -> List.length patl + | _ -> assert false + +let get_args_array p rem = match p with +| {pat_desc=Tpat_array patl} -> patl@rem +| _ -> assert false + +let matcher_array len p rem = match p.pat_desc with +| Tpat_or (_,_,_) -> raise OrPat +| Tpat_array args when List.length args=len -> args @ rem +| Tpat_any -> Parmatch.omegas len @ rem +| _ -> raise NoMatch + +let make_array_matching kind p def ctx = function + | [] -> fatal_error "Matching.make_array_matching" + | ((arg, mut) :: argl) -> + let len = get_key_array p in + let rec make_args pos = + if pos >= len + then argl + else (Lprim(Parrayrefu kind, [arg; Lconst(Const_base(Const_int pos))]), + StrictOpt) :: make_args (pos + 1) in + let def = make_default (matcher_array len) def + and ctx = filter_ctx p ctx in + {pm={cases = []; args = make_args 0 ; default = def} ; + ctx=ctx ; + pat = normalize_pat p} + +let divide_array kind ctx pm = + divide + (make_array_matching kind) + get_key_array get_args_array ctx pm + +(* To combine sub-matchings together *) + +let float_compare s1 s2 = + let f1 = float_of_string s1 and f2 = float_of_string s2 in + Pervasives.compare f1 f2 + +let sort_lambda_list l = + List.sort + (fun (x,_) (y,_) -> match x,y with + | Const_float f1, Const_float f2 -> float_compare f1 f2 + | _, _ -> Pervasives.compare x y) + l + +let rec cut n l = + if n = 0 then [],l + else match l with + [] -> raise (Invalid_argument "cut") + | a::l -> let l1,l2 = cut (n-1) l in a::l1, l2 + +let rec do_tests_fail fail tst arg = function + | [] -> fail + | (c, act)::rem -> + Lifthenelse + (Lprim (tst, [arg ; Lconst (Const_base c)]), + do_tests_fail fail tst arg rem, + act) + +let rec do_tests_nofail tst arg = function + | [] -> fatal_error "Matching.do_tests_nofail" + | [_,act] -> act + | (c,act)::rem -> + Lifthenelse + (Lprim (tst, [arg ; Lconst (Const_base c)]), + do_tests_nofail tst arg rem, + act) + +let make_test_sequence fail tst lt_tst arg const_lambda_list = + let rec make_test_sequence const_lambda_list = + if List.length const_lambda_list >= 4 && lt_tst <> Praise then + split_sequence const_lambda_list + else match fail with + | None -> do_tests_nofail tst arg const_lambda_list + | Some fail -> do_tests_fail fail tst arg const_lambda_list + + and split_sequence const_lambda_list = + let list1, list2 = + cut (List.length const_lambda_list / 2) const_lambda_list in + Lifthenelse(Lprim(lt_tst,[arg; Lconst(Const_base (fst(List.hd list2)))]), + make_test_sequence list1, make_test_sequence list2) + in make_test_sequence (sort_lambda_list const_lambda_list) + + +let make_offset x arg = if x=0 then arg else Lprim(Poffsetint(x), [arg]) + + + +let prim_string_notequal = + Pccall{prim_name = "string_notequal"; + prim_arity = 2; prim_alloc = false; + prim_native_name = ""; prim_native_float = false} + +let rec explode_inter offset i j act k = + if i <= j then + explode_inter offset i (j-1) act ((j-offset,act)::k) + else + k + +let max_vals cases acts = + let vals = Array.create (Array.length acts) 0 in + for i=Array.length cases-1 downto 0 do + let l,h,act = cases.(i) in + vals.(act) <- h - l + 1 + vals.(act) + done ; + let max = ref 0 in + for i = Array.length vals-1 downto 0 do + if vals.(i) >= vals.(!max) then + max := i + done ; + if vals.(!max) > 1 then + !max + else + -1 + +let as_int_list cases acts = + let default = max_vals cases acts in + let min_key,_,_ = cases.(0) + and _,max_key,_ = cases.(Array.length cases-1) in + let offset = max_key-min_key in + let rec do_rec i k = + if i >= 0 then + let low, high, act = cases.(i) in + if act = default then + do_rec (i-1) k + else + do_rec (i-1) (explode_inter min_key low high acts.(act) k) + else + k in + min_key, max_key,do_rec (Array.length cases-1) [], + (if default >= 0 then Some acts.(default) else None) + + +let make_switch_offset arg min_key max_key int_lambda_list default = + let numcases = max_key - min_key + 1 in + let cases = + List.map (fun (key, l) -> (key - min_key, l)) int_lambda_list in + let offsetarg = make_offset (-min_key) arg in + Lswitch(offsetarg, + {sw_numconsts = numcases; sw_consts = cases; + sw_numblocks = 0; sw_blocks = []; + sw_failaction = default}) + +let make_switch_switcher arg cases acts = + let l = ref [] in + for i = Array.length cases-1 downto 0 do + l := (i,acts.(cases.(i))) :: !l + done ; + Lswitch(arg, + {sw_numconsts = Array.length cases ; sw_consts = !l ; + sw_numblocks = 0 ; sw_blocks = [] ; + sw_failaction = None}) + +let full sw = + List.length sw.sw_consts = sw.sw_numconsts && + List.length sw.sw_blocks = sw.sw_numblocks + +let make_switch (arg,sw) = match sw.sw_failaction with +| None -> + let t = Hashtbl.create 17 in + let seen l = match l with + | Lstaticraise (i,[]) -> + let old = try Hashtbl.find t i with Not_found -> 0 in + Hashtbl.replace t i (old+1) + | _ -> () in + List.iter (fun (_,lam) -> seen lam) sw.sw_consts ; + List.iter (fun (_,lam) -> seen lam) sw.sw_blocks ; + let i_max = ref (-1) + and max = ref (-1) in + Hashtbl.iter + (fun i c -> + if c > !max then begin + i_max := i ; + max := c + end) t ; + if !i_max >= 0 then + let default = !i_max in + let rec remove = function + | [] -> [] + | (_,Lstaticraise (j,[]))::rem when j=default -> + remove rem + | x::rem -> x::remove rem in + Lswitch + (arg, + {sw with +sw_consts = remove sw.sw_consts ; +sw_blocks = remove sw.sw_blocks ; +sw_failaction = Some (Lstaticraise (default,[]))}) + else + Lswitch (arg,sw) +| _ -> Lswitch (arg,sw) + +module SArg = struct + type primitive = Lambda.primitive + + let eqint = Pintcomp Ceq + let neint = Pintcomp Cneq + let leint = Pintcomp Cle + let ltint = Pintcomp Clt + let geint = Pintcomp Cge + let gtint = Pintcomp Cgt + + type act = Lambda.lambda + + let make_prim p args = Lprim (p,args) + let make_offset arg n = match n with + | 0 -> arg + | _ -> Lprim (Poffsetint n,[arg]) + let bind arg body = + let newvar,newarg = match arg with + | Lvar v -> v,arg + | _ -> + let newvar = Ident.create "switcher" in + newvar,Lvar newvar in + bind Alias newvar arg (body newarg) + + let make_isout h arg = Lprim (Pisout, [h ; arg]) + let make_isin h arg = Lprim (Pnot,[make_isout h arg]) + let make_if cond ifso ifnot = Lifthenelse (cond, ifso, ifnot) + let make_switch = make_switch_switcher +end + +module Switcher = Switch.Make(SArg) +open Switch + +let lambda_of_int i = Lconst (Const_base (Const_int i)) + +let rec last def = function + | [] -> def + | [x,_] -> x + | _::rem -> last def rem + +let get_edges low high l = match l with +| [] -> low, high +| (x,_)::_ -> x, last high l + + +let as_interval_canfail fail low high l = + let store = mk_store equal_action in + let rec nofail_rec cur_low cur_high cur_act = function + | [] -> + if cur_high = high then + [cur_low,cur_high,cur_act] + else + [(cur_low,cur_high,cur_act) ; (cur_high+1,high, 0)] + | ((i,act_i)::rem) as all -> + let act_index = store.act_store act_i in + if cur_high+1= i then + if act_index=cur_act then + nofail_rec cur_low i cur_act rem + else if act_index=0 then + (cur_low,i-1, cur_act)::fail_rec i i rem + else + (cur_low, i-1, cur_act)::nofail_rec i i act_index rem + else + (cur_low, cur_high, cur_act):: + fail_rec ((cur_high+1)) (cur_high+1) all + + and fail_rec cur_low cur_high = function + | [] -> [(cur_low, cur_high, 0)] + | (i,act_i)::rem -> + let index = store.act_store act_i in + if index=0 then fail_rec cur_low i rem + else + (cur_low,i-1,0):: + nofail_rec i i index rem in + + let rec init_rec = function + | [] -> [] + | (i,act_i)::rem as all -> + let index = store.act_store act_i in + if index=0 then + fail_rec low i rem + else + if low < i then + (low,i-1,0)::nofail_rec i i index rem + else + nofail_rec i i index rem in + + ignore (store.act_store fail) ; (* fail has action index 0 *) + let r = init_rec l in + Array.of_list r, store.act_get () + +let as_interval_nofail l = + let store = mk_store equal_action in + + let rec i_rec cur_low cur_high cur_act = function + | [] -> + [cur_low, cur_high, cur_act] + | (i,act)::rem -> + let act_index = store.act_store act in + if act_index = cur_act then + i_rec cur_low i cur_act rem + else + (cur_low, cur_high, cur_act):: + i_rec i i act_index rem in + let inters = match l with + | (i,act)::rem -> + let act_index = store.act_store act in + i_rec i i act_index rem + | _ -> assert false in + + Array.of_list inters, store.act_get () + + +let sort_int_lambda_list l = + List.sort + (fun (i1,_) (i2,_) -> + if i1 < i2 then -1 + else if i2 < i1 then 1 + else 0) + l + +let as_interval fail low high l = + let l = sort_int_lambda_list l in + get_edges low high l, + (match fail with + | None -> as_interval_nofail l + | Some act -> as_interval_canfail act low high l) + +let call_switcher konst fail arg low high int_lambda_list = + let edges, (cases, actions) = + as_interval fail low high int_lambda_list in + Switcher.zyva edges konst arg cases actions + + +let exists_ctx ok ctx = + List.exists + (function + | {right=p::_} -> ok p + | _ -> assert false) + ctx + +let rec list_as_pat = function + | [] -> fatal_error "Matching.list_as_pat" + | [pat] -> pat + | pat::rem -> + {pat with pat_desc = Tpat_or (pat,list_as_pat rem,None)} + + +let rec pat_as_list k = function + | {pat_desc=Tpat_or (p1,p2,_)} -> + pat_as_list (pat_as_list k p2) p1 + | p -> p::k + +(* Extracting interesting patterns *) +exception All + +let rec extract_pat seen k p = match p.pat_desc with +| Tpat_or (p1,p2,_) -> + let k1,seen1 = extract_pat seen k p1 in + extract_pat seen1 k1 p2 +| Tpat_alias (p,_) -> + extract_pat seen k p +| Tpat_var _|Tpat_any -> + raise All +| _ -> + let q = normalize_pat p in + if List.exists (compat q) seen then + k, seen + else + q::k, q::seen + +let extract_mat seen pss = + let r,_ = + List.fold_left + (fun (k,seen) ps -> match ps with + | p::_ -> extract_pat seen k p + | _ -> assert false) + ([],seen) + pss in + r + + + +let complete_pats_constrs = function + | p::_ as pats -> + List.map + (pat_of_constr p) + (complete_constrs p (List.map get_key_constr pats)) + | _ -> assert false + + +let mk_res get_key env last_choice idef cant_fail ctx = + + let env,fail,jumps_fail = match last_choice with + | [] -> + env, None, jumps_empty + | [p] when group_var p -> + env, + Some (Lstaticraise (idef,[])), + jumps_singleton idef ctx + | _ -> + (idef,cant_fail,last_choice)::env, + None, jumps_empty in + let klist,jumps = + List.fold_right + (fun (i,cant_fail,pats) (klist,jumps) -> + let act = Lstaticraise (i,[]) + and pat = list_as_pat pats in + let klist = + List.fold_right + (fun pat klist -> (get_key pat,act)::klist) + pats klist + and ctx = if cant_fail then ctx else ctx_lub pat ctx in + klist,jumps_add i ctx jumps) + env ([],jumps_fail) in + fail, klist, jumps + + +(* Aucune optimisation, reflechir apres la release *) +let mk_failaction_neg partial ctx def = match partial with +| Partial -> + begin match def with + | (_,idef)::_ -> + Some (Lstaticraise (idef,[])),[],jumps_singleton idef ctx + | _ -> assert false + end +| Total -> + None, [], jumps_empty + + +(* Conforme a l'article et plus simple qu'avant *) +and mk_failaction_pos partial seen ctx defs = + let rec scan_def env to_test defs = match to_test,defs with + | ([],_)|(_,[]) -> + List.fold_left + (fun (klist,jumps) (pats,i)-> + let action = Lstaticraise (i,[]) in + let klist = + List.fold_right + (fun pat r -> (get_key_constr pat,action)::r) + pats klist + and jumps = + jumps_add i (ctx_lub (list_as_pat pats) ctx) jumps in + klist,jumps) + ([],jumps_empty) env + | _,(pss,idef)::rem -> + let now, later = + List.partition + (fun (p,p_ctx) -> ctx_match p_ctx pss) to_test in + match now with + | [] -> scan_def env to_test rem + | _ -> scan_def ((List.map fst now,idef)::env) later rem in + + scan_def + [] + (List.map + (fun pat -> pat, ctx_lub pat ctx) + (complete_pats_constrs seen)) + defs + + +let combine_constant arg cst partial ctx def + (const_lambda_list, total, pats) = + let fail, to_add, local_jumps = + mk_failaction_neg partial ctx def in + let const_lambda_list = to_add@const_lambda_list in + let lambda1 = + match cst with + | Const_int _ -> + let int_lambda_list = + List.map (function Const_int n, l -> n,l | _ -> assert false) + const_lambda_list in + call_switcher + lambda_of_int fail arg min_int max_int int_lambda_list + | Const_char _ -> + let int_lambda_list = + List.map (function Const_char c, l -> (Char.code c, l) + | _ -> assert false) + const_lambda_list in + call_switcher + (fun i -> Lconst (Const_base (Const_int i))) + fail arg 0 255 int_lambda_list + | Const_string _ -> + make_test_sequence + fail prim_string_notequal Praise arg const_lambda_list + | Const_float _ -> + make_test_sequence + fail + (Pfloatcomp Cneq) (Pfloatcomp Clt) + arg const_lambda_list + | Const_int32 _ -> + make_test_sequence + fail + (Pbintcomp(Pint32, Cneq)) (Pbintcomp(Pint32, Clt)) + arg const_lambda_list + | Const_int64 _ -> + make_test_sequence + fail + (Pbintcomp(Pint64, Cneq)) (Pbintcomp(Pint64, Clt)) + arg const_lambda_list + | Const_nativeint _ -> + make_test_sequence + fail + (Pbintcomp(Pnativeint, Cneq)) (Pbintcomp(Pnativeint, Clt)) + arg const_lambda_list + in lambda1,jumps_union local_jumps total + + + +let split_cases tag_lambda_list = + let rec split_rec = function + [] -> ([], []) + | (cstr, act) :: rem -> + let (consts, nonconsts) = split_rec rem in + match cstr with + Cstr_constant n -> ((n, act) :: consts, nonconsts) + | Cstr_block n -> (consts, (n, act) :: nonconsts) + | _ -> assert false in + let const, nonconst = split_rec tag_lambda_list in + sort_int_lambda_list const, + sort_int_lambda_list nonconst + + +let combine_constructor arg ex_pat cstr partial ctx def + (tag_lambda_list, total1, pats) = + if cstr.cstr_consts < 0 then begin + (* Special cases for exceptions *) + let cstrs = List.map fst tag_lambda_list in + let fail, to_add, local_jumps = + mk_failaction_neg partial ctx def in + let tag_lambda_list = to_add@tag_lambda_list in + let lambda1 = + let default, tests = + match fail with + | None -> + begin match tag_lambda_list with + | (_, act)::rem -> act,rem + | _ -> assert false + end + | Some fail -> fail, tag_lambda_list in + List.fold_right + (fun (ex, act) rem -> + match ex with + | Cstr_exception path -> + Lifthenelse(Lprim(Pintcomp Ceq, + [Lprim(Pfield 0, [arg]); transl_path path]), + act, rem) + | _ -> assert false) + tests default in + lambda1, jumps_union local_jumps total1 + end else begin + (* Regular concrete type *) + let ncases = List.length tag_lambda_list + and nconstrs = cstr.cstr_consts + cstr.cstr_nonconsts in + let sig_complete = ncases = nconstrs + and cstrs = List.map fst tag_lambda_list in + let fails,local_jumps = + if sig_complete then [],jumps_empty + else + mk_failaction_pos partial pats ctx def in + + let tag_lambda_list = fails @ tag_lambda_list in + let (consts, nonconsts) = split_cases tag_lambda_list in + let lambda1 = + match same_actions tag_lambda_list with + | Some act -> act + | _ -> + match + (cstr.cstr_consts, cstr.cstr_nonconsts, consts, nonconsts) + with + | (1, 1, [0, act1], [0, act2]) -> + Lifthenelse(arg, act2, act1) + | (n,_,_,[]) -> + call_switcher + (fun i -> Lconst (Const_base (Const_int i))) + None arg 0 (n-1) consts + | (n, _, _, _) -> + match same_actions nonconsts with + | None -> + make_switch(arg, {sw_numconsts = cstr.cstr_consts; + sw_consts = consts; + sw_numblocks = cstr.cstr_nonconsts; + sw_blocks = nonconsts; + sw_failaction = None}) + | Some act -> + Lifthenelse + (Lprim (Pisint, [arg]), + call_switcher + (fun i -> Lconst (Const_base (Const_int i))) + None arg + 0 (n-1) consts, + act) in + lambda1, jumps_union local_jumps total1 + end + +let make_test_sequence_variant_constant fail arg int_lambda_list = + let _, (cases, actions) = + as_interval fail min_int max_int int_lambda_list in + Switcher.test_sequence + (fun i -> Lconst (Const_base (Const_int i))) arg cases actions + +let call_switcher_variant_constant fail arg int_lambda_list = + call_switcher + (fun i -> Lconst (Const_base (Const_int i))) + fail arg min_int max_int int_lambda_list + + +let call_switcher_variant_constr fail arg int_lambda_list = + let v = Ident.create "variant" in + Llet(Alias, v, Lprim(Pfield 0, [arg]), + call_switcher + (fun i -> Lconst (Const_base (Const_int i))) + fail (Lvar v) min_int max_int int_lambda_list) + +let combine_variant row arg partial ctx def (tag_lambda_list, total1, pats) = + let row = Btype.row_repr row in + let num_constr = ref 0 in + if row.row_closed then + List.iter + (fun (_, f) -> + match Btype.row_field_repr f with + Rabsent | Reither(true, _::_, _, _) -> () + | _ -> incr num_constr) + row.row_fields + else + num_constr := max_int; + let test_int_or_block arg if_int if_block = + Lifthenelse(Lprim (Pisint, [arg]), if_int, if_block) in + let sig_complete = List.length tag_lambda_list = !num_constr + and one_action = same_actions tag_lambda_list in + let fail, to_add, local_jumps = + if sig_complete || (match partial with Total -> true | _ -> false) then + None, [], jumps_empty + else + mk_failaction_neg partial ctx def in + let tag_lambda_list = to_add@tag_lambda_list in + let (consts, nonconsts) = split_cases tag_lambda_list in + let lambda1 = match fail, one_action with + | None, Some act -> act + | _,_ -> + match (consts, nonconsts) with + | ([n, act1], [m, act2]) when fail=None -> + test_int_or_block arg act1 act2 + | (_, []) -> (* One can compare integers and pointers *) + make_test_sequence_variant_constant fail arg consts + | ([], _) -> + let lam = call_switcher_variant_constr + fail arg nonconsts in + (* One must not dereference integers *) + begin match fail with + | None -> lam + | Some fail -> test_int_or_block arg fail lam + end + | (_, _) -> + let lam_const = + call_switcher_variant_constant + fail arg consts + and lam_nonconst = + call_switcher_variant_constr + fail arg nonconsts in + test_int_or_block arg lam_const lam_nonconst + in + lambda1, jumps_union local_jumps total1 + + +let combine_array arg kind partial ctx def + (len_lambda_list, total1, pats) = + let fail, to_add, local_jumps = mk_failaction_neg partial ctx def in + let len_lambda_list = to_add @ len_lambda_list in + let lambda1 = + let newvar = Ident.create "len" in + let switch = + call_switcher + lambda_of_int + fail (Lvar newvar) + 0 max_int len_lambda_list in + bind + Alias newvar (Lprim(Parraylength kind, [arg])) switch in + lambda1, jumps_union local_jumps total1 + +(* Insertion of debugging events *) + +let rec event_branch repr lam = + begin match lam, repr with + (_, None) -> + lam + | (Levent(lam', ev), Some r) -> + incr r; + Levent(lam', {lev_pos = ev.lev_pos; + lev_kind = ev.lev_kind; + lev_repr = repr; + lev_env = ev.lev_env}) + | (Llet(str, id, lam, body), _) -> + Llet(str, id, lam, event_branch repr body) + | Lstaticraise _,_ -> lam + | (_, Some r) -> + Printlambda.lambda Format.str_formatter lam ; + fatal_error + ("Matching.event_branch: "^Format.flush_str_formatter ()) + end + + +(* + This exception is raised when the compiler cannot produce code + because control cannot reach the compiled clause, + + Unused is raised initialy in compile_test. + + compile_list (for compiling switch results) catch Unused + + comp_match_handlers (for compililing splitted matches) + may reraise Unused + + +*) + +exception Unused + +let compile_list compile_fun division = + + let rec c_rec totals = function + | [] -> [], jumps_unions totals, [] + | (key, cell) :: rem -> + begin match cell.ctx with + | [] -> c_rec totals rem + | _ -> + try + let (lambda1, total1) = compile_fun cell.ctx cell.pm in + let c_rem, total, new_pats = + c_rec + (jumps_map ctx_combine total1::totals) rem in + ((key,lambda1)::c_rem), total, (cell.pat::new_pats) + with + | Unused -> c_rec totals rem + end in + c_rec [] division + + +let compile_orhandlers compile_fun lambda1 total1 ctx to_catch = + let rec do_rec r total_r = function + | [] -> r,total_r + | (mat,i,vars,pm)::rem -> + begin try + let ctx = select_columns mat ctx in + let handler_i, total_i = compile_fun ctx pm in + match raw_action r with + | Lstaticraise (j,args) -> + if i=j then + List.fold_right2 (bind Alias) vars args handler_i, + jumps_map (ctx_rshift_num (ncols mat)) total_i + else + do_rec r total_r rem + | _ -> + do_rec + (Lstaticcatch (r,(i,vars), handler_i)) + (jumps_union + (jumps_remove i total_r) + (jumps_map (ctx_rshift_num (ncols mat)) total_i)) + rem + with + | Unused -> + do_rec (Lstaticcatch (r, (i,vars), lambda_unit)) total_r rem + end in + do_rec lambda1 total1 to_catch + + +let compile_test compile_fun partial divide combine ctx to_match = + let division = divide ctx to_match in + let c_div = compile_list compile_fun division in + match c_div with + | [],_,_ -> + begin match mk_failaction_neg partial ctx to_match.default with + | None,_,_ -> raise Unused + | Some l,_,total -> l,total + end + | _ -> + combine ctx to_match.default c_div + +(* Attempt to avoid some useless bindings by lowering them *) + +(* Approximation of v present in lam *) +let rec approx_present v = function + | Lconst _ -> false + | Lstaticraise (_,args) -> + List.exists (fun lam -> approx_present v lam) args + | Lprim (_,args) -> + List.exists (fun lam -> approx_present v lam) args + | Llet (Alias, _, l1, l2) -> + approx_present v l1 || approx_present v l2 + | Lvar vv -> Ident.same v vv + | _ -> true + +let string_of_lam lam = + Printlambda.lambda Format.str_formatter lam ; + Format.flush_str_formatter () + +let rec lower_bind v arg lam = match lam with +| Lifthenelse (cond, ifso, ifnot) -> + let pcond = approx_present v cond + and pso = approx_present v ifso + and pnot = approx_present v ifnot in + begin match pcond, pso, pnot with + | false, false, false -> lam + | false, true, false -> + Lifthenelse (cond, lower_bind v arg ifso, ifnot) + | false, false, true -> + Lifthenelse (cond, ifso, lower_bind v arg ifnot) + | _,_,_ -> bind Alias v arg lam + end +| Lswitch (ls,({sw_consts=[i,act] ; sw_blocks = []} as sw)) + when not (approx_present v ls) -> + Lswitch (ls, {sw with sw_consts = [i,lower_bind v arg act]}) +| Lswitch (ls,({sw_consts=[] ; sw_blocks = [i,act]} as sw)) + when not (approx_present v ls) -> + Lswitch (ls, {sw with sw_blocks = [i,lower_bind v arg act]}) +| Llet (Alias, vv, lv, l) -> + if approx_present v lv then + bind Alias v arg lam + else + Llet (Alias, vv, lv, lower_bind v arg l) +| _ -> + bind Alias v arg lam + +let bind_check str v arg lam = match str,arg with +| _, Lvar _ ->bind str v arg lam +| Alias,_ -> lower_bind v arg lam +| _,_ -> bind str v arg lam + +let rec comp_exit ctx m = match m.default with +| (_,i)::_ -> Lstaticraise (i,[]), jumps_singleton i ctx +| _ -> fatal_error "Matching.comp_exit" + + + +let rec comp_match_handlers comp_fun partial ctx arg first_match next_matchs = match next_matchs with + | [] -> comp_fun partial ctx arg first_match + | rem -> + let rec c_rec body total_body = function + | [] -> body, total_body + (* Hum, -1 meant never taken + | (-1,pm)::rem -> c_rec body total_body rem *) + | (i,pm)::rem -> + let ctx_i,total_rem = jumps_extract i total_body in + begin match ctx_i with + | [] -> c_rec body total_body rem + | _ -> + try + let li,total_i = + comp_fun + (match rem with [] -> partial | _ -> Partial) + ctx_i arg pm in + c_rec + (Lstaticcatch (body,(i,[]),li)) + (jumps_union total_i total_rem) + rem + with + | Unused -> + c_rec (Lstaticcatch (body,(i,[]),lambda_unit)) + total_rem rem + end in + try + let first_lam,total = comp_fun Partial ctx arg first_match in + c_rec first_lam total rem + with Unused -> match next_matchs with + | [] -> raise Unused + | (_,x)::xs -> comp_match_handlers comp_fun partial ctx arg x xs + +(* To find reasonable names for variables *) + +let rec name_pattern default = function + (pat :: patl, action) :: rem -> + begin match pat.pat_desc with + Tpat_var id -> id + | Tpat_alias(p, id) -> id + | _ -> name_pattern default rem + end + | _ -> Ident.create default + +let arg_to_var arg cls = match arg with +| Lvar v -> v,arg +| _ -> + let v = name_pattern "match" cls in + v,Lvar v + + +(* + The main compilation function. + Input: + repr=used for inserting debug events + partial=exhaustiveness information from Parmatch + ctx=a context + m=a pattern matching + + Output: a lambda term, a jump summary {..., exit number -> context, .. } +*) + + +let rec compile_match repr partial ctx m = match m with +| { cases = [] } -> comp_exit ctx m +| { cases = ([], action) :: rem } -> + if is_guarded action then begin + let (lambda, total) = + compile_match None partial ctx { m with cases = rem } in + event_branch repr (patch_guarded lambda action), total + end else + (event_branch repr action, jumps_empty) +| { args = (arg, str)::argl } -> + let v,newarg = arg_to_var arg m.cases in + let first_match,rem = + split_precompile (Some v) + { m with args = (newarg, Alias) :: argl } in + let (lam, total) = + comp_match_handlers + (do_compile_matching repr) partial ctx newarg first_match rem in + bind_check str v arg lam, total +| _ -> assert false + + +(* verbose version of do_compile_matching, for debug *) +(* +and do_compile_matching_pr repr partial ctx arg x = + prerr_string "COMPILE: " ; + prerr_endline (match partial with Partial -> "Partial" | Total -> "Total") ; + prerr_endline "MATCH" ; + pretty_ext x ; + prerr_endline "CTX" ; + pretty_ctx ctx ; + let (_, jumps) as r = do_compile_matching repr partial ctx arg x in + prerr_endline "JUMPS" ; + pretty_jumps jumps ; + r +*) + +and do_compile_matching repr partial ctx arg pmh = match pmh with +| Pm pm -> + let pat = what_is_cases pm.cases in + begin match pat.pat_desc with + | Tpat_any -> + compile_no_test + divide_var ctx_rshift repr partial ctx pm + | Tpat_tuple patl -> + compile_no_test + (divide_tuple (List.length patl) (normalize_pat pat)) ctx_combine + repr partial ctx pm + | Tpat_record ((lbl,_)::_) -> + compile_no_test + (divide_record lbl.lbl_all (normalize_pat pat)) + ctx_combine repr partial ctx pm + | Tpat_constant cst -> + compile_test + (compile_match repr partial) partial + divide_constant + (combine_constant arg cst partial) + ctx pm + | Tpat_construct (cstr, _) -> + compile_test + (compile_match repr partial) partial + divide_constructor (combine_constructor arg pat cstr partial) + ctx pm + | Tpat_array _ -> + let kind = Typeopt.array_pattern_kind pat in + compile_test (compile_match repr partial) partial + (divide_array kind) (combine_array arg kind partial) + ctx pm + | Tpat_variant(lab, _, row) -> + compile_test (compile_match repr partial) partial + (divide_variant row) + (combine_variant row arg partial) + ctx pm + | _ -> assert false + end +| PmVar {inside=pmh ; var_arg=arg} -> + let lam, total = + do_compile_matching repr partial (ctx_lshift ctx) arg pmh in + lam, jumps_map ctx_rshift total +| PmOr {body=body ; handlers=handlers} -> + let lam, total = compile_match repr partial ctx body in + compile_orhandlers (compile_match repr partial) lam total ctx handlers + +and compile_no_test divide up_ctx repr partial ctx to_match = + let {pm=this_match ; ctx=this_ctx } = divide ctx to_match in + let lambda,total = compile_match repr partial this_ctx this_match in + lambda, jumps_map up_ctx total + + + + +(* The entry points *) + + +(* had toplevel handler when appropriate *) + +let start_ctx n = [{left=[] ; right = omegas n}] + +let check_total total lambda i handler_fun = + if jumps_is_empty total then + lambda + else begin + Lstaticcatch(lambda, (i,[]), handler_fun()) + end + +let compile_matching loc repr handler_fun arg pat_act_list partial = + match partial with + | Partial -> + let raise_num = next_raise_count () in + let pm = + { cases = List.map (fun (pat, act) -> ([pat], act)) pat_act_list; + args = [arg, Strict] ; + default = [[[omega]],raise_num]} in + begin try + let (lambda, total) = compile_match repr partial (start_ctx 1) pm in + check_total total lambda raise_num handler_fun + with + | Unused -> assert false ; handler_fun() + end + | Total -> + let pm = + { cases = List.map (fun (pat, act) -> ([pat], act)) pat_act_list; + args = [arg, Strict] ; + default = []} in + let (lambda, total) = compile_match repr partial (start_ctx 1) pm in + assert (jumps_is_empty total) ; + lambda + +let partial_function loc () = + (* [Location.get_pos_info] is too expensive *) + let fname = match loc.Location.loc_start.Lexing.pos_fname with + | "" -> !Location.input_name + | x -> x + in + let pos = loc.Location.loc_start in + let line = pos.Lexing.pos_lnum in + let char = pos.Lexing.pos_cnum - pos.Lexing.pos_bol in + Lprim(Praise, [Lprim(Pmakeblock(0, Immutable), + [transl_path Predef.path_match_failure; + Lconst(Const_block(0, + [Const_base(Const_string fname); + Const_base(Const_int line); + Const_base(Const_int char)]))])]) + +let for_function loc repr param pat_act_list partial = + compile_matching loc repr (partial_function loc) param pat_act_list partial + +(* In the following two cases, exhaustiveness info is not available! *) +let for_trywith param pat_act_list = + compile_matching Location.none None (fun () -> Lprim(Praise, [param])) + param pat_act_list Partial + +let for_let loc param pat body = + compile_matching loc None (partial_function loc) param [pat, body] Partial + +(* Handling of tupled functions and matchings *) + +(* Easy case since variables are available *) +let for_tupled_function loc paraml pats_act_list partial = + let raise_num = next_raise_count () in + let omegas = [List.map (fun _ -> omega) paraml] in + let pm = + { cases = pats_act_list; + args = List.map (fun id -> (Lvar id, Strict)) paraml ; + default = [omegas,raise_num] + } in + try + let (lambda, total) = compile_match None partial + (start_ctx (List.length paraml)) pm in + check_total total lambda raise_num (partial_function loc) + with + | Unused -> partial_function loc () + + + +let flatten_pattern size p = match p.pat_desc with +| Tpat_tuple args -> args +| Tpat_any -> omegas size +| _ -> raise Cannot_flatten + +let rec flatten_pat_line size p k = match p.pat_desc with +| Tpat_any -> omegas size::k +| Tpat_tuple args -> args::k +| Tpat_or (p1,p2,_) -> flatten_pat_line size p1 (flatten_pat_line size p2 k) +| _ -> fatal_error "Matching.flatten_pat_line" + +let flatten_cases size cases = + List.map + (fun (ps,action) -> match ps with + | [p] -> flatten_pattern size p,action + | _ -> fatal_error "Matching.flatten_case") + cases + +let flatten_matrix size pss = + List.fold_right + (fun ps r -> match ps with + | [p] -> flatten_pat_line size p r + | _ -> fatal_error "Matching.flatten_matrix") + pss [] + +let flatten_def size def = + List.map + (fun (pss,i) -> flatten_matrix size pss,i) + def + +let flatten_pm size args pm = + {args = args ; cases = flatten_cases size pm.cases ; + default = flatten_def size pm.default} + + +let rec flatten_precompiled size args pmh = match pmh with +| Pm pm -> Pm (flatten_pm size args pm) +| PmOr {body=b ; handlers=hs ; or_matrix=m} -> + PmOr + {body=flatten_pm size args b ; + handlers= + List.map + (fun (mat,i,vars,pm) -> flatten_matrix size mat,i,vars,pm) + hs ; + or_matrix=flatten_matrix size m ;} +| PmVar _ -> assert false + +(* + compiled_flattened is a ``comp_fun'' argument to comp_match_handlers. + Hence it needs a fourth argument, which it ignores +*) + +let compile_flattened repr partial ctx _ pmh = match pmh with +| Pm pm -> compile_match repr partial ctx pm +| PmOr {body=b ; handlers=hs} -> + let lam, total = compile_match repr partial ctx b in + compile_orhandlers (compile_match repr partial) lam total ctx hs +| PmVar _ -> assert false + +let for_multiple_match loc paraml pat_act_list partial = + let repr = None in + let raise_num,pm1 = + match partial with + | Partial -> + let raise_num = next_raise_count () in + raise_num, + { cases = List.map (fun (pat, act) -> ([pat], act)) pat_act_list; + args = [Lprim(Pmakeblock(0, Immutable), paraml), Strict] ; + default = [[[omega]],raise_num] } + | _ -> + -1, + { cases = List.map (fun (pat, act) -> ([pat], act)) pat_act_list; + args = [Lprim(Pmakeblock(0, Immutable), paraml), Strict] ; + default = [] } in + + try + try +(* Once for checking that compilation is possible *) + let next, nexts = split_precompile None pm1 in + + let size = List.length paraml + and idl = List.map (fun _ -> Ident.create "match") paraml in + let args = List.map (fun id -> Lvar id, Alias) idl in + + let flat_next = flatten_precompiled size args next + and flat_nexts = + List.map + (fun (e,pm) -> e,flatten_precompiled size args pm) + nexts in + + let lam, total = + comp_match_handlers + (compile_flattened repr) + partial (start_ctx size) () flat_next flat_nexts in + List.fold_right2 (bind Strict) idl paraml + (match partial with + | Partial -> + check_total total lam raise_num (partial_function loc) + | Total -> + assert (jumps_is_empty total) ; + lam) + + + with Cannot_flatten -> + let (lambda, total) = compile_match None partial (start_ctx 1) pm1 in + begin match partial with + | Partial -> + check_total total lambda raise_num (partial_function loc) + | Total -> + assert (jumps_is_empty total) ; + lambda + end + with Unused -> + assert false ; partial_function loc () + diff --git a/bytecomp/matching.mli b/bytecomp/matching.mli new file mode 100644 index 00000000..17ee17ac --- /dev/null +++ b/bytecomp/matching.mli @@ -0,0 +1,37 @@ +(***********************************************************************) +(* *) +(* 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: matching.mli,v 1.11 2001/02/19 20:27:35 maranget Exp $ *) + +(* Compilation of pattern-matching *) + +open Typedtree +open Lambda + +val for_function: + Location.t -> int ref option -> lambda -> (pattern * lambda) list -> + partial -> lambda +val for_trywith: + lambda -> (pattern * lambda) list -> lambda +val for_let: + Location.t -> lambda -> pattern -> lambda -> lambda +val for_multiple_match: + Location.t -> lambda list -> (pattern * lambda) list -> partial -> + lambda + +val for_tupled_function: + Location.t -> Ident.t list -> (pattern list * lambda) list -> + partial -> lambda + +exception Cannot_flatten + +val flatten_pattern: int -> pattern -> pattern list diff --git a/bytecomp/meta.ml b/bytecomp/meta.ml new file mode 100644 index 00000000..50f5aff1 --- /dev/null +++ b/bytecomp/meta.ml @@ -0,0 +1,23 @@ +(***********************************************************************) +(* *) +(* 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: meta.ml,v 1.9 2001/08/28 14:47:07 xleroy Exp $ *) + +external global_data : unit -> Obj.t array = "get_global_data" +external realloc_global_data : int -> unit = "realloc_global" +external static_alloc : int -> string = "static_alloc" +external static_free : string -> unit = "static_free" +external static_resize : string -> int -> string = "static_resize" +type closure = unit -> Obj.t +external reify_bytecode : string -> int -> closure = "reify_bytecode" +external invoke_traced_function : Obj.t -> Obj.t -> Obj.t -> Obj.t + = "invoke_traced_function" diff --git a/bytecomp/meta.mli b/bytecomp/meta.mli new file mode 100644 index 00000000..b86dee4f --- /dev/null +++ b/bytecomp/meta.mli @@ -0,0 +1,25 @@ +(***********************************************************************) +(* *) +(* 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: meta.mli,v 1.9 2001/08/28 14:47:07 xleroy Exp $ *) + +(* To control the runtime system and bytecode interpreter *) + +external global_data : unit -> Obj.t array = "get_global_data" +external realloc_global_data : int -> unit = "realloc_global" +external static_alloc : int -> string = "static_alloc" +external static_free : string -> unit = "static_free" +external static_resize : string -> int -> string = "static_resize" +type closure = unit -> Obj.t +external reify_bytecode : string -> int -> closure = "reify_bytecode" +external invoke_traced_function : Obj.t -> Obj.t -> Obj.t -> Obj.t + = "invoke_traced_function" diff --git a/bytecomp/printinstr.ml b/bytecomp/printinstr.ml new file mode 100644 index 00000000..6594eb26 --- /dev/null +++ b/bytecomp/printinstr.ml @@ -0,0 +1,111 @@ +(***********************************************************************) +(* *) +(* 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: printinstr.ml,v 1.21 2002/11/02 22:36:42 doligez Exp $ *) + +(* Pretty-print lists of instructions *) + +open Format +open Lambda +open Instruct + +let instruction ppf = function + | Klabel lbl -> fprintf ppf "L%i:" lbl + | Kacc n -> fprintf ppf "\tacc %i" n + | Kenvacc n -> fprintf ppf "\tenvacc %i" n + | Kpush -> fprintf ppf "\tpush" + | Kpop n -> fprintf ppf "\tpop %i" n + | Kassign n -> fprintf ppf "\tassign %i" n + | Kpush_retaddr lbl -> fprintf ppf "\tpush_retaddr L%i" lbl + | Kapply n -> fprintf ppf "\tapply %i" n + | Kappterm(n, m) -> + fprintf ppf "\tappterm %i, %i" n m + | Kreturn n -> fprintf ppf "\treturn %i" n + | Krestart -> fprintf ppf "\trestart" + | Kgrab n -> fprintf ppf "\tgrab %i" n + | Kclosure(lbl, n) -> + fprintf ppf "\tclosure L%i, %i" lbl n + | Kclosurerec(lbls, n) -> + fprintf ppf "\tclosurerec"; + List.iter (fun lbl -> fprintf ppf " %i" lbl) lbls; + fprintf ppf ", %i" n + | Koffsetclosure n -> fprintf ppf "\toffsetclosure %i" n + | Kgetglobal id -> fprintf ppf "\tgetglobal %a" Ident.print id + | Ksetglobal id -> fprintf ppf "\tsetglobal %a" Ident.print id + | Kconst cst -> + fprintf ppf "@[<10>\tconst@ %a@]" Printlambda.structured_constant cst + | Kmakeblock(n, m) -> + fprintf ppf "\tmakeblock %i, %i" n m + | Kmakefloatblock(n) -> + fprintf ppf "\tmakefloatblock %i" n + | Kgetfield n -> fprintf ppf "\tgetfield %i" n + | Ksetfield n -> fprintf ppf "\tsetfield %i" n + | Kgetfloatfield n -> fprintf ppf "\tgetfloatfield %i" n + | Ksetfloatfield n -> fprintf ppf "\tsetfloatfield %i" n + | Kvectlength -> fprintf ppf "\tvectlength" + | Kgetvectitem -> fprintf ppf "\tgetvectitem" + | Ksetvectitem -> fprintf ppf "\tsetvectitem" + | Kgetstringchar -> fprintf ppf "\tgetstringchar" + | Ksetstringchar -> fprintf ppf "\tsetstringchar" + | Kbranch lbl -> fprintf ppf "\tbranch L%i" lbl + | Kbranchif lbl -> fprintf ppf "\tbranchif L%i" lbl + | Kbranchifnot lbl -> fprintf ppf "\tbranchifnot L%i" lbl + | Kstrictbranchif lbl -> fprintf ppf "\tstrictbranchif L%i" lbl + | Kstrictbranchifnot lbl -> + fprintf ppf "\tstrictbranchifnot L%i" lbl + | Kswitch(consts, blocks) -> + let labels ppf labs = + Array.iter (fun lbl -> fprintf ppf "@ %i" lbl) labs in + fprintf ppf "@[<10>\tswitch%a/%a@]" labels consts labels blocks + | Kboolnot -> fprintf ppf "\tboolnot" + | Kpushtrap lbl -> fprintf ppf "\tpushtrap L%i" lbl + | Kpoptrap -> fprintf ppf "\tpoptrap" + | Kraise -> fprintf ppf "\traise" + | Kcheck_signals -> fprintf ppf "\tcheck_signals" + | Kccall(s, n) -> + fprintf ppf "\tccall %s, %i" s n + | Knegint -> fprintf ppf "\tnegint" + | Kaddint -> fprintf ppf "\taddint" + | Ksubint -> fprintf ppf "\tsubint" + | Kmulint -> fprintf ppf "\tmulint" + | Kdivint -> fprintf ppf "\tdivint" + | Kmodint -> fprintf ppf "\tmodint" + | Kandint -> fprintf ppf "\tandint" + | Korint -> fprintf ppf "\torint" + | Kxorint -> fprintf ppf "\txorint" + | Klslint -> fprintf ppf "\tlslint" + | Klsrint -> fprintf ppf "\tlsrint" + | Kasrint -> fprintf ppf "\tasrint" + | Kintcomp Ceq -> fprintf ppf "\teqint" + | Kintcomp Cneq -> fprintf ppf "\tneqint" + | Kintcomp Clt -> fprintf ppf "\tltint" + | Kintcomp Cgt -> fprintf ppf "\tgtint" + | Kintcomp Cle -> fprintf ppf "\tleint" + | Kintcomp Cge -> fprintf ppf "\tgeint" + | Koffsetint n -> fprintf ppf "\toffsetint %i" n + | Koffsetref n -> fprintf ppf "\toffsetref %i" n + | Kisint -> fprintf ppf "\tisint" + | Kisout -> fprintf ppf "\tisout" + | Kgetmethod -> fprintf ppf "\tgetmethod" + | Kstop -> fprintf ppf "\tstop" + | Kevent ev -> fprintf ppf "\tevent \"%s\" %i" ev.ev_char.Lexing.pos_fname + ev.ev_char.Lexing.pos_cnum + +let rec instruction_list ppf = function + [] -> () + | Klabel lbl :: il -> + fprintf ppf "L%i:%a" lbl instruction_list il + | instr :: il -> + fprintf ppf "%a@ %a" instruction instr instruction_list il + +let instrlist ppf il = + fprintf ppf "@[%a@]" instruction_list il diff --git a/bytecomp/printinstr.mli b/bytecomp/printinstr.mli new file mode 100644 index 00000000..04250d8e --- /dev/null +++ b/bytecomp/printinstr.mli @@ -0,0 +1,22 @@ +(***********************************************************************) +(* *) +(* 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: printinstr.mli,v 1.5 2000/03/06 22:11:08 weis Exp $ *) + +(* Pretty-print lists of instructions *) + +open Instruct + +open Format + +val instruction: formatter -> instruction -> unit +val instrlist: formatter -> instruction list -> unit diff --git a/bytecomp/printlambda.ml b/bytecomp/printlambda.ml new file mode 100644 index 00000000..63658dc2 --- /dev/null +++ b/bytecomp/printlambda.ml @@ -0,0 +1,299 @@ +(***********************************************************************) +(* *) +(* 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: printlambda.ml,v 1.48 2003/04/25 12:27:30 xleroy Exp $ *) + +open Format +open Asttypes +open Primitive +open Types +open Lambda + + +let rec struct_const ppf = function + | Const_base(Const_int n) -> fprintf ppf "%i" n + | Const_base(Const_char c) -> fprintf ppf "%C" c + | Const_base(Const_string s) -> fprintf ppf "%S" s + | Const_base(Const_float f) -> fprintf ppf "%s" f + | Const_base(Const_int32 n) -> fprintf ppf "%lil" n + | Const_base(Const_int64 n) -> fprintf ppf "%LiL" n + | Const_base(Const_nativeint n) -> fprintf ppf "%nin" n + | Const_pointer n -> fprintf ppf "%ia" n + | Const_block(tag, []) -> + fprintf ppf "[%i]" tag + | Const_block(tag, sc1::scl) -> + let sconsts ppf scl = + List.iter (fun sc -> fprintf ppf "@ %a" struct_const sc) scl in + fprintf ppf "@[<1>[%i:@ @[%a%a@]]@]" tag struct_const sc1 sconsts scl + | Const_float_array [] -> + fprintf ppf "[| |]" + | Const_float_array (f1 :: fl) -> + let floats ppf fl = + List.iter (fun f -> fprintf ppf "@ %s" f) fl in + fprintf ppf "@[<1>[|@[%s%a@]|]@]" f1 floats fl + +let boxed_integer_name = function + | Pnativeint -> "nativeint" + | Pint32 -> "int32" + | Pint64 -> "int64" + +let print_boxed_integer name ppf bi = + fprintf ppf "%s_%s" (boxed_integer_name bi) name + +let print_boxed_integer_conversion ppf bi1 bi2 = + fprintf ppf "%s_of_%s" (boxed_integer_name bi2) (boxed_integer_name bi1) + +let boxed_integer_mark name = function + | Pnativeint -> Printf.sprintf "Nativeint.%s" name + | Pint32 -> Printf.sprintf "Int32.%s" name + | Pint64 -> Printf.sprintf "Int64.%s" name + +let print_boxed_integer name ppf bi = + fprintf ppf "%s" (boxed_integer_mark name bi);; + +let print_bigarray name kind ppf layout = + fprintf ppf "Bigarray.%s[%s,%s]" + name + (match kind with + | Pbigarray_unknown -> "generic" + | Pbigarray_float32 -> "float32" + | Pbigarray_float64 -> "float64" + | Pbigarray_sint8 -> "sint8" + | Pbigarray_uint8 -> "uint8" + | Pbigarray_sint16 -> "sint16" + | Pbigarray_uint16 -> "uint16" + | Pbigarray_int32 -> "int32" + | Pbigarray_int64 -> "int64" + | Pbigarray_caml_int -> "camlint" + | Pbigarray_native_int -> "nativeint" + | Pbigarray_complex32 -> "complex32" + | Pbigarray_complex64 -> "complex64") + (match layout with + | Pbigarray_unknown_layout -> "unknown" + | Pbigarray_c_layout -> "C" + | Pbigarray_fortran_layout -> "Fortran") + +let primitive ppf = function + | Pidentity -> fprintf ppf "id" + | Pignore -> fprintf ppf "ignore" + | Pgetglobal id -> fprintf ppf "global %a" Ident.print id + | Psetglobal id -> fprintf ppf "setglobal %a" Ident.print id + | Pmakeblock(tag, Immutable) -> fprintf ppf "makeblock %i" tag + | Pmakeblock(tag, Mutable) -> fprintf ppf "makemutable %i" tag + | Pfield n -> fprintf ppf "field %i" n + | Psetfield(n, ptr) -> + let instr = if ptr then "setfield_ptr " else "setfield_imm " in + fprintf ppf "%s%i" instr n + | Pfloatfield n -> fprintf ppf "floatfield %i" n + | Psetfloatfield n -> fprintf ppf "setfloatfield %i" n + | Pccall p -> fprintf ppf "%s" p.prim_name + | Praise -> fprintf ppf "raise" + | Psequand -> fprintf ppf "&&" + | Psequor -> fprintf ppf "||" + | Pnot -> fprintf ppf "not" + | Pnegint -> fprintf ppf "~" + | Paddint -> fprintf ppf "+" + | Psubint -> fprintf ppf "-" + | Pmulint -> fprintf ppf "*" + | Pdivint -> fprintf ppf "/" + | Pmodint -> fprintf ppf "mod" + | Pandint -> fprintf ppf "and" + | Porint -> fprintf ppf "or" + | Pxorint -> fprintf ppf "xor" + | Plslint -> fprintf ppf "lsl" + | Plsrint -> fprintf ppf "lsr" + | Pasrint -> fprintf ppf "asr" + | Pintcomp(Ceq) -> fprintf ppf "==" + | Pintcomp(Cneq) -> fprintf ppf "!=" + | Pintcomp(Clt) -> fprintf ppf "<" + | Pintcomp(Cle) -> fprintf ppf "<=" + | Pintcomp(Cgt) -> fprintf ppf ">" + | Pintcomp(Cge) -> fprintf ppf ">=" + | Poffsetint n -> fprintf ppf "%i+" n + | Poffsetref n -> fprintf ppf "+:=%i"n + | Pintoffloat -> fprintf ppf "int_of_float" + | Pfloatofint -> fprintf ppf "float_of_int" + | Pnegfloat -> fprintf ppf "~." + | Pabsfloat -> fprintf ppf "abs." + | Paddfloat -> fprintf ppf "+." + | Psubfloat -> fprintf ppf "-." + | Pmulfloat -> fprintf ppf "*." + | Pdivfloat -> fprintf ppf "/." + | Pfloatcomp(Ceq) -> fprintf ppf "==." + | Pfloatcomp(Cneq) -> fprintf ppf "!=." + | Pfloatcomp(Clt) -> fprintf ppf "<." + | Pfloatcomp(Cle) -> fprintf ppf "<=." + | Pfloatcomp(Cgt) -> fprintf ppf ">." + | Pfloatcomp(Cge) -> fprintf ppf ">=." + | Pstringlength -> fprintf ppf "string.length" + | Pstringrefu -> fprintf ppf "string.unsafe_get" + | Pstringsetu -> fprintf ppf "string.unsafe_set" + | Pstringrefs -> fprintf ppf "string.get" + | Pstringsets -> fprintf ppf "string.set" + | Parraylength _ -> fprintf ppf "array.length" + | Pmakearray _ -> fprintf ppf "makearray " + | Parrayrefu _ -> fprintf ppf "array.unsafe_get" + | Parraysetu _ -> fprintf ppf "array.unsafe_set" + | Parrayrefs _ -> fprintf ppf "array.get" + | Parraysets _ -> fprintf ppf "array.set" + | Pisint -> fprintf ppf "isint" + | Pisout -> fprintf ppf "isout" + | Pbittest -> fprintf ppf "testbit" + | Pbintofint bi -> print_boxed_integer "of_int" ppf bi + | Pintofbint bi -> print_boxed_integer "to_int" ppf bi + | Pcvtbint (bi1, bi2) -> print_boxed_integer_conversion ppf bi1 bi2 + | Pnegbint bi -> print_boxed_integer "neg" ppf bi + | Paddbint bi -> print_boxed_integer "add" ppf bi + | Psubbint bi -> print_boxed_integer "sub" ppf bi + | Pmulbint bi -> print_boxed_integer "mul" ppf bi + | Pdivbint bi -> print_boxed_integer "div" ppf bi + | Pmodbint bi -> print_boxed_integer "mod" ppf bi + | Pandbint bi -> print_boxed_integer "and" ppf bi + | Porbint bi -> print_boxed_integer "or" ppf bi + | Pxorbint bi -> print_boxed_integer "xor" ppf bi + | Plslbint bi -> print_boxed_integer "lsl" ppf bi + | Plsrbint bi -> print_boxed_integer "lsr" ppf bi + | Pasrbint bi -> print_boxed_integer "asr" ppf bi + | Pbintcomp(bi, Ceq) -> print_boxed_integer "==" ppf bi + | Pbintcomp(bi, Cneq) -> print_boxed_integer "!=" ppf bi + | Pbintcomp(bi, Clt) -> print_boxed_integer "<" ppf bi + | Pbintcomp(bi, Cgt) -> print_boxed_integer ">" ppf bi + | Pbintcomp(bi, Cle) -> print_boxed_integer "<=" ppf bi + | Pbintcomp(bi, Cge) -> print_boxed_integer ">=" ppf bi + | Pbigarrayref(n, kind, layout) -> print_bigarray "get" kind ppf layout + | Pbigarrayset(n, kind, layout) -> print_bigarray "set" kind ppf layout + +let rec lam ppf = function + | Lvar id -> + Ident.print ppf id + | Lconst cst -> + struct_const ppf cst + | Lapply(lfun, largs) -> + let lams ppf largs = + List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in + fprintf ppf "@[<2>(apply@ %a%a)@]" lam lfun lams largs + | Lfunction(kind, params, body) -> + let pr_params ppf params = + match kind with + | Curried -> + List.iter (fun param -> fprintf ppf "@ %a" Ident.print param) params + | Tupled -> + fprintf ppf " ("; + let first = ref true in + List.iter + (fun param -> + if !first then first := false else fprintf ppf ",@ "; + Ident.print ppf param) + params; + fprintf ppf ")" in + fprintf ppf "@[<2>(function%a@ %a)@]" pr_params params lam body + | Llet(str, id, arg, body) -> + let rec letbody = function + | Llet(str, id, arg, body) -> + fprintf ppf "@ @[<2>%a@ %a@]" Ident.print id lam arg; + letbody body + | expr -> expr in + fprintf ppf "@[<2>(let@ @[(@[<2>%a@ %a@]" Ident.print id lam arg; + let expr = letbody body in + fprintf ppf ")@]@ %a)@]" lam expr + | Lletrec(id_arg_list, body) -> + let bindings ppf id_arg_list = + let spc = ref false in + List.iter + (fun (id, l) -> + if !spc then fprintf ppf "@ " else spc := true; + fprintf ppf "@[<2>%a@ %a@]" Ident.print id lam l) + id_arg_list in + fprintf ppf + "@[<2>(letrec@ (@[%a@])@ %a)@]" bindings id_arg_list lam body + | Lprim(prim, largs) -> + let lams ppf largs = + List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in + fprintf ppf "@[<2>(%a%a)@]" primitive prim lams largs + | Lswitch(larg, sw) -> + let switch ppf sw = + let spc = ref false in + List.iter + (fun (n, l) -> + if !spc then fprintf ppf "@ " else spc := true; + fprintf ppf "@[case int %i:@ %a@]" n lam l) + sw.sw_consts; + List.iter + (fun (n, l) -> + if !spc then fprintf ppf "@ " else spc := true; + fprintf ppf "@[case tag %i:@ %a@]" n lam l) + sw.sw_blocks ; + begin match sw.sw_failaction with + | None -> () + | Some l -> + if !spc then fprintf ppf "@ " else spc := true; + fprintf ppf "@[default:@ %a@]" lam l + end in + + fprintf ppf + "@[<1>(%s %a@ @[%a@])@]" + (match sw.sw_failaction with None -> "switch*" | _ -> "switch") + lam larg switch sw + | Lstaticraise (i, ls) -> + let lams ppf largs = + List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in + fprintf ppf "@[<2>(exit@ %d%a)@]" i lams ls; + | Lstaticcatch(lbody, (i, vars), lhandler) -> + fprintf ppf "@[<2>(catch@ %a@;<1 -1>with (%d%a)@ %a)@]" + lam lbody i + (fun ppf vars -> match vars with + | [] -> () + | _ -> + List.iter + (fun x -> fprintf ppf " %a" Ident.print x) + vars) + vars + lam lhandler + | Ltrywith(lbody, param, lhandler) -> + fprintf ppf "@[<2>(try@ %a@;<1 -1>with %a@ %a)@]" + lam lbody Ident.print param lam lhandler + | Lifthenelse(lcond, lif, lelse) -> + fprintf ppf "@[<2>(if@ %a@ %a@ %a)@]" lam lcond lam lif lam lelse + | Lsequence(l1, l2) -> + fprintf ppf "@[<2>(seq@ %a@ %a)@]" lam l1 sequence l2 + | Lwhile(lcond, lbody) -> + fprintf ppf "@[<2>(while@ %a@ %a)@]" lam lcond lam lbody + | Lfor(param, lo, hi, dir, body) -> + fprintf ppf "@[<2>(for %a@ %a@ %s@ %a@ %a)@]" + Ident.print param lam lo + (match dir with Upto -> "to" | Downto -> "downto") + lam hi lam body + | Lassign(id, expr) -> + fprintf ppf "@[<2>(assign@ %a@ %a)@]" Ident.print id lam expr + | Lsend (met, obj, largs) -> + let args ppf largs = + List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in + fprintf ppf "@[<2>(send@ %a@ %a%a)@]" lam obj lam met args largs + | Levent(expr, ev) -> + let kind = + match ev.lev_kind with + | Lev_before -> "before" + | Lev_after _ -> "after" + | Lev_function -> "funct-body" in + fprintf ppf "@[<2>(%s %i@ %a)@]" kind ev.lev_pos.Lexing.pos_cnum lam expr + | Lifused(id, expr) -> + fprintf ppf "@[<2>(ifused@ %a@ %a)@]" Ident.print id lam expr + +and sequence ppf = function + | Lsequence(l1, l2) -> + fprintf ppf "%a@ %a" sequence l1 sequence l2 + | l -> + lam ppf l + +let structured_constant = struct_const + +let lambda = lam diff --git a/bytecomp/printlambda.mli b/bytecomp/printlambda.mli new file mode 100644 index 00000000..8493e599 --- /dev/null +++ b/bytecomp/printlambda.mli @@ -0,0 +1,20 @@ +(***********************************************************************) +(* *) +(* 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: printlambda.mli,v 1.5 2000/03/06 22:11:10 weis Exp $ *) + +open Lambda + +open Format + +val structured_constant: formatter -> structured_constant -> unit +val lambda: formatter -> lambda -> unit diff --git a/bytecomp/runtimedef.mli b/bytecomp/runtimedef.mli new file mode 100644 index 00000000..38329db1 --- /dev/null +++ b/bytecomp/runtimedef.mli @@ -0,0 +1,18 @@ +(***********************************************************************) +(* *) +(* 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: runtimedef.mli,v 1.4 1999/11/17 18:57:01 xleroy Exp $ *) + +(* Values and functions known and/or provided by the runtime system *) + +val builtin_exceptions: string array +val builtin_primitives: string array diff --git a/bytecomp/simplif.ml b/bytecomp/simplif.ml new file mode 100644 index 00000000..7bef70d6 --- /dev/null +++ b/bytecomp/simplif.ml @@ -0,0 +1,412 @@ +(***********************************************************************) +(* *) +(* 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: simplif.ml,v 1.22 2001/04/23 12:46:21 maranget Exp $ *) + +(* Elimination of useless Llet(Alias) bindings. + Also transform let-bound references into variables. *) + +open Asttypes +open Lambda + +(* To transform let-bound references into variables *) + +exception Real_reference + +let rec eliminate_ref id = function + Lvar v as lam -> + if Ident.same v id then raise Real_reference else lam + | Lconst cst as lam -> lam + | Lapply(e1, el) -> + Lapply(eliminate_ref id e1, List.map (eliminate_ref id) el) + | Lfunction(kind, params, body) as lam -> + if IdentSet.mem id (free_variables lam) + then raise Real_reference + else lam + | Llet(str, v, e1, e2) -> + Llet(str, v, eliminate_ref id e1, eliminate_ref id e2) + | Lletrec(idel, e2) -> + Lletrec(List.map (fun (v, e) -> (v, eliminate_ref id e)) idel, + eliminate_ref id e2) + | Lprim(Pfield 0, [Lvar v]) when Ident.same v id -> + Lvar id + | Lprim(Psetfield(0, _), [Lvar v; e]) when Ident.same v id -> + Lassign(id, eliminate_ref id e) + | Lprim(Poffsetref delta, [Lvar v]) when Ident.same v id -> + Lassign(id, Lprim(Poffsetint delta, [Lvar id])) + | Lprim(p, el) -> + Lprim(p, List.map (eliminate_ref id) el) + | Lswitch(e, sw) -> + Lswitch(eliminate_ref id e, + {sw_numconsts = sw.sw_numconsts; + sw_consts = + List.map (fun (n, e) -> (n, eliminate_ref id e)) sw.sw_consts; + sw_numblocks = sw.sw_numblocks; + sw_blocks = + List.map (fun (n, e) -> (n, eliminate_ref id e)) sw.sw_blocks; + sw_failaction = match sw.sw_failaction with + | None -> None + | Some l -> Some (eliminate_ref id l)}) + | Lstaticraise (i,args) -> + Lstaticraise (i,List.map (eliminate_ref id) args) + | Lstaticcatch(e1, i, e2) -> + Lstaticcatch(eliminate_ref id e1, i, eliminate_ref id e2) + | Ltrywith(e1, v, e2) -> + Ltrywith(eliminate_ref id e1, v, eliminate_ref id e2) + | Lifthenelse(e1, e2, e3) -> + Lifthenelse(eliminate_ref id e1, + eliminate_ref id e2, + eliminate_ref id e3) + | Lsequence(e1, e2) -> + Lsequence(eliminate_ref id e1, eliminate_ref id e2) + | Lwhile(e1, e2) -> + Lwhile(eliminate_ref id e1, eliminate_ref id e2) + | Lfor(v, e1, e2, dir, e3) -> + Lfor(v, eliminate_ref id e1, eliminate_ref id e2, + dir, eliminate_ref id e3) + | Lassign(v, e) -> + Lassign(v, eliminate_ref id e) + | Lsend(m, o, el) -> + Lsend(eliminate_ref id m, eliminate_ref id o, + List.map (eliminate_ref id) el) + | Levent(l, ev) -> + Levent(eliminate_ref id l, ev) + | Lifused(v, e) -> + Lifused(v, eliminate_ref id e) + +(* Simplification of exits *) + +let simplify_exits lam = + + (* Count occurrences of (exit n ...) statements *) + let exits = Hashtbl.create 17 in + + let count_exit i = + try + !(Hashtbl.find exits i) + with + | Not_found -> 0 + + and incr_exit i = + try + incr (Hashtbl.find exits i) + with + | Not_found -> Hashtbl.add exits i (ref 1) in + + let rec count = function + | (Lvar _| Lconst _) -> () + | Lapply(l1, ll) -> count l1; List.iter count ll + | Lfunction(kind, params, l) -> count l + | Llet(str, v, l1, l2) -> + count l2; count l1 + | Lletrec(bindings, body) -> + List.iter (fun (v, l) -> count l) bindings; + count body + | Lprim(p, ll) -> List.iter count ll + | Lswitch(l, sw) -> + count_default sw ; + count l; + List.iter (fun (_, l) -> count l) sw.sw_consts; + List.iter (fun (_, l) -> count l) sw.sw_blocks + | Lstaticraise (i,ls) -> incr_exit i ; List.iter count ls + | Lstaticcatch (l1,(i,[]),Lstaticraise (j,[])) -> + (* i will be replaced by j in l1, so each occurence of i in l1 + increases j's ref count *) + count l1 ; + let ic = count_exit i in + begin try + let r = Hashtbl.find exits j in r := !r + ic + with + | Not_found -> + Hashtbl.add exits j (ref ic) + end + | Lstaticcatch(l1, (i,_), l2) -> + count l1; + (* If l1 does not contain (exit i), + l2 will be removed, so don't count its exits *) + if count_exit i > 0 then + count l2 + | Ltrywith(l1, v, l2) -> count l1; count l2 + | Lifthenelse(l1, l2, l3) -> count l1; count l2; count l3 + | Lsequence(l1, l2) -> count l1; count l2 + | Lwhile(l1, l2) -> count l1; count l2 + | Lfor(_, l1, l2, dir, l3) -> count l1; count l2; count l3 + | Lassign(v, l) -> + (* Lalias-bound variables are never assigned, so don't increase + v's refcount *) + count l + | Lsend(m, o, ll) -> List.iter count (m::o::ll) + | Levent(l, _) -> count l + | Lifused(v, l) -> count l + + and count_default sw = match sw.sw_failaction with + | None -> () + | Some al -> + let nconsts = List.length sw.sw_consts + and nblocks = List.length sw.sw_blocks in + if + nconsts < sw.sw_numconsts && nblocks < sw.sw_numblocks + then begin (* default action will occur twice in native code *) + count al ; count al + end else begin (* default action will occur once *) + assert (nconsts < sw.sw_numconsts || nblocks < sw.sw_numblocks) ; + count al + end + in + count lam; + + (* + Second pass simplify ``catch body with (i ...) handler'' + - if (exit i ...) does not occur in body, suppress catch + - if (exit i ...) occurs exactly once in body, + substitute it with handler + - If handler is a single variable, replace (exit i ..) with it + Note: + In ``catch body with (i x1 .. xn) handler'' + Substituted expression is + let y1 = x1 and ... yn = xn in + handler[x1 <- y1 ; ... ; xn <- yn] + For the sake of preserving the uniqueness of bound variables. + (No alpha conversion of ``handler'' is presently needed, since + substitution of several ``(exit i ...)'' + occurs only when ``handler'' is a variable.) + *) + + let subst = Hashtbl.create 17 in + + let rec simplif = function + | (Lvar _|Lconst _) as l -> l + | Lapply(l1, ll) -> Lapply(simplif l1, List.map simplif ll) + | Lfunction(kind, params, l) -> Lfunction(kind, params, simplif l) + | Llet(kind, v, l1, l2) -> Llet(kind, v, simplif l1, simplif l2) + | Lletrec(bindings, body) -> + Lletrec(List.map (fun (v, l) -> (v, simplif l)) bindings, simplif body) + | Lprim(p, ll) -> Lprim(p, List.map simplif ll) + | Lswitch(l, sw) -> + let new_l = simplif l + and new_consts = List.map (fun (n, e) -> (n, simplif e)) sw.sw_consts + and new_blocks = List.map (fun (n, e) -> (n, simplif e)) sw.sw_blocks + and new_fail = match sw.sw_failaction with + | None -> None + | Some l -> Some (simplif l) in + Lswitch + (new_l, + {sw with sw_consts = new_consts ; sw_blocks = new_blocks; + sw_failaction = new_fail}) + | Lstaticraise (i,[]) as l -> + begin try + let _,handler = Hashtbl.find subst i in + handler + with + | Not_found -> l + end + | Lstaticraise (i,ls) as l -> + let ls = List.map simplif ls in + begin try + let xs,handler = Hashtbl.find subst i in + let ys = List.map Ident.rename xs in + let env = + List.fold_right2 + (fun x y t -> Ident.add x (Lvar y) t) + xs ys Ident.empty in + List.fold_right2 + (fun y l r -> Llet (Alias, y, l, r)) + ys ls (Lambda.subst_lambda env handler) + with + | Not_found -> l + end + | Lstaticcatch (l1,(i,[]),(Lstaticraise (j,[]) as l2)) -> + Hashtbl.add subst i ([],simplif l2) ; + simplif l1 + | Lstaticcatch (l1,(i,xs), (Lvar _ as l2)) -> + begin match count_exit i with + | 0 -> simplif l1 + | _ -> + Hashtbl.add subst i (xs,l2) ; + simplif l1 + end + | Lstaticcatch (l1,(i,xs),l2) -> + begin match count_exit i with + | 0 -> simplif l1 + | 1 -> + Hashtbl.add subst i (xs,simplif l2) ; + simplif l1 + | _ -> + Lstaticcatch (simplif l1, (i,xs), simplif l2) + end + | Ltrywith(l1, v, l2) -> Ltrywith(simplif l1, v, simplif l2) + | Lifthenelse(l1, l2, l3) -> Lifthenelse(simplif l1, simplif l2, simplif l3) + | Lsequence(l1, l2) -> Lsequence(simplif l1, simplif l2) + | Lwhile(l1, l2) -> Lwhile(simplif l1, simplif l2) + | Lfor(v, l1, l2, dir, l3) -> + Lfor(v, simplif l1, simplif l2, dir, simplif l3) + | Lassign(v, l) -> Lassign(v, simplif l) + | Lsend(m, o, ll) -> Lsend(simplif m, simplif o, List.map simplif ll) + | Levent(l, ev) -> Levent(simplif l, ev) + | Lifused(v, l) -> Lifused (v,simplif l) + in + simplif lam + +(* Simplification of lets *) + +let simplify_lets lam = + + (* First pass: count the occurrences of all identifiers *) + let occ = Hashtbl.create 83 in + let count_var v = + try + !(Hashtbl.find occ v) + with Not_found -> + 0 + and incr_var v = + try + incr(Hashtbl.find occ v) + with Not_found -> + Hashtbl.add occ v (ref 1) in + + let rec count = function + | Lvar v -> incr_var v + | Lconst cst -> () + | Lapply(l1, ll) -> count l1; List.iter count ll + | Lfunction(kind, params, l) -> count l + | Llet(str, v, Lvar w, l2) when not !Clflags.debug -> + (* v will be replaced by w in l2, so each occurrence of v in l2 + increases w's refcount *) + count l2; + let vc = count_var v in + begin try + let r = Hashtbl.find occ w in r := !r + vc + with Not_found -> + Hashtbl.add occ w (ref vc) + end + | Llet(str, v, l1, l2) -> + count l2; + (* If v is unused, l1 will be removed, so don't count its variables *) + if str = Strict || count_var v > 0 then count l1 + | Lletrec(bindings, body) -> + List.iter (fun (v, l) -> count l) bindings; + count body + | Lprim(p, ll) -> List.iter count ll + | Lswitch(l, sw) -> + count_default sw ; + count l; + List.iter (fun (_, l) -> count l) sw.sw_consts; + List.iter (fun (_, l) -> count l) sw.sw_blocks + | Lstaticraise (i,ls) -> List.iter count ls + | Lstaticcatch(l1, (i,_), l2) -> + count l1; count l2 + | Ltrywith(l1, v, l2) -> count l1; count l2 + | Lifthenelse(l1, l2, l3) -> count l1; count l2; count l3 + | Lsequence(l1, l2) -> count l1; count l2 + | Lwhile(l1, l2) -> count l1; count l2 + | Lfor(_, l1, l2, dir, l3) -> count l1; count l2; count l3 + | Lassign(v, l) -> + (* Lalias-bound variables are never assigned, so don't increase + v's refcount *) + count l + | Lsend(m, o, ll) -> List.iter count (m::o::ll) + | Levent(l, _) -> count l + | Lifused(v, l) -> + if count_var v > 0 then count l + + and count_default sw = match sw.sw_failaction with + | None -> () + | Some al -> + let nconsts = List.length sw.sw_consts + and nblocks = List.length sw.sw_blocks in + if + nconsts < sw.sw_numconsts && nblocks < sw.sw_numblocks + then begin (* default action will occur twice in native code *) + count al ; count al + end else begin (* default action will occur once *) + assert (nconsts < sw.sw_numconsts || nblocks < sw.sw_numblocks) ; + count al + end + in + count lam; + (* Second pass: remove Lalias bindings of unused variables, + and substitute the bindings of variables used exactly once. *) + + let subst = Hashtbl.create 83 in + + let rec simplif = function + Lvar v as l -> + begin try + Hashtbl.find subst v + with Not_found -> + l + end + | Lconst cst as l -> l + | Lapply(l1, ll) -> Lapply(simplif l1, List.map simplif ll) + | Lfunction(kind, params, l) -> Lfunction(kind, params, simplif l) + | Llet(str, v, Lvar w, l2) when not !Clflags.debug -> + Hashtbl.add subst v (simplif (Lvar w)); + simplif l2 + | Llet(Strict, v, Lprim(Pmakeblock(0, Mutable), [linit]), lbody) + when not !Clflags.debug -> + let slinit = simplif linit in + let slbody = simplif lbody in + begin try + Llet(Variable, v, slinit, eliminate_ref v slbody) + with Real_reference -> + Llet(Strict, v, Lprim(Pmakeblock(0, Mutable), [slinit]), slbody) + end + | Llet(Alias, v, l1, l2) -> + begin match count_var v with + 0 -> simplif l2 + | 1 when not !Clflags.debug -> + Hashtbl.add subst v (simplif l1); simplif l2 + | n -> Llet(Alias, v, simplif l1, simplif l2) + end + | Llet(StrictOpt, v, l1, l2) -> + begin match count_var v with + 0 -> simplif l2 + | n -> Llet(Alias, v, simplif l1, simplif l2) + end + | Llet(kind, v, l1, l2) -> Llet(kind, v, simplif l1, simplif l2) + | Lletrec(bindings, body) -> + Lletrec(List.map (fun (v, l) -> (v, simplif l)) bindings, simplif body) + | Lprim(p, ll) -> Lprim(p, List.map simplif ll) + | Lswitch(l, sw) -> + let new_l = simplif l + and new_consts = List.map (fun (n, e) -> (n, simplif e)) sw.sw_consts + and new_blocks = List.map (fun (n, e) -> (n, simplif e)) sw.sw_blocks + and new_fail = match sw.sw_failaction with + | None -> None + | Some l -> Some (simplif l) in + Lswitch + (new_l, + {sw with sw_consts = new_consts ; sw_blocks = new_blocks; + sw_failaction = new_fail}) + | Lstaticraise (i,ls) -> + Lstaticraise (i, List.map simplif ls) + | Lstaticcatch(l1, (i,args), l2) -> + Lstaticcatch (simplif l1, (i,args), simplif l2) + | Ltrywith(l1, v, l2) -> Ltrywith(simplif l1, v, simplif l2) + | Lifthenelse(l1, l2, l3) -> Lifthenelse(simplif l1, simplif l2, simplif l3) + | Lsequence(Lifused(v, l1), l2) -> + if count_var v > 0 + then Lsequence(simplif l1, simplif l2) + else simplif l2 + | Lsequence(l1, l2) -> Lsequence(simplif l1, simplif l2) + | Lwhile(l1, l2) -> Lwhile(simplif l1, simplif l2) + | Lfor(v, l1, l2, dir, l3) -> + Lfor(v, simplif l1, simplif l2, dir, simplif l3) + | Lassign(v, l) -> Lassign(v, simplif l) + | Lsend(m, o, ll) -> Lsend(simplif m, simplif o, List.map simplif ll) + | Levent(l, ev) -> Levent(simplif l, ev) + | Lifused(v, l) -> + if count_var v > 0 then simplif l else lambda_unit + in + simplif lam + +let simplify_lambda lam = simplify_lets (simplify_exits lam) diff --git a/bytecomp/simplif.mli b/bytecomp/simplif.mli new file mode 100644 index 00000000..16b1562f --- /dev/null +++ b/bytecomp/simplif.mli @@ -0,0 +1,19 @@ +(***********************************************************************) +(* *) +(* 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: simplif.mli,v 1.3 1999/11/17 18:57:01 xleroy Exp $ *) + +(* Elimination of useless Llet(Alias) bindings *) + +open Lambda + +val simplify_lambda: lambda -> lambda diff --git a/bytecomp/switch.ml b/bytecomp/switch.ml new file mode 100644 index 00000000..38db1d55 --- /dev/null +++ b/bytecomp/switch.ml @@ -0,0 +1,812 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Luc Maranget, 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. *) +(* *) +(***********************************************************************) + +(* Store for actions in object style *) +exception Found of int + +type 'a t_store = + {act_get : unit -> 'a array ; act_store : 'a -> int} + +let mk_store same = + let r_acts = ref [] in + let store act = + let rec store_rec i = function + | [] -> i,[act] + | act0::rem -> + if same act0 act then raise (Found i) + else + let i,rem = store_rec (i+1) rem in + i,act0::rem in + try + let i,acts = store_rec 0 !r_acts in + r_acts := acts ; + i + with + | Found i -> i + + and get () = Array.of_list !r_acts in + {act_store=store ; act_get=get} + + + +module type S = + sig + type primitive + val eqint : primitive + val neint : primitive + val leint : primitive + val ltint : primitive + val geint : primitive + val gtint : primitive + type act + + val bind : act -> (act -> act) -> act + val make_offset : act -> int -> act + val make_prim : primitive -> act list -> act + val make_isout : act -> act -> act + val make_isin : act -> act -> act + val make_if : act -> act -> act -> act + val make_switch : + act -> int array -> act array -> act + end + +(* The module will ``produce good code for the case statement'' *) +(* + Adaptation of + R.L. Berstein + ``Producing good code for the case statement'' + Sofware Practice and Experience, 15(10) (1985) + and + D.L. Spuler + ``Two-Way Comparison Search Trees, a Generalisation of Binary Search Trees + and Split Trees'' + ``Compiler Code Generation for Multiway Branch Statement as + a Static Search Problem'' + Technical Reports, James Cook University +*) +(* + Main adaptation is considering interval tests + (implemented as one addition + one unsigned test and branch) + which leads to exhaustive search for finding the optimal + test sequence in small cases and heuristics otherwise. +*) +module Make (Arg : S) = + struct + + type 'a inter = + {cases : (int * int * int) array ; + actions : 'a array} + +type 'a t_ctx = {off : int ; arg : 'a} + +let cut = ref 8 +and more_cut = ref 16 + +let pint chan i = + if i = min_int then Printf.fprintf chan "-oo" + else if i=max_int then Printf.fprintf chan "oo" + else Printf.fprintf chan "%d" i + +let pcases chan cases = + for i =0 to Array.length cases-1 do + let l,h,act = cases.(i) in + if l=h then + Printf.fprintf chan "%d:%d " l act + else + Printf.fprintf chan "%a..%a:%d " pint l pint h act + done + + let prerr_inter i = Printf.fprintf stderr + "cases=%a" pcases i.cases + +let get_act cases i = + let _,_,r = cases.(i) in + r +and get_low cases i = + let r,_,_ = cases.(i) in + r + +type ctests = { + mutable n : int ; + mutable ni : int ; + } + +let too_much = {n=max_int ; ni=max_int} + +let ptests chan {n=n ; ni=ni} = + Printf.fprintf chan "{n=%d ; ni=%d}" n ni + +let pta chan t = + for i =0 to Array.length t-1 do + Printf.fprintf chan "%d: %a\n" i ptests t.(i) + done + +let count_tests s = + let r = + Array.init + (Array.length s.actions) + (fun _ -> {n=0 ; ni=0 }) in + let c = s.cases in + let imax = Array.length c-1 in + for i=0 to imax do + let l,h,act = c.(i) in + let x = r.(act) in + x.n <- x.n+1 ; + if l < h && i<> 0 && i<>imax then + x.ni <- x.ni+1 ; + done ; + r + + +let less_tests c1 c2 = + if c1.n < c2.n then + true + else if c1.n = c2.n then begin + if c1.ni < c2.ni then + true + else + false + end else + false + +and eq_tests c1 c2 = c1.n = c2.n && c1.ni=c2.ni + +let min_tests c1 c2 = if less_tests c1 c2 then c1 else c2 + +let less2tests (c1,d1) (c2,d2) = + if eq_tests c1 c2 then + less_tests d1 d2 + else + less_tests c1 c2 + +let add_test t1 t2 = + t1.n <- t1.n + t2.n ; + t1.ni <- t1.ni + t2.ni ; + +type t_ret = Inter of int * int | Sep of int | No + +let pret chan = function + | Inter (i,j)-> Printf.fprintf chan "Inter %d %d" i j + | Sep i -> Printf.fprintf chan "Sep %d" i + | No -> Printf.fprintf chan "No" + +let coupe cases i = + let l,_,_ = cases.(i) in + l, + Array.sub cases 0 i, + Array.sub cases i (Array.length cases-i) + + +let case_append c1 c2 = + let len1 = Array.length c1 + and len2 = Array.length c2 in + match len1,len2 with + | 0,_ -> c2 + | _,0 -> c1 + | _,_ -> + let l1,h1,act1 = c1.(Array.length c1-1) + and l2,h2,act2 = c2.(0) in + if act1 = act2 then + let r = Array.create (len1+len2-1) c1.(0) in + for i = 0 to len1-2 do + r.(i) <- c1.(i) + done ; + + let l = + if len1-2 >= 0 then begin + let _,h,_ = r.(len1-2) in + if h+1 < l1 then + h+1 + else + l1 + end else + l1 + and h = + if 1 < len2-1 then begin + let l,_,_ = c2.(1) in + if h2+1 < l then + l-1 + else + h2 + end else + h2 in + r.(len1-1) <- (l,h,act1) ; + for i=1 to len2-1 do + r.(len1-1+i) <- c2.(i) + done ; + r + else if h1 > l1 then + let r = Array.create (len1+len2) c1.(0) in + for i = 0 to len1-2 do + r.(i) <- c1.(i) + done ; + r.(len1-1) <- (l1,l2-1,act1) ; + for i=0 to len2-1 do + r.(len1+i) <- c2.(i) + done ; + r + else if h2 > l2 then + let r = Array.create (len1+len2) c1.(0) in + for i = 0 to len1-1 do + r.(i) <- c1.(i) + done ; + r.(len1) <- (h1+1,h2,act2) ; + for i=1 to len2-1 do + r.(len1+i) <- c2.(i) + done ; + r + else + Array.append c1 c2 + + +let coupe_inter i j cases = + let lcases = Array.length cases in + let low,_,_ = cases.(i) + and _,high,_ = cases.(j) in + low,high, + Array.sub cases i (j-i+1), + case_append (Array.sub cases 0 i) (Array.sub cases (j+1) (lcases-(j+1))) + +type kind = Kvalue of int | Kinter of int | Kempty + +let pkind chan = function + | Kvalue i ->Printf.fprintf chan "V%d" i + | Kinter i -> Printf.fprintf chan "I%d" i + | Kempty -> Printf.fprintf chan "E" + +let rec pkey chan = function + | [] -> () + | [k] -> pkind chan k + | k::rem -> + Printf.fprintf chan "%a %a" pkey rem pkind k + +let t = Hashtbl.create 17 + +let make_key cases = + let seen = ref [] + and count = ref 0 in + let rec got_it act = function + | [] -> + seen := (act,!count):: !seen ; + let r = !count in + incr count ; + r + | (act0,index) :: rem -> + if act0 = act then + index + else + got_it act rem in + + let make_one l h act = + if l=h then + Kvalue (got_it act !seen) + else + Kinter (got_it act !seen) in + + let rec make_rec i pl = + if i < 0 then + [] + else + let l,h,act = cases.(i) in + if pl = h+1 then + make_one l h act::make_rec (i-1) l + else + Kempty::make_one l h act::make_rec (i-1) l in + + let l,h,act = cases.(Array.length cases-1) in + make_one l h act::make_rec (Array.length cases-2) l + + + let same_act t = + let len = Array.length t in + let a = get_act t (len-1) in + let rec do_rec i = + if i < 0 then true + else + let b = get_act t i in + b=a && do_rec (i-1) in + do_rec (len-2) + + +(* + Intervall test x in [l,h] works by checking x-l in [0,h-l] + * This may be false for arithmetic modulo 2^31 + * Subtracting l may change the relative ordering of values + and invalid the invariant that matched values are given in + increasing order + + To avoid this, interval check is allowed only when the + integers indeed present in the whole case interval are + in [-2^16 ; 2^16] + + This condition is checked by zyva +*) + +let inter_limit = 1 lsl 16 + +let ok_inter = ref false + +let rec opt_count top cases = + let key = make_key cases in + try + let r = Hashtbl.find t key in + r + with + | Not_found -> + let r = + let lcases = Array.length cases in + match lcases with + | 0 -> assert false + | _ when same_act cases -> No, ({n=0; ni=0},{n=0; ni=0}) + | _ -> + if lcases < !cut then + enum top cases + else if lcases < !more_cut then + heuristic top cases + else + divide top cases in + Hashtbl.add t key r ; + r + +and divide top cases = + let lcases = Array.length cases in + let m = lcases/2 in + let _,left,right = coupe cases m in + let ci = {n=1 ; ni=0} + and cm = {n=1 ; ni=0} + and _,(cml,cleft) = opt_count false left + and _,(cmr,cright) = opt_count false right in + add_test ci cleft ; + add_test ci cright ; + if less_tests cml cmr then + add_test cm cmr + else + add_test cm cml ; + Sep m,(cm, ci) + +and heuristic top cases = + let lcases = Array.length cases in + + let sep,csep = divide false cases + + and inter,cinter = + if !ok_inter then begin + let _,_,act0 = cases.(0) + and _,_,act1 = cases.(lcases-1) in + if act0 = act1 then begin + let low, high, inside, outside = coupe_inter 1 (lcases-2) cases in + let _,(cmi,cinside) = opt_count false inside + and _,(cmo,coutside) = opt_count false outside + and cmij = {n=1 ; ni=(if low=high then 0 else 1)} + and cij = {n=1 ; ni=(if low=high then 0 else 1)} in + add_test cij cinside ; + add_test cij coutside ; + if less_tests cmi cmo then + add_test cmij cmo + else + add_test cmij cmi ; + Inter (1,lcases-2),(cmij,cij) + end else + Inter (-1,-1),(too_much, too_much) + end else + Inter (-1,-1),(too_much, too_much) in + if less2tests csep cinter then + sep,csep + else + inter,cinter + + +and enum top cases = + let lcases = Array.length cases in + let lim, with_sep = + let best = ref (-1) and best_cost = ref (too_much,too_much) in + + for i = 1 to lcases-(1) do + let _,left,right = coupe cases i in + let ci = {n=1 ; ni=0} + and cm = {n=1 ; ni=0} + and _,(cml,cleft) = opt_count false left + and _,(cmr,cright) = opt_count false right in + add_test ci cleft ; + add_test ci cright ; + if less_tests cml cmr then + add_test cm cmr + else + add_test cm cml ; + + if + less2tests (cm,ci) !best_cost + then begin + if top then + Printf.fprintf stderr "Get it: %d\n" i ; + best := i ; + best_cost := (cm,ci) + end + done ; + !best, !best_cost in + + let ilow, ihigh, with_inter = + if not !ok_inter then + let rlow = ref (-1) and rhigh = ref (-1) + and best_cost= ref (too_much,too_much) in + for i=1 to lcases-2 do + let low, high, inside, outside = coupe_inter i i cases in + if low=high then begin + let _,(cmi,cinside) = opt_count false inside + and _,(cmo,coutside) = opt_count false outside + and cmij = {n=1 ; ni=0} + and cij = {n=1 ; ni=0} in + add_test cij cinside ; + add_test cij coutside ; + if less_tests cmi cmo then + add_test cmij cmo + else + add_test cmij cmi ; + if less2tests (cmij,cij) !best_cost then begin + rlow := i ; + rhigh := i ; + best_cost := (cmij,cij) + end + end + done ; + !rlow, !rhigh, !best_cost + else + let rlow = ref (-1) and rhigh = ref (-1) + and best_cost= ref (too_much,too_much) in + for i=1 to lcases-2 do + for j=i to lcases-2 do + let low, high, inside, outside = coupe_inter i j cases in + let _,(cmi,cinside) = opt_count false inside + and _,(cmo,coutside) = opt_count false outside + and cmij = {n=1 ; ni=(if low=high then 0 else 1)} + and cij = {n=1 ; ni=(if low=high then 0 else 1)} in + add_test cij cinside ; + add_test cij coutside ; + if less_tests cmi cmo then + add_test cmij cmo + else + add_test cmij cmi ; + if less2tests (cmij,cij) !best_cost then begin + rlow := i ; + rhigh := j ; + best_cost := (cmij,cij) + end + done + done ; + !rlow, !rhigh, !best_cost in + let r = ref (Inter (ilow,ihigh)) and rc = ref with_inter in + if less2tests with_sep !rc then begin + r := Sep lim ; rc := with_sep + end ; + !r, !rc + + let make_if_test konst test arg i ifso ifnot = + Arg.make_if + (Arg.make_prim test [arg ; konst i]) + ifso ifnot + + let make_if_lt konst arg i ifso ifnot = match i with + | 1 -> + make_if_test konst Arg.leint arg 0 ifso ifnot + | _ -> + make_if_test konst Arg.ltint arg i ifso ifnot + + and make_if_le konst arg i ifso ifnot = match i with + | -1 -> + make_if_test konst Arg.ltint arg 0 ifso ifnot + | _ -> + make_if_test konst Arg.leint arg i ifso ifnot + + and make_if_gt konst arg i ifso ifnot = match i with + | -1 -> + make_if_test konst Arg.geint arg 0 ifso ifnot + | _ -> + make_if_test konst Arg.gtint arg i ifso ifnot + + and make_if_ge konst arg i ifso ifnot = match i with + | 1 -> + make_if_test konst Arg.gtint arg 0 ifso ifnot + | _ -> + make_if_test konst Arg.geint arg i ifso ifnot + + and make_if_eq konst arg i ifso ifnot = + make_if_test konst Arg.eqint arg i ifso ifnot + + and make_if_ne konst arg i ifso ifnot = + make_if_test konst Arg.neint arg i ifso ifnot + + let do_make_if_out h arg ifso ifno = + Arg.make_if (Arg.make_isout h arg) ifso ifno + + let make_if_out konst ctx l d mk_ifso mk_ifno = match l with + | 0 -> + do_make_if_out + (konst d) ctx.arg (mk_ifso ctx) (mk_ifno ctx) + | _ -> + Arg.bind + (Arg.make_offset ctx.arg (-l)) + (fun arg -> + let ctx = {off= (-l+ctx.off) ; arg=arg} in + do_make_if_out + (konst d) arg (mk_ifso ctx) (mk_ifno ctx)) + + let do_make_if_in h arg ifso ifno = + Arg.make_if (Arg.make_isin h arg) ifso ifno + + let make_if_in konst ctx l d mk_ifso mk_ifno = match l with + | 0 -> + do_make_if_in + (konst d) ctx.arg (mk_ifso ctx) (mk_ifno ctx) + | _ -> + Arg.bind + (Arg.make_offset ctx.arg (-l)) + (fun arg -> + let ctx = {off= (-l+ctx.off) ; arg=arg} in + do_make_if_in + (konst d) arg (mk_ifso ctx) (mk_ifno ctx)) + + + let rec c_test konst ctx ({cases=cases ; actions=actions} as s) = + let lcases = Array.length cases in + assert(lcases > 0) ; + if lcases = 1 then + actions.(get_act cases 0) ctx + else begin + + let w,c = opt_count false cases in +(* + Printf.fprintf stderr + "off=%d tactic=%a for %a\n" + ctx.off pret w pcases cases ; + *) + match w with + | No -> actions.(get_act cases 0) ctx + | Inter (i,j) -> + let low,high,inside, outside = coupe_inter i j cases in + let _,(cinside,_) = opt_count false inside + and _,(coutside,_) = opt_count false outside in +(* Costs are retrieved to put the code with more remaining tests + in the privileged (positive) branch of ``if'' *) + if low=high then begin + if less_tests coutside cinside then + make_if_eq + konst ctx.arg + (low+ctx.off) + (c_test konst ctx {s with cases=inside}) + (c_test konst ctx {s with cases=outside}) + else + make_if_ne + konst ctx.arg + (low+ctx.off) + (c_test konst ctx {s with cases=outside}) + (c_test konst ctx {s with cases=inside}) + end else begin + if less_tests coutside cinside then + make_if_in + konst ctx + (low+ctx.off) + (high-low) + (fun ctx -> c_test konst ctx {s with cases=inside}) + (fun ctx -> c_test konst ctx {s with cases=outside}) + else + make_if_out + konst ctx + (low+ctx.off) + (high-low) + (fun ctx -> c_test konst ctx {s with cases=outside}) + (fun ctx -> c_test konst ctx {s with cases=inside}) + end + | Sep i -> + let lim,left,right = coupe cases i in + let _,(cleft,_) = opt_count false left + and _,(cright,_) = opt_count false right in + let left = {s with cases=left} + and right = {s with cases=right} in + + if i=1 && (lim+ctx.off)=1 && get_low cases 0+ctx.off=0 then + make_if_ne konst + ctx.arg 0 + (c_test konst ctx right) (c_test konst ctx left) + else if less_tests cright cleft then + make_if_lt konst + ctx.arg (lim+ctx.off) + (c_test konst ctx left) (c_test konst ctx right) + else + make_if_ge konst + ctx.arg (lim+ctx.off) + (c_test konst ctx right) (c_test konst ctx left) + + end + + +(* Minimal density of switches *) +let theta = ref 0.33333 + +(* Minmal number of tests to make a switch *) +let switch_min = ref 3 + +(* Particular case 0, 1, 2 *) +let particular_case cases i j = + j-i = 2 && + (let l1,h1,act1 = cases.(i) + and l2,h2,act2 = cases.(i+1) + and l3,h3,act3 = cases.(i+2) in + l1+1=l2 && l2+1=l3 && l3=h3 && + act1 <> act3) + +let approx_count cases i j n_actions = + let l = j-i+1 in + if l < !cut then + let _,(_,{n=ntests}) = opt_count false (Array.sub cases i l) in + ntests + else + l-1 + +(* Sends back a boolean that says whether is switch is worth or not *) + +let dense ({cases=cases ; actions=actions} as s) i j = + if i=j then true + else + let l,_,_ = cases.(i) + and _,h,_ = cases.(j) in + let ntests = approx_count cases i j (Array.length actions) in +(* + (ntests+1) >= theta * (h-l+1) +*) + particular_case cases i j || + (ntests >= !switch_min && + float_of_int ntests +. 1.0 >= + !theta *. (float_of_int h -. float_of_int l +. 1.0)) + +(* Compute clusters by dynamic programming + Adaptation of the correction to Bernstein + ``Correction to `Producing Good Code for the Case Statement' '' + S.K. Kannan and T.A. Proebsting + Software Practice and Exprience Vol. 24(2) 233 (Feb 1994) +*) + +let comp_clusters ({cases=cases ; actions=actions} as s) = + let len = Array.length cases in + let min_clusters = Array.create len max_int + and k = Array.create len 0 in + let get_min i = if i < 0 then 0 else min_clusters.(i) in + + for i = 0 to len-1 do + for j = 0 to i do + if + dense s j i && + get_min (j-1) + 1 < min_clusters.(i) + then begin + k.(i) <- j ; + min_clusters.(i) <- get_min (j-1) + 1 + end + done ; + done ; + min_clusters.(len-1),k + +(* Assume j > i *) +let make_switch {cases=cases ; actions=actions} i j = + let ll,_,_ = cases.(i) + and _,hh,_ = cases.(j) in + let tbl = Array.create (hh-ll+1) 0 + and t = Hashtbl.create 17 + and index = ref 0 in + let get_index act = + try + Hashtbl.find t act + with + | Not_found -> + let i = !index in + incr index ; + Hashtbl.add t act i ; + i in + + for k=i to j do + let l,h,act = cases.(k) in + let index = get_index act in + for kk=l-ll to h-ll do + tbl.(kk) <- index + done + done ; + let acts = Array.create !index actions.(0) in + Hashtbl.iter + (fun act i -> acts.(i) <- actions.(act)) + t ; + (fun ctx -> + match -ll-ctx.off with + | 0 -> Arg.make_switch ctx.arg tbl acts + | _ -> + Arg.bind + (Arg.make_offset ctx.arg (-ll-ctx.off)) + (fun arg -> Arg.make_switch arg tbl acts)) + + +let make_clusters ({cases=cases ; actions=actions} as s) n_clusters k = + let len = Array.length cases in + let r = Array.create n_clusters (0,0,0) + and t = Hashtbl.create 17 + and index = ref 0 + and bidon = ref (Array.length actions) in + let get_index act = + try + let i,_ = Hashtbl.find t act in + i + with + | Not_found -> + let i = !index in + incr index ; + Hashtbl.add + t act + (i,(fun _ -> actions.(act))) ; + i + and add_index act = + let i = !index in + incr index ; + incr bidon ; + Hashtbl.add t !bidon (i,act) ; + i in + + let rec zyva j ir = + let i = k.(j) in + begin if i=j then + let l,h,act = cases.(i) in + r.(ir) <- (l,h,get_index act) + else (* assert i < j *) + let l,_,_ = cases.(i) + and _,h,_ = cases.(j) in + r.(ir) <- (l,h,add_index (make_switch s i j)) + end ; + if i > 0 then zyva (i-1) (ir-1) in + + zyva (len-1) (n_clusters-1) ; + let acts = Array.create !index (fun _ -> assert false) in + Hashtbl.iter (fun _ (i,act) -> acts.(i) <- act) t ; + {cases = r ; actions = acts} +;; + + +let zyva (low,high) konst arg cases actions = + let lcases = Array.length cases in + let old_ok = !ok_inter in + ok_inter := (abs low <= inter_limit && abs high <= inter_limit) ; + if !ok_inter <> old_ok then Hashtbl.clear t ; + + let s = {cases=cases ; actions=actions} in +(* + Printf.eprintf "ZYVA: %b\n" !ok_inter ; + pcases stderr cases ; + prerr_endline "" ; +*) + let n_clusters,k = comp_clusters s in + let clusters = make_clusters s n_clusters k in + let r = c_test konst {arg=arg ; off=0} clusters in + r + + + +and test_sequence konst arg cases actions = + let old_ok = !ok_inter in + ok_inter := false ; + if !ok_inter <> old_ok then Hashtbl.clear t ; + let s = + {cases=cases ; + actions=Array.map (fun act -> (fun _ -> act)) actions} in +(* + Printf.eprintf "SEQUENCE: %b\n" !ok_inter ; + pcases stderr cases ; + prerr_endline "" ; +*) + let r = c_test konst {arg=arg ; off=0} s in + r +;; + +end diff --git a/bytecomp/switch.mli b/bytecomp/switch.mli new file mode 100644 index 00000000..73799daa --- /dev/null +++ b/bytecomp/switch.mli @@ -0,0 +1,82 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Luc Maranget, 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. *) +(* *) +(***********************************************************************) + +(* + This module transforms generic switches in combinations + of if tests and switches. +*) + +(* For detecting action sharing, object style *) + +type 'a t_store = + {act_get : unit -> 'a array ; act_store : 'a -> int} +val mk_store : ('a -> 'a -> bool) -> 'a t_store + +(* Arguments to the Make functor *) +module type S = + sig + (* type of basic tests *) + type primitive + (* basic tests themselves *) + val eqint : primitive + val neint : primitive + val leint : primitive + val ltint : primitive + val geint : primitive + val gtint : primitive + (* type of actions *) + type act + + (* Various constructors, for making a binder, + adding one integer, etc. *) + val bind : act -> (act -> act) -> act + val make_offset : act -> int -> act + val make_prim : primitive -> act list -> act + val make_isout : act -> act -> act + val make_isin : act -> act -> act + val make_if : act -> act -> act -> act + (* construct an actual switch : + make_switch arg cases acts + NB: cases is in the value form *) + val make_switch : + act -> int array -> act array -> act + end + + +(* + Make.zyva mk_const arg low high cases actions where + - mk_const takes an integer sends a constant action. + - arg is the argument of the switch. + - low, high are the interval limits. + - cases is a list of sub-interval and action indices + - actions is an array of actions. + + All these arguments specify a switch construct and zyva + returns an action that performs the switch, +*) +module Make : + functor (Arg : S) -> + sig + val zyva : + (int * int) -> + (int -> Arg.act) -> + Arg.act -> + (int * int * int) array -> + Arg.act array -> + Arg.act + val test_sequence : + (int -> Arg.act) -> + Arg.act -> + (int * int * int) array -> + Arg.act array -> + Arg.act + end diff --git a/bytecomp/symtable.ml b/bytecomp/symtable.ml new file mode 100644 index 00000000..54f03190 --- /dev/null +++ b/bytecomp/symtable.ml @@ -0,0 +1,349 @@ +(***********************************************************************) +(* *) +(* 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: symtable.ml,v 1.35 2003/05/26 13:46:06 xleroy Exp $ *) + +(* To assign numbers to globals and primitives *) + +open Misc +open Asttypes +open Lambda +open Emitcode + +(* Functions for batch linking *) + +type error = + Undefined_global of string + | Unavailable_primitive of string + | Wrong_vm of string + | Uninitialized_global of string + +exception Error of error + +(* Tables for numbering objects *) + +type 'a numtable = + { num_cnt: int; (* The next number *) + num_tbl: ('a, int) Tbl.t } (* The table of already numbered objects *) + +let empty_numtable = { num_cnt = 0; num_tbl = Tbl.empty } + +let find_numtable nt key = + Tbl.find key nt.num_tbl + +let enter_numtable nt key = + let n = !nt.num_cnt in + nt := { num_cnt = n + 1; num_tbl = Tbl.add key n !nt.num_tbl }; + n + +let incr_numtable nt = + let n = !nt.num_cnt in + nt := { num_cnt = n + 1; num_tbl = !nt.num_tbl }; + n + +(* Global variables *) + +let global_table = ref(empty_numtable : Ident.t numtable) +and literal_table = ref([] : (int * structured_constant) list) + +let slot_for_getglobal id = + try + find_numtable !global_table id + with Not_found -> + raise(Error(Undefined_global(Ident.name id))) + +let slot_for_setglobal id = + enter_numtable global_table id + +let slot_for_literal cst = + let n = incr_numtable global_table in + literal_table := (n, cst) :: !literal_table; + n + +(* The C primitives *) + +let c_prim_table = ref(empty_numtable : string numtable) + +let set_prim_table name = + ignore(enter_numtable c_prim_table name) + +let num_of_prim name = + try + find_numtable !c_prim_table name + with Not_found -> + if !Clflags.custom_runtime then + enter_numtable c_prim_table name + else begin + let symb = + try Dll.find_primitive name + with Not_found -> raise(Error(Unavailable_primitive name)) in + let num = enter_numtable c_prim_table name in + Dll.synchronize_primitive num symb; + num + end + +let require_primitive name = + if name.[0] <> '%' then ignore(num_of_prim name) + +let all_primitives () = + let prim = Array.create !c_prim_table.num_cnt "" in + Tbl.iter (fun name number -> prim.(number) <- name) !c_prim_table.num_tbl; + prim + +let output_primitive_names outchan = + let prim = all_primitives() in + for i = 0 to Array.length prim - 1 do + output_string outchan prim.(i); output_char outchan '\000' + done + +open Printf + +let output_primitive_table outchan = + let prim = all_primitives() in + fprintf outchan "\ + #ifdef __cplusplus\n\ + extern \"C\" {\n\ + #endif\n"; + for i = 0 to Array.length prim - 1 do + fprintf outchan "extern long %s();\n" prim.(i) + done; + fprintf outchan "typedef long (*primitive)();\n"; + fprintf outchan "primitive builtin_cprim[] = {\n"; + for i = 0 to Array.length prim - 1 do + fprintf outchan " %s,\n" prim.(i) + done; + fprintf outchan " (primitive) 0 };\n"; + fprintf outchan "char * names_of_builtin_cprim[] = {\n"; + for i = 0 to Array.length prim - 1 do + fprintf outchan " \"%s\",\n" prim.(i) + done; + fprintf outchan " (char *) 0 };\n"; + fprintf outchan "\ + #ifdef __cplusplus\n\ + }\n\ + #endif\n" + +(* Initialization for batch linking *) + +let init () = + (* Enter the predefined exceptions *) + Array.iter + (fun name -> + let id = + try List.assoc name Predef.builtin_values + with Not_found -> fatal_error "Symtable.init" in + let c = slot_for_setglobal id in + let cst = Const_block(0, [Const_base(Const_string name)]) in + literal_table := (c, cst) :: !literal_table) + Runtimedef.builtin_exceptions; + (* Initialize the known C primitives *) + if String.length !Clflags.use_prims > 0 then begin + let ic = open_in !Clflags.use_prims in + try + while true do + set_prim_table (input_line ic) + done + with End_of_file -> close_in ic + | x -> close_in ic; raise x + end else if String.length !Clflags.use_runtime > 0 then begin + let primfile = Filename.temp_file "camlprims" "" in + try + if Sys.command(Printf.sprintf "%s -p > %s" + !Clflags.use_runtime primfile) <> 0 + then raise(Error(Wrong_vm !Clflags.use_runtime)); + let ic = open_in primfile in + try + while true do + set_prim_table (input_line ic) + done + with End_of_file -> close_in ic; remove_file primfile + | x -> close_in ic; raise x + with x -> remove_file primfile; raise x + end else begin + Array.iter set_prim_table Runtimedef.builtin_primitives + end + +(* Relocate a block of object bytecode *) + +(* Must use the unsafe String.set here because the block may be + a "fake" string as returned by Meta.static_alloc. *) + +let patch_int buff pos n = + String.unsafe_set buff pos (Char.unsafe_chr n); + String.unsafe_set buff (pos + 1) (Char.unsafe_chr (n asr 8)); + String.unsafe_set buff (pos + 2) (Char.unsafe_chr (n asr 16)); + String.unsafe_set buff (pos + 3) (Char.unsafe_chr (n asr 24)) + +let patch_object buff patchlist = + List.iter + (function + (Reloc_literal sc, pos) -> + patch_int buff pos (slot_for_literal sc) + | (Reloc_getglobal id, pos) -> + patch_int buff pos (slot_for_getglobal id) + | (Reloc_setglobal id, pos) -> + patch_int buff pos (slot_for_setglobal id) + | (Reloc_primitive name, pos) -> + patch_int buff pos (num_of_prim name)) + patchlist + +(* Translate structured constants *) + +let rec transl_const = function + Const_base(Const_int i) -> Obj.repr i + | Const_base(Const_char c) -> Obj.repr c + | Const_base(Const_string s) -> Obj.repr s + | Const_base(Const_float f) -> Obj.repr (float_of_string f) + | Const_base(Const_int32 i) -> Obj.repr i + | Const_base(Const_int64 i) -> Obj.repr i + | Const_base(Const_nativeint i) -> Obj.repr i + | Const_pointer i -> Obj.repr i + | Const_block(tag, fields) -> + let block = Obj.new_block tag (List.length fields) in + let pos = ref 0 in + List.iter + (fun c -> Obj.set_field block !pos (transl_const c); incr pos) + fields; + block + | Const_float_array fields -> + Obj.repr(Array.of_list(List.map (fun f -> float_of_string f) fields)) + +(* Build the initial table of globals *) + +let initial_global_table () = + let glob = Array.create !global_table.num_cnt (Obj.repr 0) in + List.iter + (fun (slot, cst) -> glob.(slot) <- transl_const cst) + !literal_table; + literal_table := []; + glob + +(* Save the table of globals *) + +let output_global_map oc = + output_value oc !global_table + +(* Functions for toplevel use *) + +(* Update the in-core table of globals *) + +let update_global_table () = + let ng = !global_table.num_cnt in + if ng > Array.length(Meta.global_data()) then Meta.realloc_global_data ng; + let glob = Meta.global_data() in + List.iter + (fun (slot, cst) -> glob.(slot) <- transl_const cst) + !literal_table; + literal_table := [] + +(* Initialize the linker for toplevel use *) + +let init_toplevel () = + (* Read back the known global symbols and the known primitives + from the executable file *) + let ic = open_in_bin Sys.executable_name in + begin try + Bytesections.read_toc ic; + ignore(Bytesections.seek_section ic "SYMB"); + global_table := (input_value ic : Ident.t numtable); + let prims = Bytesections.read_section ic "PRIM" in + c_prim_table := empty_numtable; + let pos = ref 0 in + while !pos < String.length prims do + let i = String.index_from prims !pos '\000' in + set_prim_table (String.sub prims !pos (i - !pos)); + pos := i + 1 + done + with Bytesections.Bad_magic_number | Not_found | Failure _ -> + fatal_error "Toplevel bytecode executable is corrupted" + end; + (* Initialize the Dll machinery for toplevel use *) + let dllpath = + try Bytesections.read_section ic "DLPT" with Not_found -> "" in + Dll.init_toplevel dllpath; + (* Recover CRC infos for interfaces *) + let crcintfs = + try + ignore(Bytesections.seek_section ic "CRCS"); + (input_value ic : (string * Digest.t) list) + with Not_found -> [] in + close_in ic; + crcintfs + +(* Find the value of a global identifier *) + +let get_global_position id = slot_for_getglobal id + +let get_global_value id = + (Meta.global_data()).(slot_for_getglobal id) +let assign_global_value id v = + (Meta.global_data()).(slot_for_getglobal id) <- v + +(* Check that all globals referenced in the given patch list + have been initialized already *) + +let check_global_initialized patchlist = + (* First determine the globals we will define *) + let defined_globals = + List.fold_left + (fun accu rel -> + match rel with + (Reloc_setglobal id, pos) -> id :: accu + | _ -> accu) + [] patchlist in + (* Then check that all referenced, not defined globals have a value *) + let check_reference = function + (Reloc_getglobal id, pos) -> + if not (List.mem id defined_globals) + && Obj.is_int (get_global_value id) + then raise (Error(Uninitialized_global(Ident.name id))) + | _ -> () in + List.iter check_reference patchlist + +(* Save and restore the current state *) + +type global_map = Ident.t numtable + +let current_state () = !global_table + +let restore_state st = global_table := st + +let hide_additions st = + if st.num_cnt > !global_table.num_cnt then + fatal_error "Symtable.hide_additions"; + global_table := + { num_cnt = !global_table.num_cnt; + num_tbl = st.num_tbl } + +(* "Filter" the global map according to some predicate. + Used to expunge the global map for the toplevel. *) + +let filter_global_map p gmap = + let newtbl = ref Tbl.empty in + Tbl.iter + (fun id num -> if p id then newtbl := Tbl.add id num !newtbl) + gmap.num_tbl; + {num_cnt = gmap.num_cnt; num_tbl = !newtbl} + +(* Error report *) + +open Format + +let report_error ppf = function + | Undefined_global s -> + fprintf ppf "Reference to undefined global `%s'" s + | Unavailable_primitive s -> + fprintf ppf "The external function `%s' is not available" s + | Wrong_vm s -> + fprintf ppf "Cannot find or execute the runtime system %s" s + | Uninitialized_global s -> + fprintf ppf "The value of the global `%s' is not yet computed" s diff --git a/bytecomp/symtable.mli b/bytecomp/symtable.mli new file mode 100644 index 00000000..3b21587c --- /dev/null +++ b/bytecomp/symtable.mli @@ -0,0 +1,57 @@ +(***********************************************************************) +(* *) +(* 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: symtable.mli,v 1.13 2003/05/26 13:46:06 xleroy Exp $ *) + +(* Assign locations and numbers to globals and primitives *) + +open Emitcode + +(* Functions for batch linking *) + +val init: unit -> unit +val patch_object: string -> (reloc_info * int) list -> unit +val require_primitive: string -> unit +val initial_global_table: unit -> Obj.t array +val output_global_map: out_channel -> unit +val output_primitive_names: out_channel -> unit +val output_primitive_table: out_channel -> unit + +(* Functions for the toplevel *) + +val init_toplevel: unit -> (string * Digest.t) list +val update_global_table: unit -> unit +val get_global_value: Ident.t -> Obj.t +val assign_global_value: Ident.t -> Obj.t -> unit +val get_global_position: Ident.t -> int +val check_global_initialized: (reloc_info * int) list -> unit + +type global_map + +val current_state: unit -> global_map +val restore_state: global_map -> unit +val hide_additions: global_map -> unit +val filter_global_map: (Ident.t -> bool) -> global_map -> global_map + +(* Error report *) + +type error = + Undefined_global of string + | Unavailable_primitive of string + | Wrong_vm of string + | Uninitialized_global of string + +exception Error of error + +open Format + +val report_error: formatter -> error -> unit diff --git a/bytecomp/translclass.ml b/bytecomp/translclass.ml new file mode 100644 index 00000000..e525937f --- /dev/null +++ b/bytecomp/translclass.ml @@ -0,0 +1,334 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Jerome Vouillon, 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: translclass.ml,v 1.24 2003/06/19 15:53:48 xleroy Exp $ *) + +open Misc +open Asttypes +open Types +open Typedtree +open Lambda +open Translobj +open Translcore + +(* XXX Rajouter des evenements... *) + +type error = Illegal_class_expr + +exception Error of Location.t * error + +let lfunction params body = + match body with + Lfunction (Curried, params', body') -> + Lfunction (Curried, params @ params', body') + | _ -> + Lfunction (Curried, params, body) + +let lapply func args = + match func with + Lapply(func', args') -> + Lapply(func', args' @ args) + | _ -> + Lapply(func, args) + +let lsequence l1 l2 = + if l2 = lambda_unit then l1 else Lsequence(l1, l2) + +let transl_label l = Lconst (Const_base (Const_string l)) + +let rec transl_meth_list lst = + Lconst + (List.fold_right + (fun lab rem -> Const_block (0, [Const_base (Const_string lab); rem])) + lst (Const_pointer 0)) + +let set_inst_var obj id expr = + let kind = if Typeopt.maybe_pointer expr then Paddrarray else Pintarray in + Lprim(Parraysetu kind, [Lvar obj; Lvar id; transl_exp expr]) + +let copy_inst_var obj id expr templ offset = + let kind = if Typeopt.maybe_pointer expr then Paddrarray else Pintarray in + let id' = Ident.create (Ident.name id) in + Llet(Strict, id', Lprim (Pidentity, [Lvar id]), + Lprim(Parraysetu kind, + [Lvar obj; Lvar id'; + Lprim(Parrayrefu kind, [Lvar templ; Lprim(Paddint, + [Lvar id'; + Lvar offset])])])) + +let transl_val tbl create name id rem = + Llet(StrictOpt, id, Lapply (oo_prim (if create then "new_variable" + else "get_variable"), + [Lvar tbl; transl_label name]), + rem) + +let transl_vals tbl create vals rem = + List.fold_right + (fun (name, id) rem -> transl_val tbl create name id rem) + vals rem + +let transl_super tbl meths inh_methods rem = + List.fold_right + (fun (nm, id) rem -> + begin try + Llet(StrictOpt, id, Lapply (oo_prim "get_method", + [Lvar tbl; Lvar (Meths.find nm meths)]), + rem) + with Not_found -> + rem + end) + inh_methods rem + +let create_object cl obj init = + let obj' = Ident.create "self" in + let (inh_init, obj_init) = init obj' in + if obj_init = lambda_unit then + (inh_init, + Lapply (oo_prim "create_object_and_run_initializers", + [Lvar obj; Lvar cl])) + else begin + (inh_init, + Llet(Strict, obj', + Lapply (oo_prim "create_object_opt", [Lvar obj; Lvar cl]), + Lsequence(obj_init, + Lapply (oo_prim "run_initializers_opt", + [Lvar obj; Lvar obj'; Lvar cl])))) + end + +let rec build_object_init cl_table obj params inh_init cl = + match cl.cl_desc with + Tclass_ident path -> + let obj_init = Ident.create "obj_init" in + (obj_init::inh_init, Lapply(Lvar obj_init, [Lvar obj])) + | Tclass_structure str -> + create_object cl_table obj (fun obj -> + let (inh_init, obj_init) = + List.fold_right + (fun field (inh_init, obj_init) -> + match field with + Cf_inher (cl, _, _) -> + let (inh_init, obj_init') = + build_object_init cl_table obj [] inh_init cl + in + (inh_init, lsequence obj_init' obj_init) + | Cf_val (_, id, exp) -> + (inh_init, lsequence (set_inst_var obj id exp) obj_init) + | Cf_meth _ | Cf_init _ -> + (inh_init, obj_init) + | Cf_let (rec_flag, defs, vals) -> + (inh_init, + Translcore.transl_let rec_flag defs + (List.fold_right + (fun (id, expr) rem -> + lsequence (Lifused(id, set_inst_var obj id expr)) + rem) + vals obj_init))) + str.cl_field + (inh_init, lambda_unit) + in + (inh_init, + List.fold_right + (fun (id, expr) rem -> + lsequence (Lifused (id, set_inst_var obj id expr)) rem) + params obj_init)) + | Tclass_fun (pat, vals, cl, partial) -> + let (inh_init, obj_init) = + build_object_init cl_table obj (vals @ params) inh_init cl + in + (inh_init, + let build params rem = + let param = name_pattern "param" [pat, ()] in + Lfunction (Curried, param::params, + Matching.for_function + pat.pat_loc None (Lvar param) [pat, rem] partial) + in + begin match obj_init with + Lfunction (Curried, params, rem) -> build params rem + | rem -> build [] rem + end) + | Tclass_apply (cl, oexprs) -> + let (inh_init, obj_init) = + build_object_init cl_table obj params inh_init cl + in + (inh_init, transl_apply obj_init oexprs) + | Tclass_let (rec_flag, defs, vals, cl) -> + let (inh_init, obj_init) = + build_object_init cl_table obj (vals @ params) inh_init cl + in + (inh_init, Translcore.transl_let rec_flag defs obj_init) + | Tclass_constraint (cl, vals, pub_meths, concr_meths) -> + build_object_init cl_table obj params inh_init cl + +let rec build_object_init_0 cl_table params cl = + match cl.cl_desc with + Tclass_let (rec_flag, defs, vals, cl) -> + let (inh_init, obj_init) = + build_object_init_0 cl_table (vals @ params) cl + in + (inh_init, Translcore.transl_let rec_flag defs obj_init) + | _ -> + let obj = Ident.create "self" in + let (inh_init, obj_init) = build_object_init cl_table obj params [] cl in + let obj_init = lfunction [obj] obj_init in + (inh_init, obj_init) + +let bind_method tbl public_methods lab id cl_init = + if List.mem lab public_methods then + Llet(Alias, id, Lvar (meth lab), cl_init) + else + Llet(StrictOpt, id, Lapply (oo_prim "get_method_label", + [Lvar tbl; transl_label lab]), + cl_init) + +let bind_methods tbl public_methods meths cl_init = + Meths.fold (bind_method tbl public_methods) meths cl_init + +let rec build_class_init cla pub_meths cstr inh_init cl_init cl = + match cl.cl_desc with + Tclass_ident path -> + begin match inh_init with + obj_init::inh_init -> + (inh_init, + Llet (Strict, obj_init, + Lapply(Lprim(Pfield 1, [transl_path path]), [Lvar cla]), + cl_init)) + | _ -> + assert false + end + | Tclass_structure str -> + let (inh_init, cl_init) = + List.fold_right + (fun field (inh_init, cl_init) -> + match field with + Cf_inher (cl, vals, meths) -> + build_class_init cla pub_meths false inh_init + (transl_vals cla false vals + (transl_super cla str.cl_meths meths cl_init)) + cl + | Cf_val (name, id, exp) -> + (inh_init, transl_val cla true name id cl_init) + | Cf_meth (name, exp) -> + let met_code = + if !Clflags.native_code then begin + (* Force correct naming of method for profiles *) + let met = Ident.create ("method_" ^ name) in + Llet(Strict, met, transl_exp exp, Lvar met) + end else + transl_exp exp in + (inh_init, + Lsequence(Lapply (oo_prim "set_method", + [Lvar cla; + Lvar (Meths.find name str.cl_meths); + met_code]), + cl_init)) + | Cf_let (rec_flag, defs, vals) -> + let vals = + List.map (function (id, _) -> (Ident.name id, id)) vals + in + (inh_init, transl_vals cla true vals cl_init) + | Cf_init exp -> + (inh_init, + Lsequence(Lapply (oo_prim "add_initializer", + [Lvar cla; transl_exp exp]), + cl_init))) + str.cl_field + (inh_init, cl_init) + in + (inh_init, bind_methods cla pub_meths str.cl_meths cl_init) + | Tclass_fun (pat, vals, cl, _) -> + let (inh_init, cl_init) = + build_class_init cla pub_meths cstr inh_init cl_init cl + in + let vals = List.map (function (id, _) -> (Ident.name id, id)) vals in + (inh_init, transl_vals cla true vals cl_init) + | Tclass_apply (cl, exprs) -> + build_class_init cla pub_meths cstr inh_init cl_init cl + | Tclass_let (rec_flag, defs, vals, cl) -> + let (inh_init, cl_init) = + build_class_init cla pub_meths cstr inh_init cl_init cl + in + let vals = List.map (function (id, _) -> (Ident.name id, id)) vals in + (inh_init, transl_vals cla true vals cl_init) + | Tclass_constraint (cl, vals, meths, concr_meths) -> + let core cl_init = + build_class_init cla pub_meths true inh_init cl_init cl + in + if cstr then + core cl_init + else + let virt_meths = + List.fold_right + (fun lab rem -> + if Concr.mem lab concr_meths then rem else lab::rem) + meths + [] + in + let (inh_init, cl_init) = + core (Lsequence (Lapply (oo_prim "widen", [Lvar cla]), + cl_init)) + in + (inh_init, + Lsequence(Lapply (oo_prim "narrow", + [Lvar cla; + transl_meth_list vals; + transl_meth_list virt_meths; + transl_meth_list (Concr.elements concr_meths)]), + cl_init)) + + +(* + XXX Il devrait etre peu couteux d'ecrire des classes : + class c x y = d e f +*) +(* + XXX + Exploiter le fait que les methodes sont definies dans l'ordre pour + l'initialisation des classes (et les variables liees par un + let ???) ? +*) + +let transl_class ids cl_id arity pub_meths cl = + let cla = Ident.create "class" in + let (inh_init, obj_init) = build_object_init_0 cla [] cl in + if not (Translcore.check_recursive_lambda ids obj_init) then + raise(Error(cl.cl_loc, Illegal_class_expr)); + let (inh_init, cl_init) = + build_class_init cla pub_meths true (List.rev inh_init) obj_init cl + in + assert (inh_init = []); + let table = Ident.create "table" in + let class_init = Ident.create "class_init" in + let obj_init = Ident.create "obj_init" in + Llet(Strict, table, + Lapply (oo_prim "create_table", [transl_meth_list pub_meths]), + Llet(Strict, class_init, + Lfunction(Curried, [cla], cl_init), + Llet(Strict, obj_init, Lapply(Lvar class_init, [Lvar table]), + Lsequence(Lapply (oo_prim "init_class", [Lvar table]), + Lprim(Pmakeblock(0, Immutable), + [Lvar obj_init; + Lvar class_init; + Lvar table]))))) + +let class_stub = + Lprim(Pmakeblock(0, Mutable), [lambda_unit; lambda_unit; lambda_unit]) + +let dummy_class undef_fn = + Lprim(Pmakeblock(0, Mutable), [undef_fn; undef_fn; oo_prim "dummy_table"]) + +(* Error report *) + +open Format + +let report_error ppf = function + | Illegal_class_expr -> + fprintf ppf "This kind of class expression is not allowed" diff --git a/bytecomp/translclass.mli b/bytecomp/translclass.mli new file mode 100644 index 00000000..a91b7db3 --- /dev/null +++ b/bytecomp/translclass.mli @@ -0,0 +1,29 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Jerome Vouillon, 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: translclass.mli,v 1.8 2003/06/19 15:53:48 xleroy Exp $ *) + +open Typedtree +open Lambda + +val class_stub : lambda +val dummy_class : lambda -> lambda +val transl_class : + Ident.t list -> Ident.t -> int -> string list -> class_expr -> lambda;; + +type error = Illegal_class_expr + +exception Error of Location.t * error + +open Format + +val report_error: formatter -> error -> unit diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml new file mode 100644 index 00000000..74f22b74 --- /dev/null +++ b/bytecomp/translcore.ml @@ -0,0 +1,902 @@ +(***********************************************************************) +(* *) +(* 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: translcore.ml,v 1.89 2003/06/23 12:45:42 xleroy Exp $ *) + +(* Translation from typed abstract syntax to lambda terms, + for the core language *) + +open Misc +open Asttypes +open Primitive +open Path +open Types +open Typedtree +open Typeopt +open Lambda + +type error = + Illegal_letrec_pat + | Illegal_letrec_expr + | Free_super_var + +exception Error of Location.t * error + +(* Forward declaration -- to be filled in by Translmod.transl_module *) +let transl_module = + ref((fun cc rootpath modl -> assert false) : + module_coercion -> Path.t option -> module_expr -> lambda) + +(* Translation of primitives *) + +let comparisons_table = create_hashtable 11 [ + "%equal", + (Pccall{prim_name = "equal"; prim_arity = 2; prim_alloc = true; + prim_native_name = ""; prim_native_float = false}, + Pintcomp Ceq, + Pfloatcomp Ceq, + Pccall{prim_name = "string_equal"; prim_arity = 2; prim_alloc = false; + prim_native_name = ""; prim_native_float = false}, + Pbintcomp(Pnativeint, Ceq), + Pbintcomp(Pint32, Ceq), + Pbintcomp(Pint64, Ceq)); + "%notequal", + (Pccall{prim_name = "notequal"; prim_arity = 2; prim_alloc = true; + prim_native_name = ""; prim_native_float = false}, + Pintcomp Cneq, + Pfloatcomp Cneq, + Pccall{prim_name = "string_notequal"; prim_arity = 2; + prim_alloc = false; prim_native_name = ""; + prim_native_float = false}, + Pbintcomp(Pnativeint, Cneq), + Pbintcomp(Pint32, Cneq), + Pbintcomp(Pint64, Cneq)); + "%lessthan", + (Pccall{prim_name = "lessthan"; prim_arity = 2; prim_alloc = true; + prim_native_name = ""; prim_native_float = false}, + Pintcomp Clt, + Pfloatcomp Clt, + Pccall{prim_name = "string_lessthan"; prim_arity = 2; + prim_alloc = false; prim_native_name = ""; + prim_native_float = false}, + Pbintcomp(Pnativeint, Clt), + Pbintcomp(Pint32, Clt), + Pbintcomp(Pint64, Clt)); + "%greaterthan", + (Pccall{prim_name = "greaterthan"; prim_arity = 2; prim_alloc = true; + prim_native_name = ""; prim_native_float = false}, + Pintcomp Cgt, + Pfloatcomp Cgt, + Pccall{prim_name = "string_greaterthan"; prim_arity = 2; + prim_alloc = false; prim_native_name = ""; + prim_native_float = false}, + Pbintcomp(Pnativeint, Cgt), + Pbintcomp(Pint32, Cgt), + Pbintcomp(Pint64, Cgt)); + "%lessequal", + (Pccall{prim_name = "lessequal"; prim_arity = 2; prim_alloc = true; + prim_native_name = ""; prim_native_float = false}, + Pintcomp Cle, + Pfloatcomp Cle, + Pccall{prim_name = "string_lessequal"; prim_arity = 2; + prim_alloc = false; prim_native_name = ""; + prim_native_float = false}, + Pbintcomp(Pnativeint, Cle), + Pbintcomp(Pint32, Cle), + Pbintcomp(Pint64, Cle)); + "%greaterequal", + (Pccall{prim_name = "greaterequal"; prim_arity = 2; prim_alloc = true; + prim_native_name = ""; prim_native_float = false}, + Pintcomp Cge, + Pfloatcomp Cge, + Pccall{prim_name = "string_greaterequal"; prim_arity = 2; + prim_alloc = false; prim_native_name = ""; + prim_native_float = false}, + Pbintcomp(Pnativeint, Cge), + Pbintcomp(Pint32, Cge), + Pbintcomp(Pint64, Cge)); + "%compare", + (Pccall{prim_name = "compare"; prim_arity = 2; prim_alloc = true; + prim_native_name = ""; prim_native_float = false}, + Pccall{prim_name = "int_compare"; prim_arity = 2; + prim_alloc = false; prim_native_name = ""; + prim_native_float = false}, + Pccall{prim_name = "float_compare"; prim_arity = 2; + prim_alloc = false; prim_native_name = ""; + prim_native_float = false}, + Pccall{prim_name = "string_compare"; prim_arity = 2; + prim_alloc = false; prim_native_name = ""; + prim_native_float = false}, + Pccall{prim_name = "nativeint_compare"; prim_arity = 2; + prim_alloc = false; prim_native_name = ""; + prim_native_float = false}, + Pccall{prim_name = "int32_compare"; prim_arity = 2; + prim_alloc = false; prim_native_name = ""; + prim_native_float = false}, + Pccall{prim_name = "int64_compare"; prim_arity = 2; + prim_alloc = false; prim_native_name = ""; + prim_native_float = false}) +] + +let primitives_table = create_hashtable 57 [ + "%identity", Pidentity; + "%ignore", Pignore; + "%field0", Pfield 0; + "%field1", Pfield 1; + "%setfield0", Psetfield(0, true); + "%makeblock", Pmakeblock(0, Immutable); + "%makemutable", Pmakeblock(0, Mutable); + "%raise", Praise; + "%sequand", Psequand; + "%sequor", Psequor; + "%boolnot", Pnot; + "%negint", Pnegint; + "%succint", Poffsetint 1; + "%predint", Poffsetint(-1); + "%addint", Paddint; + "%subint", Psubint; + "%mulint", Pmulint; + "%divint", Pdivint; + "%modint", Pmodint; + "%andint", Pandint; + "%orint", Porint; + "%xorint", Pxorint; + "%lslint", Plslint; + "%lsrint", Plsrint; + "%asrint", Pasrint; + "%eq", Pintcomp Ceq; + "%noteq", Pintcomp Cneq; + "%ltint", Pintcomp Clt; + "%leint", Pintcomp Cle; + "%gtint", Pintcomp Cgt; + "%geint", Pintcomp Cge; + "%incr", Poffsetref(1); + "%decr", Poffsetref(-1); + "%intoffloat", Pintoffloat; + "%floatofint", Pfloatofint; + "%negfloat", Pnegfloat; + "%absfloat", Pabsfloat; + "%addfloat", Paddfloat; + "%subfloat", Psubfloat; + "%mulfloat", Pmulfloat; + "%divfloat", Pdivfloat; + "%eqfloat", Pfloatcomp Ceq; + "%noteqfloat", Pfloatcomp Cneq; + "%ltfloat", Pfloatcomp Clt; + "%lefloat", Pfloatcomp Cle; + "%gtfloat", Pfloatcomp Cgt; + "%gefloat", Pfloatcomp Cge; + "%string_length", Pstringlength; + "%string_safe_get", Pstringrefs; + "%string_safe_set", Pstringsets; + "%string_unsafe_get", Pstringrefu; + "%string_unsafe_set", Pstringsetu; + "%array_length", Parraylength Pgenarray; + "%array_safe_get", Parrayrefs Pgenarray; + "%array_safe_set", Parraysets Pgenarray; + "%array_unsafe_get", Parrayrefu Pgenarray; + "%array_unsafe_set", Parraysetu Pgenarray; + "%obj_size", Parraylength Pgenarray; + "%obj_field", Parrayrefu Pgenarray; + "%obj_set_field", Parraysetu Pgenarray; + "%obj_is_int", Pisint; + "%nativeint_of_int", Pbintofint Pnativeint; + "%nativeint_to_int", Pintofbint Pnativeint; + "%nativeint_neg", Pnegbint Pnativeint; + "%nativeint_add", Paddbint Pnativeint; + "%nativeint_sub", Psubbint Pnativeint; + "%nativeint_mul", Pmulbint Pnativeint; + "%nativeint_div", Pdivbint Pnativeint; + "%nativeint_mod", Pmodbint Pnativeint; + "%nativeint_and", Pandbint Pnativeint; + "%nativeint_or", Porbint Pnativeint; + "%nativeint_xor", Pxorbint Pnativeint; + "%nativeint_lsl", Plslbint Pnativeint; + "%nativeint_lsr", Plsrbint Pnativeint; + "%nativeint_asr", Pasrbint Pnativeint; + "%int32_of_int", Pbintofint Pint32; + "%int32_to_int", Pintofbint Pint32; + "%int32_neg", Pnegbint Pint32; + "%int32_add", Paddbint Pint32; + "%int32_sub", Psubbint Pint32; + "%int32_mul", Pmulbint Pint32; + "%int32_div", Pdivbint Pint32; + "%int32_mod", Pmodbint Pint32; + "%int32_and", Pandbint Pint32; + "%int32_or", Porbint Pint32; + "%int32_xor", Pxorbint Pint32; + "%int32_lsl", Plslbint Pint32; + "%int32_lsr", Plsrbint Pint32; + "%int32_asr", Pasrbint Pint32; + "%int64_of_int", Pbintofint Pint64; + "%int64_to_int", Pintofbint Pint64; + "%int64_neg", Pnegbint Pint64; + "%int64_add", Paddbint Pint64; + "%int64_sub", Psubbint Pint64; + "%int64_mul", Pmulbint Pint64; + "%int64_div", Pdivbint Pint64; + "%int64_mod", Pmodbint Pint64; + "%int64_and", Pandbint Pint64; + "%int64_or", Porbint Pint64; + "%int64_xor", Pxorbint Pint64; + "%int64_lsl", Plslbint Pint64; + "%int64_lsr", Plsrbint Pint64; + "%int64_asr", Pasrbint Pint64; + "%nativeint_of_int32", Pcvtbint(Pint32, Pnativeint); + "%nativeint_to_int32", Pcvtbint(Pnativeint, Pint32); + "%int64_of_int32", Pcvtbint(Pint32, Pint64); + "%int64_to_int32", Pcvtbint(Pint64, Pint32); + "%int64_of_nativeint", Pcvtbint(Pnativeint, Pint64); + "%int64_to_nativeint", Pcvtbint(Pint64, Pnativeint); + "%bigarray_ref_1", Pbigarrayref(1, Pbigarray_unknown, Pbigarray_c_layout); + "%bigarray_ref_2", Pbigarrayref(2, Pbigarray_unknown, Pbigarray_c_layout); + "%bigarray_ref_3", Pbigarrayref(3, Pbigarray_unknown, Pbigarray_c_layout); + "%bigarray_set_1", Pbigarrayset(1, Pbigarray_unknown, Pbigarray_c_layout); + "%bigarray_set_2", Pbigarrayset(2, Pbigarray_unknown, Pbigarray_c_layout); + "%bigarray_set_3", Pbigarrayset(3, Pbigarray_unknown, Pbigarray_c_layout) +] + +let prim_makearray = + { prim_name = "make_vect"; prim_arity = 2; prim_alloc = true; + prim_native_name = ""; prim_native_float = false } + +let prim_obj_dup = + { prim_name = "obj_dup"; prim_arity = 1; prim_alloc = true; + prim_native_name = ""; prim_native_float = false } + +let transl_prim prim args = + try + let (gencomp, intcomp, floatcomp, stringcomp, + nativeintcomp, int32comp, int64comp) = + Hashtbl.find comparisons_table prim.prim_name in + begin match args with + [arg1; {exp_desc = Texp_construct({cstr_tag = Cstr_constant _}, _)}] -> + intcomp + | [{exp_desc = Texp_construct({cstr_tag = Cstr_constant _}, _)}; arg2] -> + intcomp + | [arg1; arg2] when has_base_type arg1 Predef.path_int + || has_base_type arg1 Predef.path_char -> + intcomp + | [arg1; arg2] when has_base_type arg1 Predef.path_float -> + floatcomp + | [arg1; arg2] when has_base_type arg1 Predef.path_string -> + stringcomp + | [arg1; arg2] when has_base_type arg1 Predef.path_nativeint -> + nativeintcomp + | [arg1; arg2] when has_base_type arg1 Predef.path_int32 -> + int32comp + | [arg1; arg2] when has_base_type arg1 Predef.path_int64 -> + int64comp + | _ -> + gencomp + end + with Not_found -> + try + let p = Hashtbl.find primitives_table prim.prim_name in + (* Try strength reduction based on the type of the argument *) + begin match (p, args) with + (Psetfield(n, _), [arg1; arg2]) -> Psetfield(n, maybe_pointer arg2) + | (Parraylength Pgenarray, [arg]) -> Parraylength(array_kind arg) + | (Parrayrefu Pgenarray, arg1 :: _) -> Parrayrefu(array_kind arg1) + | (Parraysetu Pgenarray, arg1 :: _) -> Parraysetu(array_kind arg1) + | (Parrayrefs Pgenarray, arg1 :: _) -> Parrayrefs(array_kind arg1) + | (Parraysets Pgenarray, arg1 :: _) -> Parraysets(array_kind arg1) + | (Pbigarrayref(n, Pbigarray_unknown, _), arg1 :: _) -> + let (k, l) = bigarray_kind_and_layout arg1 in + Pbigarrayref(n, k, l) + | (Pbigarrayset(n, Pbigarray_unknown, _), arg1 :: _) -> + let (k, l) = bigarray_kind_and_layout arg1 in + Pbigarrayset(n, k, l) + | _ -> p + end + with Not_found -> + Pccall prim + + +(* Eta-expand a primitive without knowing the types of its arguments *) + +let transl_primitive p = + let prim = + try + let (gencomp, _, _, _, _, _, _) = + Hashtbl.find comparisons_table p.prim_name in + gencomp + with Not_found -> + try + Hashtbl.find primitives_table p.prim_name + with Not_found -> + Pccall p in + let rec make_params n = + if n <= 0 then [] else Ident.create "prim" :: make_params (n-1) in + let params = make_params p.prim_arity in + Lfunction(Curried, params, Lprim(prim, List.map (fun id -> Lvar id) params)) + +(* To check the well-formedness of r.h.s. of "let rec" definitions *) + +let check_recursive_lambda idlist lam = + let rec check_top idlist = function + | Lvar v -> not (List.mem v idlist) + | Llet (_, _, _, _) as lam when check_recursive_recordwith idlist lam -> + true + | Llet(str, id, arg, body) -> + check idlist arg && check_top (add_let id arg idlist) body + | Lletrec(bindings, body) -> + let idlist' = add_letrec bindings idlist in + List.for_all (fun (id, arg) -> check idlist' arg) bindings && + check_top idlist' body + | Lsequence (lam1, lam2) -> check idlist lam1 && check_top idlist lam2 + | Levent (lam, _) -> check_top idlist lam + | lam -> check idlist lam + + and check idlist = function + | Lvar _ -> true + | Lfunction(kind, params, body) -> true + | Llet (_, _, _, _) as lam when check_recursive_recordwith idlist lam -> + true + | Llet(str, id, arg, body) -> + check idlist arg && check (add_let id arg idlist) body + | Lletrec(bindings, body) -> + let idlist' = add_letrec bindings idlist in + List.for_all (fun (id, arg) -> check idlist' arg) bindings && + check idlist' body + | Lprim(Pmakeblock(tag, mut), args) -> + List.for_all (check idlist) args + | Lprim(Pmakearray(Paddrarray|Pintarray), args) -> + List.for_all (check idlist) args + | Lsequence (lam1, lam2) -> check idlist lam1 && check idlist lam2 + | Levent (lam, _) -> check idlist lam + | lam -> + let fv = free_variables lam in + not (List.exists (fun id -> IdentSet.mem id fv) idlist) + + and add_let id arg idlist = + let fv = free_variables arg in + if List.exists (fun id -> IdentSet.mem id fv) idlist + then id :: idlist + else idlist + + and add_letrec bindings idlist = + List.fold_right (fun (id, arg) idl -> add_let id arg idl) + bindings idlist + + (* reverse-engineering the code generated by transl_record case 2 *) + and check_recursive_recordwith idlist = function + | Llet (Strict, id1, Lprim (Pccall prim, [e1]), body) -> + prim = prim_obj_dup && check_top idlist e1 + && check_recordwith_updates idlist id1 body + | _ -> false + + and check_recordwith_updates idlist id1 = function + | Lsequence (Lprim ((Psetfield _ | Psetfloatfield _), [Lvar id2; e1]), cont) + -> id2 = id1 && check idlist e1 + && check_recordwith_updates idlist id1 cont + | Lvar id2 -> id2 = id1 + | _ -> false + + in check_top idlist lam + +(* To propagate structured constants *) + +exception Not_constant + +let extract_constant = function + Lconst sc -> sc + | _ -> raise Not_constant + +let extract_float = function + Const_base(Const_float f) -> f + | _ -> fatal_error "Translcore.extract_float" + +(* To find reasonable names for let-bound and lambda-bound idents *) + +let rec name_pattern default = function + [] -> Ident.create default + | (p, e) :: rem -> + match p.pat_desc with + Tpat_var id -> id + | Tpat_alias(p, id) -> id + | _ -> name_pattern default rem + +(* Push the default values under the functional abstractions *) + +let rec push_defaults loc bindings pat_expr_list partial = + match pat_expr_list with + [pat, ({exp_desc = Texp_function(pl,partial)} as exp)] -> + let pl = push_defaults exp.exp_loc bindings pl partial in + [pat, {exp with exp_desc = Texp_function(pl, partial)}] + | [pat, ({exp_desc = Texp_let + (Default, cases, ({exp_desc = Texp_function _} as e2))} as e1)] -> + push_defaults loc (cases :: bindings) [pat, e2] partial + | [pat, exp] -> + let exp = + List.fold_left + (fun exp cases -> + {exp with exp_desc = Texp_let(Nonrecursive, cases, exp)}) + exp bindings + in + [pat, exp] + | (pat, exp) :: _ when bindings <> [] -> + let param = name_pattern "param" pat_expr_list in + let exp = + { exp with exp_loc = loc; exp_desc = + Texp_match + ({exp with exp_type = pat.pat_type; exp_desc = + Texp_ident (Path.Pident param, + {val_type = pat.pat_type; val_kind = Val_reg})}, + pat_expr_list, partial) } + in + push_defaults loc bindings + [{pat with pat_desc = Tpat_var param}, exp] Total + | _ -> + pat_expr_list + +(* Insertion of debugging events *) + +let event_before exp lam = match lam with +| Lstaticraise (_,_) -> lam +| _ -> + if !Clflags.debug + then Levent(lam, {lev_pos = exp.exp_loc.Location.loc_start; + lev_kind = Lev_before; + lev_repr = None; + lev_env = Env.summary exp.exp_env}) + else lam + +let event_after exp lam = + if !Clflags.debug + then Levent(lam, {lev_pos = exp.exp_loc.Location.loc_end; + lev_kind = Lev_after exp.exp_type; + lev_repr = None; + lev_env = Env.summary exp.exp_env}) + else lam + +let event_function exp lam = + if !Clflags.debug then + let repr = Some (ref 0) in + let (info, body) = lam repr in + (info, + Levent(body, {lev_pos = exp.exp_loc.Location.loc_start; + lev_kind = Lev_function; + lev_repr = repr; + lev_env = Env.summary exp.exp_env})) + else + lam None + +let primitive_is_ccall = function + (* Determine if a primitive is a Pccall or will be turned later into + a C function call that may raise an exception *) + | Pccall _ | Pstringrefs | Pstringsets | Parrayrefs _ | Parraysets _ | + Pbigarrayref _ | Pbigarrayset _ -> true + | _ -> false + +(* Assertions *) + +let assert_failed loc = + (* [Location.get_pos_info] is too expensive *) + let fname = match loc.Location.loc_start.Lexing.pos_fname with + | "" -> !Location.input_name + | x -> x + in + let pos = loc.Location.loc_start in + let line = pos.Lexing.pos_lnum in + let char = pos.Lexing.pos_cnum - pos.Lexing.pos_bol in + Lprim(Praise, [Lprim(Pmakeblock(0, Immutable), + [transl_path Predef.path_assert_failure; + Lconst(Const_block(0, + [Const_base(Const_string fname); + Const_base(Const_int line); + Const_base(Const_int char)]))])]) +;; + +(* Translation of expressions *) + +let rec transl_exp e = + match e.exp_desc with + Texp_ident(path, {val_kind = Val_prim p}) -> + transl_primitive p + | Texp_ident(path, {val_kind = Val_anc _}) -> + raise(Error(e.exp_loc, Free_super_var)) + | Texp_ident(path, {val_kind = Val_reg | Val_self _}) -> + transl_path path + | Texp_ident _ -> fatal_error "Translcore.transl_exp: bad Texp_ident" + | Texp_constant cst -> + Lconst(Const_base cst) + | Texp_let(rec_flag, pat_expr_list, body) -> + transl_let rec_flag pat_expr_list (event_before body (transl_exp body)) + | Texp_function (pat_expr_list, partial) -> + let ((kind, params), body) = + event_function e + (function repr -> + let pl = push_defaults e.exp_loc [] pat_expr_list partial in + transl_function e.exp_loc !Clflags.native_code repr partial pl) + in + Lfunction(kind, params, body) + | Texp_apply({exp_desc = Texp_ident(path, {val_kind = Val_prim p})}, args) + when List.length args = p.prim_arity + && List.for_all (fun (arg,_) -> arg <> None) args -> + let args = List.map (function Some x, _ -> x | _ -> assert false) args in + let prim = transl_prim p args in + begin match (prim, args) with + (Praise, [arg1]) -> + Lprim(Praise, [event_after arg1 (transl_exp arg1)]) + | (_, _) -> + if primitive_is_ccall prim + then event_after e (Lprim(prim, transl_list args)) + else Lprim(prim, transl_list args) + end + | Texp_apply(funct, oargs) -> + event_after e (transl_apply (transl_exp funct) oargs) + | Texp_match({exp_desc = Texp_tuple argl} as arg, pat_expr_list, partial) -> + Matching.for_multiple_match e.exp_loc + (transl_list argl) (transl_cases pat_expr_list) partial + | Texp_match(arg, pat_expr_list, partial) -> + Matching.for_function e.exp_loc None + (transl_exp arg) (transl_cases pat_expr_list) partial + | Texp_try(body, pat_expr_list) -> + let id = name_pattern "exn" pat_expr_list in + Ltrywith(transl_exp body, id, + Matching.for_trywith (Lvar id) (transl_cases pat_expr_list)) + | Texp_tuple el -> + let ll = transl_list el in + begin try + Lconst(Const_block(0, List.map extract_constant ll)) + with Not_constant -> + Lprim(Pmakeblock(0, Immutable), ll) + end + | Texp_construct(cstr, args) -> + let ll = transl_list args in + begin match cstr.cstr_tag with + Cstr_constant n -> + Lconst(Const_pointer n) + | Cstr_block n -> + begin try + Lconst(Const_block(n, List.map extract_constant ll)) + with Not_constant -> + Lprim(Pmakeblock(n, Immutable), ll) + end + | Cstr_exception path -> + Lprim(Pmakeblock(0, Immutable), transl_path path :: ll) + end + | Texp_variant(l, arg) -> + let tag = Btype.hash_variant l in + begin match arg with + None -> Lconst(Const_pointer tag) + | Some arg -> + let lam = transl_exp arg in + try + Lconst(Const_block(0, [Const_base(Const_int tag); + extract_constant lam])) + with Not_constant -> + Lprim(Pmakeblock(0, Immutable), + [Lconst(Const_base(Const_int tag)); lam]) + end + | Texp_record ((lbl1, _) :: _ as lbl_expr_list, opt_init_expr) -> + transl_record lbl1.lbl_all lbl1.lbl_repres lbl_expr_list opt_init_expr + | Texp_record ([], _) -> + fatal_error "Translcore.transl_exp: bad Texp_record" + | Texp_field(arg, lbl) -> + let access = + match lbl.lbl_repres with + Record_regular -> Pfield lbl.lbl_pos + | Record_float -> Pfloatfield lbl.lbl_pos in + Lprim(access, [transl_exp arg]) + | Texp_setfield(arg, lbl, newval) -> + let access = + match lbl.lbl_repres with + Record_regular -> Psetfield(lbl.lbl_pos, maybe_pointer newval) + | Record_float -> Psetfloatfield lbl.lbl_pos in + Lprim(access, [transl_exp arg; transl_exp newval]) + | Texp_array expr_list -> + let kind = array_kind e in + let ll = transl_list expr_list in + begin try + (* Deactivate constant optimization if array is small enough *) + if List.length ll <= 5 then raise Not_constant; + let cl = List.map extract_constant ll in + let master = + match kind with + | Paddrarray | Pintarray -> + Lconst(Const_block(0, cl)) + | Pfloatarray -> + Lconst(Const_float_array(List.map extract_float cl)) + | Pgenarray -> + assert false in + Lprim(Pccall prim_obj_dup, [master]) + with Not_constant -> + Lprim(Pmakearray kind, ll) + end + | Texp_ifthenelse(cond, ifso, Some ifnot) -> + Lifthenelse(transl_exp cond, + event_before ifso (transl_exp ifso), + event_before ifnot (transl_exp ifnot)) + | Texp_ifthenelse(cond, ifso, None) -> + Lifthenelse(transl_exp cond, + event_before ifso (transl_exp ifso), + lambda_unit) + | Texp_sequence(expr1, expr2) -> + Lsequence(transl_exp expr1, event_before expr2 (transl_exp expr2)) + | Texp_while(cond, body) -> + Lwhile(transl_exp cond, event_before body (transl_exp body)) + | Texp_for(param, low, high, dir, body) -> + Lfor(param, transl_exp low, transl_exp high, dir, + event_before body (transl_exp body)) + | Texp_when(cond, body) -> + event_before cond + (Lifthenelse(transl_exp cond, event_before body (transl_exp body), + staticfail)) + | Texp_send(expr, met) -> + let met_id = + match met with + Tmeth_name nm -> Translobj.meth nm + | Tmeth_val id -> id + in + event_after e (Lsend(Lvar met_id, transl_exp expr, [])) + | Texp_new (cl, _) -> + Lapply(Lprim(Pfield 0, [transl_path cl]), [lambda_unit]) + | Texp_instvar(path_self, path) -> + Lprim(Parrayrefu Paddrarray, [transl_path path_self; transl_path path]) + | Texp_setinstvar(path_self, path, expr) -> + transl_setinstvar (transl_path path_self) path expr + | Texp_override(path_self, modifs) -> + let cpy = Ident.create "copy" in + Llet(Strict, cpy, + Lapply(Translobj.oo_prim "copy", [transl_path path_self]), + List.fold_right + (fun (path, expr) rem -> + Lsequence(transl_setinstvar (Lvar cpy) path expr, rem)) + modifs + (Lvar cpy)) + | Texp_letmodule(id, modl, body) -> + Llet(Strict, id, !transl_module Tcoerce_none None modl, transl_exp body) + | Texp_assert (cond) -> + if !Clflags.noassert + then lambda_unit + else Lifthenelse (transl_exp cond, lambda_unit, assert_failed e.exp_loc) + | Texp_assertfalse -> assert_failed e.exp_loc + | Texp_lazy e -> + let fn = Lfunction (Curried, [Ident.create "param"], transl_exp e) in + Lprim(Pmakeblock(Config.lazy_tag, Immutable), [fn]) + +and transl_list expr_list = + List.map transl_exp expr_list + +and transl_cases pat_expr_list = + List.map + (fun (pat, expr) -> (pat, event_before expr (transl_exp expr))) + pat_expr_list + +and transl_tupled_cases patl_expr_list = + List.map (fun (patl, expr) -> (patl, transl_exp expr)) patl_expr_list + +and transl_apply lam sargs = + let lapply funct args = + match funct with + Lsend(lmet, lobj, largs) -> + Lsend(lmet, lobj, largs @ args) + | Levent(Lsend(lmet, lobj, largs), _) -> + Lsend(lmet, lobj, largs @ args) + | Lapply(lexp, largs) -> + Lapply(lexp, largs @ args) + | lexp -> + Lapply(lexp, args) + in + let rec build_apply lam args = function + (None, optional) :: l -> + let defs = ref [] in + let protect name lam = + match lam with + Lvar _ | Lconst _ -> lam + | _ -> + let id = Ident.create name in + defs := (id, lam) :: !defs; + Lvar id + in + let args, args' = + if List.for_all (fun (_,opt) -> opt = Optional) args then [], args + else args, [] in + let lam = + if args = [] then lam else lapply lam (List.rev_map fst args) in + let handle = protect "func" lam + and l = List.map (fun (arg, opt) -> may_map (protect "arg") arg, opt) l + and id_arg = Ident.create "param" in + let body = + match build_apply handle ((Lvar id_arg, optional)::args') l with + Lfunction(Curried, ids, lam) -> + Lfunction(Curried, id_arg::ids, lam) + | Levent(Lfunction(Curried, ids, lam), _) -> + Lfunction(Curried, id_arg::ids, lam) + | lam -> + Lfunction(Curried, [id_arg], lam) + in + List.fold_left + (fun body (id, lam) -> Llet(Strict, id, lam, body)) + body !defs + | (Some arg, optional) :: l -> + build_apply lam ((arg, optional) :: args) l + | [] -> + lapply lam (List.rev_map fst args) + in + build_apply lam [] (List.map (fun (x,o) -> may_map transl_exp x, o) sargs) + +and transl_function loc untuplify_fn repr partial pat_expr_list = + match pat_expr_list with + [pat, ({exp_desc = Texp_function(pl,partial')} as exp)] -> + let param = name_pattern "param" pat_expr_list in + let ((_, params), body) = + transl_function exp.exp_loc false repr partial' pl in + ((Curried, param :: params), + Matching.for_function loc None (Lvar param) [pat, body] partial) +(* + | [({pat_desc = Tpat_var id} as pat), + ({exp_desc = Texp_let(Nonrecursive, cases, + ({exp_desc = Texp_function _} as e2))} as e1)] + when Ident.name id = "*opt*" -> + transl_function loc untuplify_fn repr (cases::bindings) partial [pat, e2] + | [pat, exp] when bindings <> [] -> + let exp = + List.fold_left + (fun exp cases -> + {exp with exp_desc = Texp_let(Nonrecursive, cases, exp)}) + exp bindings + in + transl_function loc untuplify_fn repr [] partial [pat, exp] + | (pat, exp)::_ when bindings <> [] -> + let param = name_pattern "param" pat_expr_list in + let exp = + { exp with exp_loc = loc; exp_desc = + Texp_match + ({exp with exp_type = pat.pat_type; exp_desc = + Texp_ident (Path.Pident param, + {val_type = pat.pat_type; val_kind = Val_reg})}, + pat_expr_list, partial) } + in + transl_function loc untuplify_fn repr bindings Total + [{pat with pat_desc = Tpat_var param}, exp] +*) + | ({pat_desc = Tpat_tuple pl}, _) :: _ when untuplify_fn -> + begin try + let size = List.length pl in + let pats_expr_list = + List.map + (fun (pat, expr) -> (Matching.flatten_pattern size pat, expr)) + pat_expr_list in + let params = List.map (fun p -> Ident.create "param") pl in + ((Tupled, params), + Matching.for_tupled_function loc params + (transl_tupled_cases pats_expr_list) partial) + with Matching.Cannot_flatten -> + let param = name_pattern "param" pat_expr_list in + ((Curried, [param]), + Matching.for_function loc repr (Lvar param) + (transl_cases pat_expr_list) partial) + end + | _ -> + let param = name_pattern "param" pat_expr_list in + ((Curried, [param]), + Matching.for_function loc repr (Lvar param) + (transl_cases pat_expr_list) partial) + +and transl_let rec_flag pat_expr_list body = + match rec_flag with + Nonrecursive | Default -> + let rec transl = function + [] -> + body + | (pat, expr) :: rem -> + Matching.for_let pat.pat_loc (transl_exp expr) pat (transl rem) + in transl pat_expr_list + | Recursive -> + let idlist = + List.map + (fun (pat, expr) -> + match pat.pat_desc with + Tpat_var id -> id + | _ -> raise(Error(pat.pat_loc, Illegal_letrec_pat))) + pat_expr_list in + let transl_case (pat, expr) id = + let lam = transl_exp expr in + if not (check_recursive_lambda idlist lam) then + raise(Error(expr.exp_loc, Illegal_letrec_expr)); + (id, lam) in + Lletrec(List.map2 transl_case pat_expr_list idlist, body) + +and transl_setinstvar self var expr = + Lprim(Parraysetu (if maybe_pointer expr then Paddrarray else Pintarray), + [self; transl_path var; transl_exp expr]) + +and transl_record all_labels repres lbl_expr_list opt_init_expr = + (* Determine if there are "enough" new fields *) + if 3 + 2 * List.length lbl_expr_list >= Array.length all_labels + then begin + (* Allocate new record with given fields (and remaining fields + taken from init_expr if any *) + let lv = Array.create (Array.length all_labels) staticfail in + let init_id = Ident.create "init" in + begin match opt_init_expr with + None -> () + | Some init_expr -> + for i = 0 to Array.length all_labels - 1 do + let access = + match all_labels.(i).lbl_repres with + Record_regular -> Pfield i + | Record_float -> Pfloatfield i in + lv.(i) <- Lprim(access, [Lvar init_id]) + done + end; + List.iter + (fun (lbl, expr) -> lv.(lbl.lbl_pos) <- transl_exp expr) + lbl_expr_list; + let ll = Array.to_list lv in + let mut = + if List.exists (fun (lbl, expr) -> lbl.lbl_mut = Mutable) lbl_expr_list + then Mutable + else Immutable in + let lam = + try + if mut = Mutable then raise Not_constant; + let cl = List.map extract_constant ll in + match repres with + Record_regular -> Lconst(Const_block(0, cl)) + | Record_float -> + Lconst(Const_float_array(List.map extract_float cl)) + with Not_constant -> + match repres with + Record_regular -> Lprim(Pmakeblock(0, mut), ll) + | Record_float -> Lprim(Pmakearray Pfloatarray, ll) in + begin match opt_init_expr with + None -> lam + | Some init_expr -> Llet(Strict, init_id, transl_exp init_expr, lam) + end + end else begin + (* Take a shallow copy of the init record, then mutate the fields + of the copy *) + (* If you change anything here, you will likely have to change + [check_recursive_recordwith] in this file. *) + let copy_id = Ident.create "newrecord" in + let rec update_field (lbl, expr) cont = + let upd = + match lbl.lbl_repres with + Record_regular -> Psetfield(lbl.lbl_pos, maybe_pointer expr) + | Record_float -> Psetfloatfield lbl.lbl_pos in + Lsequence(Lprim(upd, [Lvar copy_id; transl_exp expr]), cont) in + begin match opt_init_expr with + None -> assert false + | Some init_expr -> + Llet(Strict, copy_id, + Lprim(Pccall prim_obj_dup, [transl_exp init_expr]), + List.fold_right update_field lbl_expr_list (Lvar copy_id)) + end + end + +(* Compile an exception definition *) + +let transl_exception id path decl = + let name = + match path with + None -> Ident.name id + | Some p -> Path.name p in + Lprim(Pmakeblock(0, Immutable), [Lconst(Const_base(Const_string name))]) + +(* Error report *) + +open Format + +let report_error ppf = function + | Illegal_letrec_pat -> + fprintf ppf + "Only variables are allowed as left-hand side of `let rec'" + | Illegal_letrec_expr -> + fprintf ppf + "This kind of expression is not allowed as right-hand side of `let rec'" + | Free_super_var -> + fprintf ppf + "Ancestor names can only be used to select inherited methods" diff --git a/bytecomp/translcore.mli b/bytecomp/translcore.mli new file mode 100644 index 00000000..2b7d01d0 --- /dev/null +++ b/bytecomp/translcore.mli @@ -0,0 +1,48 @@ +(***********************************************************************) +(* *) +(* 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: translcore.mli,v 1.17 2000/09/04 08:49:31 garrigue Exp $ *) + +(* Translation from typed abstract syntax to lambda terms, + for the core language *) + +open Asttypes +open Types +open Typedtree +open Lambda + +val name_pattern: string -> (pattern * 'a) list -> Ident.t + +val transl_exp: expression -> lambda +val transl_apply: lambda -> (expression option * optional) list -> lambda +val transl_let: + rec_flag -> (pattern * expression) list -> lambda -> lambda +val transl_primitive: Primitive.description -> lambda +val transl_exception: + Ident.t -> Path.t option -> exception_declaration -> lambda + +val check_recursive_lambda: Ident.t list -> lambda -> bool + +type error = + Illegal_letrec_pat + | Illegal_letrec_expr + | Free_super_var + +exception Error of Location.t * error + +open Format + +val report_error: formatter -> error -> unit + +(* Forward declaration -- to be filled in by Translmod.transl_module *) +val transl_module : + (module_coercion -> Path.t option -> module_expr -> lambda) ref diff --git a/bytecomp/translmod.ml b/bytecomp/translmod.ml new file mode 100644 index 00000000..11eaec52 --- /dev/null +++ b/bytecomp/translmod.ml @@ -0,0 +1,684 @@ +(***********************************************************************) +(* *) +(* 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: translmod.ml,v 1.44 2003/07/07 13:42:49 xleroy Exp $ *) + +(* Translation from typed abstract syntax to lambda terms, + for the module language *) + +open Misc +open Asttypes +open Path +open Types +open Typedtree +open Primitive +open Lambda +open Translobj +open Translcore +open Translclass + +type error = + Circular_dependency of Ident.t + +exception Error of Location.t * error + +(* Compile a coercion *) + +let rec apply_coercion restr arg = + match restr with + Tcoerce_none -> + arg + | Tcoerce_structure pos_cc_list -> + name_lambda arg (fun id -> + Lprim(Pmakeblock(0, Immutable), + List.map (apply_coercion_field id) pos_cc_list)) + | Tcoerce_functor(cc_arg, cc_res) -> + let param = Ident.create "funarg" in + name_lambda arg (fun id -> + Lfunction(Curried, [param], + apply_coercion cc_res + (Lapply(Lvar id, [apply_coercion cc_arg (Lvar param)])))) + | Tcoerce_primitive p -> + transl_primitive p + +and apply_coercion_field id (pos, cc) = + apply_coercion cc (Lprim(Pfield pos, [Lvar id])) + +(* Compose two coercions + apply_coercion c1 (apply_coercion c2 e) behaves like + apply_coercion (compose_coercions c1 c2) e. *) + +let rec compose_coercions c1 c2 = + match (c1, c2) with + (Tcoerce_none, c2) -> c2 + | (c1, Tcoerce_none) -> c1 + | (Tcoerce_structure pc1, Tcoerce_structure pc2) -> + let v2 = Array.of_list pc2 in + Tcoerce_structure + (List.map + (function (p1, Tcoerce_primitive p) -> + (p1, Tcoerce_primitive p) + | (p1, c1) -> + let (p2, c2) = v2.(p1) in (p2, compose_coercions c1 c2)) + pc1) + | (Tcoerce_functor(arg1, res1), Tcoerce_functor(arg2, res2)) -> + Tcoerce_functor(compose_coercions arg2 arg1, + compose_coercions res1 res2) + | (_, _) -> + fatal_error "Translmod.compose_coercions" + +(* Record the primitive declarations occuring in the module compiled *) + +let primitive_declarations = ref ([] : string list) + +(* Keep track of the root path (from the root of the namespace to the + currently compiled module expression). Useful for naming exceptions. *) + +let global_path glob = Some(Pident glob) +let functor_path path param = + match path with + None -> None + | Some p -> Some(Papply(p, Pident param)) +let field_path path field = + match path with + None -> None + | Some p -> Some(Pdot(p, Ident.name field, Path.nopos)) + +(* Utilities for compiling "module rec" definitions *) + +let undefined_exception loc = + (* Confer Translcore.assert_failed *) + let fname = match loc.Location.loc_start.Lexing.pos_fname with + | "" -> !Location.input_name + | x -> x in + let pos = loc.Location.loc_start in + let line = pos.Lexing.pos_lnum in + let char = pos.Lexing.pos_cnum - pos.Lexing.pos_bol in + Lprim(Pmakeblock(0, Immutable), + [transl_path Predef.path_undefined_recursive_module; + Lconst(Const_block(0, + [Const_base(Const_string fname); + Const_base(Const_int line); + Const_base(Const_int char)]))]) + +let undefined_function loc = + Lfunction(Curried, [Ident.create "undef"], + Lprim(Praise, [undefined_exception loc])) + +let init_value modl = + let undef_exn_id = Ident.create "undef_exception" in + let undef_function_id = Ident.create "undef_function" in + let rec init_value_mod env mty = + match Mtype.scrape env mty with + Tmty_ident _ -> + raise Not_found + | Tmty_signature sg -> + Lprim(Pmakeblock(0, Mutable), init_value_struct env sg) + | Tmty_functor(id, arg, res) -> + raise Not_found (* to be fixed? *) + and init_value_struct env sg = + match sg with + [] -> [] + | Tsig_value(id, vdesc) :: rem -> + let init_v = + match Ctype.expand_head env vdesc.val_type with + {desc = Tarrow(_,_,_,_)} -> + Lvar undef_function_id + | {desc = Tconstr(p, _, _)} when Path.same p Predef.path_lazy_t -> + Lprim(Pmakeblock(Config.lazy_tag, Immutable), + [Lvar undef_function_id]) + | _ -> raise Not_found in + init_v :: init_value_struct env rem + | Tsig_type(id, tdecl) :: rem -> + init_value_struct (Env.add_type id tdecl env) rem + | Tsig_exception(id, edecl) :: rem -> + transl_exception + id (Some Predef.path_undefined_recursive_module) edecl :: + init_value_struct env rem + | Tsig_module(id, mty) :: rem -> + init_value_mod env mty :: + init_value_struct (Env.add_module id mty env) rem + | Tsig_modtype(id, minfo) :: rem -> + init_value_struct (Env.add_modtype id minfo env) rem + | Tsig_class(id, cdecl) :: rem -> + Translclass.dummy_class (Lvar undef_function_id) :: + init_value_struct env rem + | Tsig_cltype(id, ctyp) :: rem -> + init_value_struct env rem + in + try + Some(Llet(Alias, undef_function_id, undefined_function modl.mod_loc, + init_value_mod modl.mod_env modl.mod_type)) + with Not_found -> + None + +(* Reorder bindings to honor dependencies. *) + +type binding_status = Undefined | Inprogress | Defined + +let reorder_rec_bindings bindings = + let id = Array.of_list (List.map (fun (id,_,_,_) -> id) bindings) + and loc = Array.of_list (List.map (fun (_,loc,_,_) -> loc) bindings) + and init = Array.of_list (List.map (fun (_,_,init,_) -> init) bindings) + and rhs = Array.of_list (List.map (fun (_,_,_,rhs) -> rhs) bindings) in + let fv = Array.map Lambda.free_variables rhs in + let num_bindings = Array.length id in + let status = Array.create num_bindings Undefined in + let res = ref [] in + let rec emit_binding i = + match status.(i) with + Defined -> () + | Inprogress -> raise(Error(loc.(i), Circular_dependency id.(i))) + | Undefined -> + if init.(i) = None then begin + status.(i) <- Inprogress; + for j = 0 to num_bindings - 1 do + if IdentSet.mem id.(j) fv.(i) then emit_binding j + done + end; + res := (id.(i), init.(i), rhs.(i)) :: !res; + status.(i) <- Defined in + for i = 0 to num_bindings - 1 do + match status.(i) with + Undefined -> emit_binding i + | Inprogress -> assert false + | Defined -> () + done; + List.rev !res + +(* Generate lambda-code for a reordered list of bindings *) + +let prim_update = + { prim_name = "update_dummy"; + prim_arity = 2; + prim_alloc = true; + prim_native_name = ""; + prim_native_float = false } + +let eval_rec_bindings bindings cont = + let rec bind_inits = function + [] -> + bind_strict bindings + | (id, None, rhs) :: rem -> + bind_inits rem + | (id, Some init, rhs) :: rem -> + Llet(Strict, id, init, bind_inits rem) + and bind_strict = function + [] -> + patch_forwards bindings + | (id, None, rhs) :: rem -> + Llet(Strict, id, rhs, bind_strict rem) + | (id, Some init, rhs) :: rem -> + bind_strict rem + and patch_forwards = function + [] -> + cont + | (id, None, rhs) :: rem -> + patch_forwards rem + | (id, Some init, rhs) :: rem -> + Lsequence(Lprim(Pccall prim_update, [Lvar id; rhs]), patch_forwards rem) + in + bind_inits bindings + +let compile_recmodule compile_rhs bindings cont = + eval_rec_bindings + (reorder_rec_bindings + (List.map + (fun (id, modl) -> + (id, modl.mod_loc, init_value modl, compile_rhs id modl)) + bindings)) + cont + +(* Compile a module expression *) + +let rec transl_module cc rootpath mexp = + match mexp.mod_desc with + Tmod_ident path -> + apply_coercion cc (transl_path path) + | Tmod_structure str -> + transl_structure [] cc rootpath str + | Tmod_functor(param, mty, body) -> + let bodypath = functor_path rootpath param in + begin match cc with + Tcoerce_none -> + Lfunction(Curried, [param], transl_module Tcoerce_none bodypath body) + | Tcoerce_functor(ccarg, ccres) -> + let param' = Ident.create "funarg" in + Lfunction(Curried, [param'], + Llet(Alias, param, apply_coercion ccarg (Lvar param'), + transl_module ccres bodypath body)) + | _ -> + fatal_error "Translmod.transl_module" + end + | Tmod_apply(funct, arg, ccarg) -> + apply_coercion cc + (Lapply(transl_module Tcoerce_none None funct, + [transl_module ccarg None arg])) + | Tmod_constraint(arg, mty, ccarg) -> + transl_module (compose_coercions cc ccarg) rootpath arg + +and transl_structure fields cc rootpath = function + [] -> + begin match cc with + Tcoerce_none -> + Lprim(Pmakeblock(0, Immutable), + List.map (fun id -> Lvar id) (List.rev fields)) + | Tcoerce_structure pos_cc_list -> + let v = Array.of_list (List.rev fields) in + Lprim(Pmakeblock(0, Immutable), + List.map + (fun (pos, cc) -> + match cc with + Tcoerce_primitive p -> transl_primitive p + | _ -> apply_coercion cc (Lvar v.(pos))) + pos_cc_list) + | _ -> + fatal_error "Translmod.transl_structure" + end + | Tstr_eval expr :: rem -> + Lsequence(transl_exp expr, transl_structure fields cc rootpath rem) + | Tstr_value(rec_flag, pat_expr_list) :: rem -> + let ext_fields = rev_let_bound_idents pat_expr_list @ fields in + transl_let rec_flag pat_expr_list + (transl_structure ext_fields cc rootpath rem) + | Tstr_primitive(id, descr) :: rem -> + begin match descr.val_kind with + Val_prim p -> primitive_declarations := + p.Primitive.prim_name :: !primitive_declarations + | _ -> () + end; + transl_structure fields cc rootpath rem + | Tstr_type(decls) :: rem -> + transl_structure fields cc rootpath rem + | Tstr_exception(id, decl) :: rem -> + Llet(Strict, id, transl_exception id (field_path rootpath id) decl, + transl_structure (id :: fields) cc rootpath rem) + | Tstr_exn_rebind(id, path) :: rem -> + Llet(Strict, id, transl_path path, + transl_structure (id :: fields) cc rootpath rem) + | Tstr_module(id, modl) :: rem -> + Llet(Strict, id, + transl_module Tcoerce_none (field_path rootpath id) modl, + transl_structure (id :: fields) cc rootpath rem) + | Tstr_recmodule bindings :: rem -> + compile_recmodule + (fun id modl -> + transl_module Tcoerce_none (field_path rootpath id) modl) + bindings + (transl_structure (map_end fst bindings fields) cc rootpath rem) + | Tstr_modtype(id, decl) :: rem -> + transl_structure fields cc rootpath rem + | Tstr_open path :: rem -> + transl_structure fields cc rootpath rem + | Tstr_class cl_list :: rem -> + let ids = List.map (fun (i, _, _, _) -> i) cl_list in + Lletrec(List.map + (fun (id, arity, meths, cl) -> + (id, transl_class ids id arity meths cl)) + cl_list, + transl_structure (List.rev ids @ fields) cc rootpath rem) + | Tstr_cltype cl_list :: rem -> + transl_structure fields cc rootpath rem + | Tstr_include(modl, ids) :: rem -> + let mid = Ident.create "include" in + let rec rebind_idents pos newfields = function + [] -> + transl_structure newfields cc rootpath rem + | id :: ids -> + Llet(Alias, id, Lprim(Pfield pos, [Lvar mid]), + rebind_idents (pos + 1) (id :: newfields) ids) in + Llet(Alias, mid, transl_module Tcoerce_none None modl, + rebind_idents 0 fields ids) + +(* Update forward declaration in Translcore *) +let _ = + Translcore.transl_module := transl_module + +(* Compile an implementation *) + +let transl_implementation module_name (str, cc) = + reset_labels (); + primitive_declarations := []; + let module_id = Ident.create_persistent module_name in + Lprim(Psetglobal module_id, + [transl_label_init + (transl_structure [] cc (global_path module_id) str)]) + +(* A variant of transl_structure used to compile toplevel structure definitions + for the native-code compiler. Store the defined values in the fields + of the global as soon as they are defined, in order to reduce register + pressure. Also rewrites the defining expressions so that they + refer to earlier fields of the structure through the fields of + the global, not by their names. + "map" is a table from defined idents to (pos in global block, coercion). + "prim" is a list of (pos in global block, primitive declaration). *) + +let transl_store_structure glob map prims str = + let rec transl_store subst = function + [] -> + lambda_unit + | Tstr_eval expr :: rem -> + Lsequence(subst_lambda subst (transl_exp expr), + transl_store subst rem) + | Tstr_value(rec_flag, pat_expr_list) :: rem -> + let ids = let_bound_idents pat_expr_list in + let lam = transl_let rec_flag pat_expr_list (store_idents ids) in + Lsequence(subst_lambda subst lam, + transl_store (add_idents false ids subst) rem) + | Tstr_primitive(id, descr) :: rem -> + begin match descr.val_kind with + Val_prim p -> primitive_declarations := + p.Primitive.prim_name :: !primitive_declarations + | _ -> () + end; + transl_store subst rem + | Tstr_type(decls) :: rem -> + transl_store subst rem + | Tstr_exception(id, decl) :: rem -> + let lam = transl_exception id (field_path (global_path glob) id) decl in + Lsequence(Llet(Strict, id, lam, store_ident id), + transl_store (add_ident false id subst) rem) + | Tstr_exn_rebind(id, path) :: rem -> + let lam = subst_lambda subst (transl_path path) in + Lsequence(Llet(Strict, id, lam, store_ident id), + transl_store (add_ident false id subst) rem) + | Tstr_module(id, modl) :: rem -> + let lam = + transl_module Tcoerce_none (field_path (global_path glob) id) modl in + (* Careful: the module value stored in the global may be different + from the local module value, in case a coercion is applied. + If so, keep using the local module value (id) in the remainder of + the compilation unit (add_ident true returns subst unchanged). + If not, we can use the value from the global + (add_ident true adds id -> Pgetglobal... to subst). *) + Llet(Strict, id, subst_lambda subst lam, + Lsequence(store_ident id, transl_store(add_ident true id subst) rem)) + | Tstr_recmodule bindings :: rem -> + let ids = List.map fst bindings in + compile_recmodule + (fun id modl -> + subst_lambda subst + (transl_module Tcoerce_none + (field_path (global_path glob) id) modl)) + bindings + (Lsequence(store_idents ids, + transl_store (add_idents true ids subst) rem)) + | Tstr_modtype(id, decl) :: rem -> + transl_store subst rem + | Tstr_open path :: rem -> + transl_store subst rem + | Tstr_class cl_list :: rem -> + let ids = List.map (fun (i, _, _, _) -> i) cl_list in + let lam = + Lletrec(List.map + (fun (id, arity, meths, cl) -> + (id, transl_class ids id arity meths cl)) + cl_list, + store_idents ids) in + Lsequence(subst_lambda subst lam, + transl_store (add_idents false ids subst) rem) + | Tstr_cltype cl_list :: rem -> + transl_store subst rem + | Tstr_include(modl, ids) :: rem -> + let mid = Ident.create "include" in + let rec store_idents pos = function + [] -> transl_store (add_idents true ids subst) rem + | id :: idl -> + Llet(Alias, id, Lprim(Pfield pos, [Lvar mid]), + Lsequence(store_ident id, store_idents (pos + 1) idl)) in + Llet(Strict, mid, + subst_lambda subst (transl_module Tcoerce_none None modl), + store_idents 0 ids) + + and store_ident id = + try + let (pos, cc) = Ident.find_same id map in + let init_val = apply_coercion cc (Lvar id) in + Lprim(Psetfield(pos, false), [Lprim(Pgetglobal glob, []); init_val]) + with Not_found -> + fatal_error("Translmod.store_ident: " ^ Ident.unique_name id) + + and store_idents idlist = + make_sequence store_ident idlist + + and add_ident may_coerce id subst = + try + let (pos, cc) = Ident.find_same id map in + match cc with + Tcoerce_none -> + Ident.add id (Lprim(Pfield pos, [Lprim(Pgetglobal glob, [])])) subst + | _ -> + if may_coerce then subst else assert false + with Not_found -> + assert false + + and add_idents may_coerce idlist subst = + List.fold_right (add_ident may_coerce) idlist subst + + and store_primitive (pos, prim) cont = + Lsequence(Lprim(Psetfield(pos, false), + [Lprim(Pgetglobal glob, []); transl_primitive prim]), + cont) + + in List.fold_right store_primitive prims (transl_store Ident.empty str) + +(* Build the list of value identifiers defined by a toplevel structure + (excluding primitive declarations). *) + +let rec defined_idents = function + [] -> [] + | Tstr_eval expr :: rem -> defined_idents rem + | Tstr_value(rec_flag, pat_expr_list) :: rem -> + let_bound_idents pat_expr_list @ defined_idents rem + | Tstr_primitive(id, descr) :: rem -> defined_idents rem + | Tstr_type decls :: rem -> defined_idents rem + | Tstr_exception(id, decl) :: rem -> id :: defined_idents rem + | Tstr_exn_rebind(id, path) :: rem -> id :: defined_idents rem + | Tstr_module(id, modl) :: rem -> id :: defined_idents rem + | Tstr_recmodule decls :: rem -> List.map fst decls @ defined_idents rem + | Tstr_modtype(id, decl) :: rem -> defined_idents rem + | Tstr_open path :: rem -> defined_idents rem + | Tstr_class cl_list :: rem -> + List.map (fun (i, _, _, _) -> i) cl_list @ defined_idents rem + | Tstr_cltype cl_list :: rem -> defined_idents rem + | Tstr_include(modl, ids) :: rem -> ids @ defined_idents rem + +(* Transform a coercion and the list of value identifiers defined by + a toplevel structure into a table [id -> (pos, coercion)], + with [pos] being the position in the global block where the value of + [id] must be stored, and [coercion] the coercion to be applied to it. + A given identifier may appear several times + in the coercion (if it occurs several times in the signature); remember + to assign it the position of its last occurrence. + Identifiers that are not exported are assigned positions at the + end of the block (beyond the positions of all exported idents). + Also compute the total size of the global block, + and the list of all primitives exported as values. *) + +let build_ident_map restr idlist = + let rec natural_map pos map prims = function + [] -> + (map, prims, pos) + | id :: rem -> + natural_map (pos+1) (Ident.add id (pos, Tcoerce_none) map) prims rem in + match restr with + Tcoerce_none -> + natural_map 0 Ident.empty [] idlist + | Tcoerce_structure pos_cc_list -> + let idarray = Array.of_list idlist in + let rec export_map pos map prims undef = function + [] -> + natural_map pos map prims undef + | (source_pos, Tcoerce_primitive p) :: rem -> + export_map (pos + 1) map ((pos, p) :: prims) undef rem + | (source_pos, cc) :: rem -> + let id = idarray.(source_pos) in + export_map (pos + 1) (Ident.add id (pos, cc) map) + prims (list_remove id undef) rem + in export_map 0 Ident.empty [] idlist pos_cc_list + | _ -> + fatal_error "Translmod.build_ident_map" + +(* Compile an implementation using transl_store_structure + (for the native-code compiler). *) + +let transl_store_implementation module_name (str, restr) = + reset_labels (); + primitive_declarations := []; + let module_id = Ident.create_persistent module_name in + let (map, prims, size) = build_ident_map restr (defined_idents str) in + (size, transl_label_init (transl_store_structure module_id map prims str)) + +(* Compile a toplevel phrase *) + +let toploop_ident = Ident.create_persistent "Toploop" +let toploop_getvalue_pos = 0 (* position of getvalue in module Toploop *) +let toploop_setvalue_pos = 1 (* position of setvalue in module Toploop *) + +let aliased_idents = ref Ident.empty + +let set_toplevel_unique_name id = + aliased_idents := + Ident.add id (Ident.unique_toplevel_name id) !aliased_idents + +let toplevel_name id = + try Ident.find_same id !aliased_idents + with Not_found -> Ident.name id + +let toploop_getvalue id = + Lapply(Lprim(Pfield toploop_getvalue_pos, + [Lprim(Pgetglobal toploop_ident, [])]), + [Lconst(Const_base(Const_string (toplevel_name id)))]) + +let toploop_setvalue id lam = + Lapply(Lprim(Pfield toploop_setvalue_pos, + [Lprim(Pgetglobal toploop_ident, [])]), + [Lconst(Const_base(Const_string (toplevel_name id))); lam]) + +let toploop_setvalue_id id = toploop_setvalue id (Lvar id) + +let close_toplevel_term lam = + IdentSet.fold (fun id l -> Llet(Strict, id, toploop_getvalue id, l)) + (free_variables lam) lam + +let transl_toplevel_item = function + Tstr_eval expr -> + transl_exp expr + | Tstr_value(rec_flag, pat_expr_list) -> + let idents = let_bound_idents pat_expr_list in + transl_let rec_flag pat_expr_list + (make_sequence toploop_setvalue_id idents) + | Tstr_primitive(id, descr) -> + lambda_unit + | Tstr_type(decls) -> + lambda_unit + | Tstr_exception(id, decl) -> + toploop_setvalue id (transl_exception id None decl) + | Tstr_exn_rebind(id, path) -> + toploop_setvalue id (transl_path path) + | Tstr_module(id, modl) -> + (* we need to use the unique name for the module because of issues + with "open" (PR#1672) *) + set_toplevel_unique_name id; + toploop_setvalue id + (transl_module Tcoerce_none (Some(Pident id)) modl) + | Tstr_recmodule bindings -> + let idents = List.map fst bindings in + compile_recmodule + (fun id modl -> transl_module Tcoerce_none (Some(Pident id)) modl) + bindings + (make_sequence toploop_setvalue_id idents) + | Tstr_modtype(id, decl) -> + lambda_unit + | Tstr_open path -> + lambda_unit + | Tstr_class cl_list -> + (* we need to use unique names for the classes because there might + be a value named identically *) + let ids = List.map (fun (i, _, _, _) -> i) cl_list in + List.iter set_toplevel_unique_name ids; + Lletrec(List.map + (fun (id, arity, meths, cl) -> + (id, transl_class ids id arity meths cl)) + cl_list, + make_sequence + (fun (id, _, _, _) -> toploop_setvalue_id id) + cl_list) + | Tstr_cltype cl_list -> + lambda_unit + | Tstr_include(modl, ids) -> + let mid = Ident.create "include" in + let rec set_idents pos = function + [] -> + lambda_unit + | id :: ids -> + Lsequence(toploop_setvalue id (Lprim(Pfield pos, [Lvar mid])), + set_idents (pos + 1) ids) in + Llet(Strict, mid, transl_module Tcoerce_none None modl, set_idents 0 ids) + +let transl_toplevel_item_and_close itm = + close_toplevel_term (transl_label_init (transl_toplevel_item itm)) + +let transl_toplevel_definition str = + reset_labels (); + make_sequence transl_toplevel_item_and_close str + +(* Compile the initialization code for a packed library *) + +let transl_package component_names target_name coercion = + let components = + match coercion with + Tcoerce_none -> + List.map (fun id -> Lprim(Pgetglobal id, [])) component_names + | Tcoerce_structure pos_cc_list -> + let g = Array.of_list component_names in + List.map + (fun (pos, cc) -> apply_coercion cc (Lprim(Pgetglobal g.(pos), []))) + pos_cc_list + | _ -> + assert false in + Lprim(Psetglobal target_name, [Lprim(Pmakeblock(0, Immutable), components)]) + +let transl_store_package component_names target_name coercion = + let rec make_sequence fn pos arg = + match arg with + [] -> lambda_unit + | hd :: tl -> Lsequence(fn pos hd, make_sequence fn (pos + 1) tl) in + match coercion with + Tcoerce_none -> + (List.length component_names, + make_sequence + (fun pos id -> + Lprim(Psetfield(pos, false), + [Lprim(Pgetglobal target_name, []); + Lprim(Pgetglobal id, [])])) + 0 component_names) + | Tcoerce_structure pos_cc_list -> + let id = Array.of_list component_names in + (List.length pos_cc_list, + make_sequence + (fun dst (src, cc) -> + Lprim(Psetfield(dst, false), + [Lprim(Pgetglobal target_name, []); + apply_coercion cc (Lprim(Pgetglobal id.(src), []))])) + 0 pos_cc_list) + | _ -> assert false + +(* Error report *) + +open Format + +let report_error ppf = function + Circular_dependency id -> + fprintf ppf + "@[Cannot safely evaluate the definition@ of the recursively-defined module %a@]" + Printtyp.ident id diff --git a/bytecomp/translmod.mli b/bytecomp/translmod.mli new file mode 100644 index 00000000..402e2fea --- /dev/null +++ b/bytecomp/translmod.mli @@ -0,0 +1,38 @@ +(***********************************************************************) +(* *) +(* 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: translmod.mli,v 1.11 2003/06/19 15:53:48 xleroy Exp $ *) + +(* Translation from typed abstract syntax to lambda terms, + for the module language *) + +open Typedtree +open Lambda + +val transl_implementation: string -> structure * module_coercion -> lambda +val transl_store_implementation: + string -> structure * module_coercion -> int * lambda +val transl_toplevel_definition: structure -> lambda +val transl_package: Ident.t list -> Ident.t -> module_coercion -> lambda +val transl_store_package: + Ident.t list -> Ident.t -> module_coercion -> int * lambda + +val toplevel_name: Ident.t -> string + +val primitive_declarations: string list ref + +type error = + Circular_dependency of Ident.t + +exception Error of Location.t * error + +val report_error: Format.formatter -> error -> unit diff --git a/bytecomp/translobj.ml b/bytecomp/translobj.ml new file mode 100644 index 00000000..2013cbbc --- /dev/null +++ b/bytecomp/translobj.ml @@ -0,0 +1,62 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Jerome Vouillon, 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: translobj.ml,v 1.7 2002/04/24 09:49:05 xleroy Exp $ *) + +open Misc +open Asttypes +open Longident +open Lambda + +(* Get oo primitives identifiers *) + +let oo_prim name = + try + transl_path + (fst (Env.lookup_value (Ldot (Lident "CamlinternalOO", name)) Env.empty)) + with Not_found -> + fatal_error ("Primitive " ^ name ^ " not found.") + +(* Collect labels *) + +let used_methods = ref ([] : (string * Ident.t) list);; + +let meth lab = + try + List.assoc lab !used_methods + with Not_found -> + let id = Ident.create lab in + used_methods := (lab, id)::!used_methods; + id + +let reset_labels () = + used_methods := [] + +(* Insert labels *) + +let string s = Lconst (Const_base (Const_string s)) + +let transl_label_init expr = + if !used_methods = [] then + expr + else + let init = Ident.create "new_method" in + let expr' = + Llet(StrictOpt, init, oo_prim "new_method", + List.fold_right + (fun (lab, id) expr -> + Llet(StrictOpt, id, Lapply(Lvar init, [string lab]), expr)) + !used_methods + expr) + in + reset_labels (); + expr' diff --git a/bytecomp/translobj.mli b/bytecomp/translobj.mli new file mode 100644 index 00000000..acb5bc98 --- /dev/null +++ b/bytecomp/translobj.mli @@ -0,0 +1,20 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Jerome Vouillon, 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: translobj.mli,v 1.4 1999/11/17 18:57:03 xleroy Exp $ *) + +val oo_prim: string -> Lambda.lambda + +val meth: string -> Ident.t + +val reset_labels: unit -> unit +val transl_label_init: Lambda.lambda -> Lambda.lambda diff --git a/bytecomp/typeopt.ml b/bytecomp/typeopt.ml new file mode 100644 index 00000000..997a00dc --- /dev/null +++ b/bytecomp/typeopt.ml @@ -0,0 +1,133 @@ +(***********************************************************************) +(* *) +(* 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 Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: typeopt.ml,v 1.9 2003/07/02 09:14:29 xleroy Exp $ *) + +(* Auxiliaries for type-based optimizations, e.g. array kinds *) + +open Misc +open Asttypes +open Primitive +open Path +open Types +open Typedtree +open Lambda + +let has_base_type exp base_ty_path = + let exp_ty = + Ctype.expand_head exp.exp_env (Ctype.correct_levels exp.exp_type) in + match Ctype.repr exp_ty with + {desc = Tconstr(p, _, _)} -> Path.same p base_ty_path + | _ -> false + +let maybe_pointer exp = + let exp_ty = + Ctype.expand_head exp.exp_env (Ctype.correct_levels exp.exp_type) in + match (Ctype.repr exp_ty).desc with + Tconstr(p, args, abbrev) -> + not (Path.same p Predef.path_int) && + not (Path.same p Predef.path_char) && + begin try + match Env.find_type p exp.exp_env with + {type_kind = Type_variant([], _)} -> true (* type exn *) + | {type_kind = Type_variant(cstrs, _)} -> + List.exists (fun (name, args) -> args <> []) cstrs + | _ -> true + with Not_found -> true + (* This can happen due to e.g. missing -I options, + causing some .cmi files to be unavailable. + Maybe we should emit a warning. *) + end + | _ -> true + +let array_element_kind env ty = + let ty = Ctype.repr (Ctype.expand_head env ty) in + match ty.desc with + Tvar -> + Pgenarray + | Tconstr(p, args, abbrev) -> + if Path.same p Predef.path_int || Path.same p Predef.path_char then + Pintarray + else if Path.same p Predef.path_float then + Pfloatarray + else if Path.same p Predef.path_string + || Path.same p Predef.path_array + || Path.same p Predef.path_nativeint + || Path.same p Predef.path_int32 + || Path.same p Predef.path_int64 then + Paddrarray + else begin + try + match Env.find_type p env with + {type_kind = Type_abstract} -> + Pgenarray + | {type_kind = Type_variant(cstrs, _)} + when List.for_all (fun (name, args) -> args = []) cstrs -> + Pintarray + | {type_kind = _} -> + Paddrarray + with Not_found -> + (* This can happen due to e.g. missing -I options, + causing some .cmi files to be unavailable. + Maybe we should emit a warning. *) + Pgenarray + end + | _ -> + Paddrarray + +let array_kind_gen ty env = + let array_ty = Ctype.expand_head env (Ctype.correct_levels ty) in + match (Ctype.repr array_ty).desc with + Tconstr(p, [elt_ty], _) when Path.same p Predef.path_array -> + array_element_kind env elt_ty + | _ -> + (* This can happen with e.g. Obj.field *) + Pgenarray + +let array_kind exp = array_kind_gen exp.exp_type exp.exp_env + +let array_pattern_kind pat = array_kind_gen pat.pat_type pat.pat_env + +let bigarray_decode_type ty tbl dfl = + match (Ctype.repr ty).desc with + Tconstr(Pdot(Pident mod_id, type_name, _), [], _) + when Ident.name mod_id = "Bigarray" -> + begin try List.assoc type_name tbl with Not_found -> dfl end + | _ -> + dfl + +let kind_table = + ["float32_elt", Pbigarray_float32; + "float64_elt", Pbigarray_float64; + "int8_signed_elt", Pbigarray_sint8; + "int8_unsigned_elt", Pbigarray_uint8; + "int16_signed_elt", Pbigarray_sint16; + "int16_unsigned_elt", Pbigarray_uint16; + "int32_elt", Pbigarray_int32; + "int64_elt", Pbigarray_int64; + "int_elt", Pbigarray_caml_int; + "nativeint_elt", Pbigarray_native_int; + "complex32_elt", Pbigarray_complex32; + "complex64_elt", Pbigarray_complex64] + +let layout_table = + ["c_layout", Pbigarray_c_layout; + "fortran_layout", Pbigarray_fortran_layout] + +let bigarray_kind_and_layout exp = + let ty = Ctype.repr (Ctype.expand_head exp.exp_env exp.exp_type) in + match ty.desc with + Tconstr(p, [caml_type; elt_type; layout_type], abbrev) -> + (bigarray_decode_type elt_type kind_table Pbigarray_unknown, + bigarray_decode_type layout_type layout_table Pbigarray_unknown_layout) + | _ -> + (Pbigarray_unknown, Pbigarray_unknown_layout) diff --git a/bytecomp/typeopt.mli b/bytecomp/typeopt.mli new file mode 100644 index 00000000..d057be61 --- /dev/null +++ b/bytecomp/typeopt.mli @@ -0,0 +1,22 @@ +(***********************************************************************) +(* *) +(* 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 Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: typeopt.mli,v 1.4 2000/02/28 15:45:50 xleroy Exp $ *) + +(* Auxiliaries for type-based optimizations, e.g. array kinds *) + +val has_base_type : Typedtree.expression -> Path.t -> bool +val maybe_pointer : Typedtree.expression -> bool +val array_kind : Typedtree.expression -> Lambda.array_kind +val array_pattern_kind : Typedtree.pattern -> Lambda.array_kind +val bigarray_kind_and_layout : + Typedtree.expression -> Lambda.bigarray_kind * Lambda.bigarray_layout diff --git a/byterun/.cvsignore b/byterun/.cvsignore new file mode 100644 index 00000000..351addb4 --- /dev/null +++ b/byterun/.cvsignore @@ -0,0 +1,14 @@ +jumptbl.h +primitives +prims.c +opnames.h +ocamlrun +ocamlrund +libcamlrun.x +libcamlrun-gui.x +*.c.x +ocamlrun.xcoff +ocamlrun.dbg +interp.a.lst +*.[sd]obj +*.lib diff --git a/byterun/.depend b/byterun/.depend new file mode 100644 index 00000000..e80d3cfa --- /dev/null +++ b/byterun/.depend @@ -0,0 +1,249 @@ +alloc.o: alloc.c alloc.h misc.h config.h ../config/m.h ../config/s.h \ + mlvalues.h custom.h major_gc.h freelist.h memory.h gc.h minor_gc.h \ + stacks.h +array.o: array.c alloc.h misc.h config.h ../config/m.h ../config/s.h \ + mlvalues.h fail.h memory.h gc.h major_gc.h freelist.h minor_gc.h +backtrace.o: backtrace.c config.h ../config/m.h ../config/s.h mlvalues.h \ + misc.h alloc.h io.h instruct.h intext.h fix_code.h exec.h startup.h \ + stacks.h memory.h gc.h major_gc.h freelist.h minor_gc.h sys.h \ + backtrace.h +callback.o: callback.c callback.h mlvalues.h config.h ../config/m.h \ + ../config/s.h misc.h fail.h memory.h gc.h major_gc.h freelist.h \ + minor_gc.h interp.h instruct.h fix_code.h stacks.h +compact.o: compact.c config.h ../config/m.h ../config/s.h finalise.h \ + roots.h misc.h memory.h gc.h mlvalues.h major_gc.h freelist.h \ + minor_gc.h gc_ctrl.h weak.h +compare.o: compare.c custom.h mlvalues.h config.h ../config/m.h \ + ../config/s.h misc.h fail.h memory.h gc.h major_gc.h freelist.h \ + minor_gc.h +custom.o: custom.c alloc.h misc.h config.h ../config/m.h ../config/s.h \ + mlvalues.h custom.h fail.h memory.h gc.h major_gc.h freelist.h \ + minor_gc.h +debugger.o: debugger.c config.h ../config/m.h ../config/s.h debugger.h \ + misc.h mlvalues.h fail.h fix_code.h instruct.h intext.h io.h stacks.h \ + memory.h gc.h major_gc.h freelist.h minor_gc.h sys.h +dynlink.o: dynlink.c config.h ../config/m.h ../config/s.h alloc.h misc.h \ + mlvalues.h dynlink.h fail.h memory.h gc.h major_gc.h freelist.h \ + minor_gc.h osdeps.h prims.h +extern.o: extern.c alloc.h misc.h config.h ../config/m.h ../config/s.h \ + mlvalues.h custom.h fail.h gc.h intext.h io.h fix_code.h memory.h \ + major_gc.h freelist.h minor_gc.h reverse.h +fail.o: fail.c alloc.h misc.h config.h ../config/m.h ../config/s.h \ + mlvalues.h fail.h io.h gc.h memory.h major_gc.h freelist.h minor_gc.h \ + printexc.h signals.h stacks.h +finalise.o: finalise.c callback.h mlvalues.h config.h ../config/m.h \ + ../config/s.h misc.h fail.h roots.h memory.h gc.h major_gc.h freelist.h \ + minor_gc.h signals.h +fix_code.o: fix_code.c config.h ../config/m.h ../config/s.h debugger.h \ + misc.h mlvalues.h fix_code.h instruct.h md5.h io.h memory.h gc.h \ + major_gc.h freelist.h minor_gc.h reverse.h +floats.o: floats.c alloc.h misc.h config.h ../config/m.h ../config/s.h \ + mlvalues.h fail.h memory.h gc.h major_gc.h freelist.h minor_gc.h \ + reverse.h stacks.h +freelist.o: freelist.c config.h ../config/m.h ../config/s.h freelist.h \ + misc.h mlvalues.h gc.h gc_ctrl.h major_gc.h +gc_ctrl.o: gc_ctrl.c alloc.h misc.h config.h ../config/m.h ../config/s.h \ + mlvalues.h compact.h custom.h finalise.h roots.h memory.h gc.h \ + major_gc.h freelist.h minor_gc.h gc_ctrl.h stacks.h +globroots.o: globroots.c memory.h config.h ../config/m.h ../config/s.h \ + gc.h mlvalues.h misc.h major_gc.h freelist.h minor_gc.h globroots.h +hash.o: hash.c mlvalues.h config.h ../config/m.h ../config/s.h misc.h \ + custom.h memory.h gc.h major_gc.h freelist.h minor_gc.h +instrtrace.o: instrtrace.c +intern.o: intern.c alloc.h misc.h config.h ../config/m.h ../config/s.h \ + mlvalues.h custom.h fail.h gc.h intext.h io.h fix_code.h memory.h \ + major_gc.h freelist.h minor_gc.h reverse.h +interp.o: interp.c alloc.h misc.h config.h ../config/m.h ../config/s.h \ + mlvalues.h backtrace.h callback.h debugger.h fail.h fix_code.h \ + instrtrace.h instruct.h interp.h major_gc.h freelist.h memory.h gc.h \ + minor_gc.h prims.h signals.h stacks.h jumptbl.h +ints.o: ints.c alloc.h misc.h config.h ../config/m.h ../config/s.h \ + mlvalues.h custom.h fail.h intext.h io.h fix_code.h memory.h gc.h \ + major_gc.h freelist.h minor_gc.h int64_native.h +io.o: io.c config.h ../config/m.h ../config/s.h alloc.h misc.h mlvalues.h \ + custom.h fail.h io.h memory.h gc.h major_gc.h freelist.h minor_gc.h \ + signals.h sys.h +lexing.o: lexing.c fail.h misc.h config.h ../config/m.h ../config/s.h \ + mlvalues.h stacks.h memory.h gc.h major_gc.h freelist.h minor_gc.h +macintosh.o: macintosh.c misc.h config.h ../config/m.h ../config/s.h \ + rotatecursor.h mlvalues.h prims.h +main.o: main.c misc.h config.h ../config/m.h ../config/s.h mlvalues.h \ + sys.h +major_gc.o: major_gc.c compact.h config.h ../config/m.h ../config/s.h \ + misc.h custom.h mlvalues.h fail.h finalise.h roots.h memory.h gc.h \ + major_gc.h freelist.h minor_gc.h gc_ctrl.h weak.h +md5.o: md5.c alloc.h misc.h config.h ../config/m.h ../config/s.h \ + mlvalues.h fail.h md5.h io.h reverse.h +memory.o: memory.c fail.h misc.h config.h ../config/m.h ../config/s.h \ + mlvalues.h freelist.h gc.h gc_ctrl.h major_gc.h memory.h minor_gc.h \ + signals.h +meta.o: meta.c alloc.h misc.h config.h ../config/m.h ../config/s.h \ + mlvalues.h fail.h fix_code.h interp.h major_gc.h freelist.h memory.h \ + gc.h minor_gc.h prims.h stacks.h +minor_gc.o: minor_gc.c config.h ../config/m.h ../config/s.h fail.h misc.h \ + mlvalues.h finalise.h roots.h memory.h gc.h major_gc.h freelist.h \ + minor_gc.h gc_ctrl.h signals.h +misc.o: misc.c config.h ../config/m.h ../config/s.h misc.h memory.h gc.h \ + mlvalues.h major_gc.h freelist.h minor_gc.h +mpwtool.o: mpwtool.c +obj.o: obj.c alloc.h misc.h config.h ../config/m.h ../config/s.h \ + mlvalues.h fail.h gc.h major_gc.h freelist.h memory.h minor_gc.h \ + prims.h +parsing.o: parsing.c config.h ../config/m.h ../config/s.h mlvalues.h \ + misc.h memory.h gc.h major_gc.h freelist.h minor_gc.h alloc.h +prims.o: prims.c mlvalues.h config.h ../config/m.h ../config/s.h misc.h \ + prims.h +printexc.o: printexc.c backtrace.h mlvalues.h config.h ../config/m.h \ + ../config/s.h misc.h callback.h debugger.h fail.h printexc.h +roots.o: roots.c finalise.h roots.h misc.h config.h ../config/m.h \ + ../config/s.h memory.h gc.h mlvalues.h major_gc.h freelist.h minor_gc.h \ + globroots.h stacks.h +rotatecursor.o: rotatecursor.c rotatecursor.h +signals.o: signals.c alloc.h misc.h config.h ../config/m.h ../config/s.h \ + mlvalues.h callback.h fail.h memory.h gc.h major_gc.h freelist.h \ + minor_gc.h roots.h signals.h sys.h +stacks.o: stacks.c config.h ../config/m.h ../config/s.h fail.h misc.h \ + mlvalues.h stacks.h memory.h gc.h major_gc.h freelist.h minor_gc.h +startup.o: startup.c config.h ../config/m.h ../config/s.h alloc.h misc.h \ + mlvalues.h backtrace.h callback.h custom.h debugger.h dynlink.h exec.h \ + fail.h fix_code.h gc_ctrl.h instrtrace.h interp.h intext.h io.h \ + memory.h gc.h major_gc.h freelist.h minor_gc.h osdeps.h prims.h \ + printexc.h reverse.h signals.h stacks.h sys.h startup.h +str.o: str.c alloc.h misc.h config.h ../config/m.h ../config/s.h \ + mlvalues.h fail.h +sys.o: sys.c config.h ../config/m.h ../config/s.h alloc.h misc.h \ + mlvalues.h debugger.h fail.h instruct.h osdeps.h signals.h stacks.h \ + memory.h gc.h major_gc.h freelist.h minor_gc.h sys.h +terminfo.o: terminfo.c config.h ../config/m.h ../config/s.h alloc.h \ + misc.h mlvalues.h fail.h io.h +unix.o: unix.c config.h ../config/m.h ../config/s.h memory.h gc.h \ + mlvalues.h misc.h major_gc.h freelist.h minor_gc.h osdeps.h +weak.o: weak.c alloc.h misc.h config.h ../config/m.h ../config/s.h \ + mlvalues.h fail.h memory.h gc.h major_gc.h freelist.h minor_gc.h +win32.o: win32.c memory.h config.h ../config/m.h ../config/s.h gc.h \ + mlvalues.h misc.h major_gc.h freelist.h minor_gc.h osdeps.h signals.h +alloc.d.o: alloc.c alloc.h misc.h config.h ../config/m.h ../config/s.h \ + mlvalues.h custom.h major_gc.h freelist.h memory.h gc.h minor_gc.h \ + stacks.h +array.d.o: array.c alloc.h misc.h config.h ../config/m.h ../config/s.h \ + mlvalues.h fail.h memory.h gc.h major_gc.h freelist.h minor_gc.h +backtrace.d.o: backtrace.c config.h ../config/m.h ../config/s.h mlvalues.h \ + misc.h alloc.h io.h instruct.h intext.h fix_code.h exec.h startup.h \ + stacks.h memory.h gc.h major_gc.h freelist.h minor_gc.h sys.h \ + backtrace.h +callback.d.o: callback.c callback.h mlvalues.h config.h ../config/m.h \ + ../config/s.h misc.h fail.h memory.h gc.h major_gc.h freelist.h \ + minor_gc.h interp.h instruct.h fix_code.h stacks.h +compact.d.o: compact.c config.h ../config/m.h ../config/s.h finalise.h \ + roots.h misc.h memory.h gc.h mlvalues.h major_gc.h freelist.h \ + minor_gc.h gc_ctrl.h weak.h +compare.d.o: compare.c custom.h mlvalues.h config.h ../config/m.h \ + ../config/s.h misc.h fail.h memory.h gc.h major_gc.h freelist.h \ + minor_gc.h +custom.d.o: custom.c alloc.h misc.h config.h ../config/m.h ../config/s.h \ + mlvalues.h custom.h fail.h memory.h gc.h major_gc.h freelist.h \ + minor_gc.h +debugger.d.o: debugger.c config.h ../config/m.h ../config/s.h debugger.h \ + misc.h mlvalues.h fail.h fix_code.h instruct.h intext.h io.h stacks.h \ + memory.h gc.h major_gc.h freelist.h minor_gc.h sys.h +dynlink.d.o: dynlink.c config.h ../config/m.h ../config/s.h alloc.h misc.h \ + mlvalues.h dynlink.h fail.h memory.h gc.h major_gc.h freelist.h \ + minor_gc.h osdeps.h prims.h +extern.d.o: extern.c alloc.h misc.h config.h ../config/m.h ../config/s.h \ + mlvalues.h custom.h fail.h gc.h intext.h io.h fix_code.h memory.h \ + major_gc.h freelist.h minor_gc.h reverse.h +fail.d.o: fail.c alloc.h misc.h config.h ../config/m.h ../config/s.h \ + mlvalues.h fail.h io.h gc.h memory.h major_gc.h freelist.h minor_gc.h \ + printexc.h signals.h stacks.h +finalise.d.o: finalise.c callback.h mlvalues.h config.h ../config/m.h \ + ../config/s.h misc.h fail.h roots.h memory.h gc.h major_gc.h freelist.h \ + minor_gc.h signals.h +fix_code.d.o: fix_code.c config.h ../config/m.h ../config/s.h debugger.h \ + misc.h mlvalues.h fix_code.h instruct.h md5.h io.h memory.h gc.h \ + major_gc.h freelist.h minor_gc.h reverse.h +floats.d.o: floats.c alloc.h misc.h config.h ../config/m.h ../config/s.h \ + mlvalues.h fail.h memory.h gc.h major_gc.h freelist.h minor_gc.h \ + reverse.h stacks.h +freelist.d.o: freelist.c config.h ../config/m.h ../config/s.h freelist.h \ + misc.h mlvalues.h gc.h gc_ctrl.h major_gc.h +gc_ctrl.d.o: gc_ctrl.c alloc.h misc.h config.h ../config/m.h ../config/s.h \ + mlvalues.h compact.h custom.h finalise.h roots.h memory.h gc.h \ + major_gc.h freelist.h minor_gc.h gc_ctrl.h stacks.h +globroots.d.o: globroots.c memory.h config.h ../config/m.h ../config/s.h \ + gc.h mlvalues.h misc.h major_gc.h freelist.h minor_gc.h globroots.h +hash.d.o: hash.c mlvalues.h config.h ../config/m.h ../config/s.h misc.h \ + custom.h memory.h gc.h major_gc.h freelist.h minor_gc.h +instrtrace.d.o: instrtrace.c instruct.h misc.h config.h ../config/m.h \ + ../config/s.h mlvalues.h opnames.h prims.h +intern.d.o: intern.c alloc.h misc.h config.h ../config/m.h ../config/s.h \ + mlvalues.h custom.h fail.h gc.h intext.h io.h fix_code.h memory.h \ + major_gc.h freelist.h minor_gc.h reverse.h +interp.d.o: interp.c alloc.h misc.h config.h ../config/m.h ../config/s.h \ + mlvalues.h backtrace.h callback.h debugger.h fail.h fix_code.h \ + instrtrace.h instruct.h interp.h major_gc.h freelist.h memory.h gc.h \ + minor_gc.h prims.h signals.h stacks.h +ints.d.o: ints.c alloc.h misc.h config.h ../config/m.h ../config/s.h \ + mlvalues.h custom.h fail.h intext.h io.h fix_code.h memory.h gc.h \ + major_gc.h freelist.h minor_gc.h int64_native.h +io.d.o: io.c config.h ../config/m.h ../config/s.h alloc.h misc.h mlvalues.h \ + custom.h fail.h io.h memory.h gc.h major_gc.h freelist.h minor_gc.h \ + signals.h sys.h +lexing.d.o: lexing.c fail.h misc.h config.h ../config/m.h ../config/s.h \ + mlvalues.h stacks.h memory.h gc.h major_gc.h freelist.h minor_gc.h +macintosh.d.o: macintosh.c misc.h config.h ../config/m.h ../config/s.h \ + rotatecursor.h mlvalues.h prims.h +main.d.o: main.c misc.h config.h ../config/m.h ../config/s.h mlvalues.h \ + sys.h +major_gc.d.o: major_gc.c compact.h config.h ../config/m.h ../config/s.h \ + misc.h custom.h mlvalues.h fail.h finalise.h roots.h memory.h gc.h \ + major_gc.h freelist.h minor_gc.h gc_ctrl.h weak.h +md5.d.o: md5.c alloc.h misc.h config.h ../config/m.h ../config/s.h \ + mlvalues.h fail.h md5.h io.h reverse.h +memory.d.o: memory.c fail.h misc.h config.h ../config/m.h ../config/s.h \ + mlvalues.h freelist.h gc.h gc_ctrl.h major_gc.h memory.h minor_gc.h \ + signals.h +meta.d.o: meta.c alloc.h misc.h config.h ../config/m.h ../config/s.h \ + mlvalues.h fail.h fix_code.h interp.h major_gc.h freelist.h memory.h \ + gc.h minor_gc.h prims.h stacks.h +minor_gc.d.o: minor_gc.c config.h ../config/m.h ../config/s.h fail.h misc.h \ + mlvalues.h finalise.h roots.h memory.h gc.h major_gc.h freelist.h \ + minor_gc.h gc_ctrl.h signals.h +misc.d.o: misc.c config.h ../config/m.h ../config/s.h misc.h memory.h gc.h \ + mlvalues.h major_gc.h freelist.h minor_gc.h +mpwtool.d.o: mpwtool.c +obj.d.o: obj.c alloc.h misc.h config.h ../config/m.h ../config/s.h \ + mlvalues.h fail.h gc.h major_gc.h freelist.h memory.h minor_gc.h \ + prims.h +parsing.d.o: parsing.c config.h ../config/m.h ../config/s.h mlvalues.h \ + misc.h memory.h gc.h major_gc.h freelist.h minor_gc.h alloc.h +prims.d.o: prims.c mlvalues.h config.h ../config/m.h ../config/s.h misc.h \ + prims.h +printexc.d.o: printexc.c backtrace.h mlvalues.h config.h ../config/m.h \ + ../config/s.h misc.h callback.h debugger.h fail.h printexc.h +roots.d.o: roots.c finalise.h roots.h misc.h config.h ../config/m.h \ + ../config/s.h memory.h gc.h mlvalues.h major_gc.h freelist.h minor_gc.h \ + globroots.h stacks.h +rotatecursor.d.o: rotatecursor.c rotatecursor.h +signals.d.o: signals.c alloc.h misc.h config.h ../config/m.h ../config/s.h \ + mlvalues.h callback.h fail.h memory.h gc.h major_gc.h freelist.h \ + minor_gc.h roots.h signals.h sys.h +stacks.d.o: stacks.c config.h ../config/m.h ../config/s.h fail.h misc.h \ + mlvalues.h stacks.h memory.h gc.h major_gc.h freelist.h minor_gc.h +startup.d.o: startup.c config.h ../config/m.h ../config/s.h alloc.h misc.h \ + mlvalues.h backtrace.h callback.h custom.h debugger.h dynlink.h exec.h \ + fail.h fix_code.h gc_ctrl.h instrtrace.h interp.h intext.h io.h \ + memory.h gc.h major_gc.h freelist.h minor_gc.h osdeps.h prims.h \ + printexc.h reverse.h signals.h stacks.h sys.h startup.h +str.d.o: str.c alloc.h misc.h config.h ../config/m.h ../config/s.h \ + mlvalues.h fail.h +sys.d.o: sys.c config.h ../config/m.h ../config/s.h alloc.h misc.h \ + mlvalues.h debugger.h fail.h instruct.h osdeps.h signals.h stacks.h \ + memory.h gc.h major_gc.h freelist.h minor_gc.h sys.h +terminfo.d.o: terminfo.c config.h ../config/m.h ../config/s.h alloc.h \ + misc.h mlvalues.h fail.h io.h +unix.d.o: unix.c config.h ../config/m.h ../config/s.h memory.h gc.h \ + mlvalues.h misc.h major_gc.h freelist.h minor_gc.h osdeps.h +weak.d.o: weak.c alloc.h misc.h config.h ../config/m.h ../config/s.h \ + mlvalues.h fail.h memory.h gc.h major_gc.h freelist.h minor_gc.h +win32.d.o: win32.c memory.h config.h ../config/m.h ../config/s.h gc.h \ + mlvalues.h misc.h major_gc.h freelist.h minor_gc.h osdeps.h signals.h diff --git a/byterun/Makefile b/byterun/Makefile new file mode 100644 index 00000000..61e5bca6 --- /dev/null +++ b/byterun/Makefile @@ -0,0 +1,110 @@ +######################################################################### +# # +# 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: Makefile,v 1.45 2003/06/23 12:52:06 xleroy Exp $ + +include ../config/Makefile + +CC=$(BYTECC) +CFLAGS=-O $(BYTECCCOMPOPTS) +DFLAGS=-g -DDEBUG $(BYTECCCOMPOPTS) + +OBJS=interp.o misc.o stacks.o fix_code.o startup.o main.o \ + freelist.o major_gc.o minor_gc.o memory.o alloc.o roots.o globroots.o \ + fail.o signals.o printexc.o backtrace.o \ + compare.o ints.o floats.o str.o array.o io.o extern.o intern.o \ + hash.o sys.o meta.o parsing.o gc_ctrl.o terminfo.o md5.o obj.o \ + lexing.o callback.o debugger.o weak.o compact.o finalise.o custom.o \ + dynlink.o unix.o + +DOBJS=$(OBJS:.o=.d.o) instrtrace.d.o + +PRIMS=alloc.c array.c compare.c extern.c floats.c gc_ctrl.c hash.c \ + intern.c interp.c ints.c io.c lexing.c md5.c meta.c obj.c parsing.c \ + signals.c str.c sys.c terminfo.c callback.c weak.c finalise.c stacks.c \ + dynlink.c + +PUBLIC_INCLUDES=alloc.h callback.h config.h custom.h fail.h intext.h \ + memory.h misc.h mlvalues.h signals.h + +all: ocamlrun$(EXE) + +ocamlrun$(EXE): libcamlrun.a prims.o + $(BYTECC) $(BYTECCCOMPOPTS) $(BYTECCLINKOPTS) -o ocamlrun$(EXE) \ + prims.o libcamlrun.a $(BYTECCLIBS) + +ocamlrund$(EXE): libcamlrund.a prims.o + $(BYTECC) -g $(BYTECCCOMPOPTS) $(BYTECCLINKOPTS) -o ocamlrund$(EXE) \ + prims.o libcamlrund.a $(BYTECCLIBS) + +install: + cp ocamlrun$(EXE) $(BINDIR)/ocamlrun$(EXE) + cp libcamlrun.a $(LIBDIR)/libcamlrun.a + cd $(LIBDIR); $(RANLIB) libcamlrun.a + if test -d $(LIBDIR)/caml; then : ; else mkdir $(LIBDIR)/caml; fi + for i in $(PUBLIC_INCLUDES); do \ + sed -f ../tools/cleanup-header $$i > $(LIBDIR)/caml/$$i; \ + done + +libcamlrun.a: $(OBJS) + ar rc libcamlrun.a $(OBJS) + $(RANLIB) libcamlrun.a + +libcamlrund.a: $(DOBJS) + ar rc libcamlrund.a $(DOBJS) + $(RANLIB) libcamlrund.a + +clean: + rm -f ocamlrun$(EXE) ocamlrund$(EXE) *.o lib*.a + rm -f primitives prims.c opnames.h jumptbl.h + +primitives : $(PRIMS) + sed -n -e "s/CAMLprim value \([a-z0-9_][a-z0-9_]*\).*/\1/p" \ + $(PRIMS) > primitives + +prims.c : primitives + (echo '#include "mlvalues.h"'; \ + echo '#include "prims.h"'; \ + sed -e 's/.*/extern value &();/' primitives; \ + echo 'c_primitive builtin_cprim[] = {'; \ + sed -e 's/.*/ &,/' primitives; \ + echo ' 0 };'; \ + echo 'char * names_of_builtin_cprim[] = {'; \ + sed -e 's/.*/ "&",/' primitives; \ + echo ' 0 };') > prims.c + +opnames.h : instruct.h + sed -e '/\/\*/d' \ + -e '/^#/d' \ + -e 's/enum /char * names_of_/' \ + -e 's/{$$/[] = {/' \ + -e 's/\([A-Z][A-Z_0-9]*\)/"\1"/g' instruct.h > opnames.h + +# jumptbl.h is required only if you have GCC 2.0 or later +jumptbl.h : instruct.h + sed -n -e '/^ /s/ \([A-Z]\)/ \&\&lbl_\1/gp' \ + -e '/^}/q' instruct.h > jumptbl.h + +.SUFFIXES: .d.o + +.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 + +depend : prims.c opnames.h jumptbl.h + gcc -MM $(BYTECCCOMPOPTS) *.c > .depend + gcc -MM $(BYTECCCOMPOPTS) -DDEBUG *.c | sed -e 's/\.o/.d.o/' >> .depend + +include .depend diff --git a/byterun/Makefile.Mac b/byterun/Makefile.Mac new file mode 100644 index 00000000..4a439ea2 --- /dev/null +++ b/byterun/Makefile.Mac @@ -0,0 +1,118 @@ +######################################################################### +# # +# 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: Makefile.Mac,v 1.31 2001/12/13 13:59:22 doligez Exp $ + +PPCC = mrc +PPCCOptions = -w 29,30,35 -i ::config: {cdbgflag} +PPCLinkOptions = -d {ldbgflag} +PPCLibs = "{sharedlibraries}MathLib" "{ppclibraries}PPCCRuntime.o" ¶ + "{ppclibraries}PPCToolLibs.o" "{sharedlibraries}StdCLib" ¶ + "{ppclibraries}StdCRuntime.o" "{sharedlibraries}InterfaceLib" + +PPCOBJS = :interp.c.x :misc.c.x :stacks.c.x ¶ + :fix_code.c.x :startup.c.x :main.c.x ¶ + :freelist.c.x :major_gc.c.x :minor_gc.c.x :memory.c.x :alloc.c.x :roots.c.x ¶ + :fail.c.x :signals.c.x ¶ + :compare.c.x :ints.c.x :floats.c.x :str.c.x :array.c.x :io.c.x :extern.c.x ¶ + :intern.c.x ¶ + :hash.c.x :sys.c.x :meta.c.x :parsing.c.x ¶ + :gc_ctrl.c.x :terminfo.c.x :md5.c.x ¶ + :obj.c.x :lexing.c.x :macintosh.c.x ¶ + :rotatecursor.c.x :printexc.c.x :callback.c.x ¶ + :debugger.c.x :weak.c.x :compact.c.x ¶ + :instrtrace.c.x :finalise.c.x :custom.c.x :backtrace.c.x :globroots.c.x + +PRIMS = alloc.c array.c compare.c extern.c floats.c gc_ctrl.c hash.c ¶ + intern.c interp.c ints.c io.c lexing.c md5.c meta.c obj.c parsing.c ¶ + signals.c str.c sys.c terminfo.c callback.c weak.c finalise.c stacks.c ¶ + dynlink.c + +PUBLIC_INCLUDES = mlvalues.h alloc.h misc.h callback.h fail.h custom.h + +all Ä libcamlrun-gui.x libcamlrun.x ocamlrun + +libcamlrun-gui.x Ä {PPCOBJS} + ppclink {PPCLinkOptions} -xm library -o libcamlrun-gui.x {PPCOBJS} + +libcamlrun.x Ä libcamlrun-gui.x mpwtool.c.x + ppclink {PPCLinkOptions} -xm library -o libcamlrun.x libcamlrun-gui.x mpwtool.c.x + +ocamlrun Ä libcamlrun.x :prims.c.x + ppclink -c 'MPS ' -t MPST {PPCLinkOptions} -o ocamlrun prims.c.x ¶ + libcamlrun.x {PPCLibs} + +install Ä + duplicate -y ocamlrun "{BINDIR}ocamlrun" + duplicate -y libcamlrun.x libcamlrun-gui.x "{LIBDIR}" + if "`exists -d "{LIBDIR}caml:"`" == "" + newfolder "{LIBDIR}caml:" + end + duplicate -y {PUBLIC_INCLUDES} "{LIBDIR}caml:" + duplicate -y config.h "{LIBDIR}caml:" + open -t "{LIBDIR}caml:config.h" + find ¥ "{LIBDIR}caml:config.h" + find /Å'#include 'Å°/ "{LIBDIR}caml:config.h" + catenate ::config:m.h > "{LIBDIR}caml:config.h".¤ + find ¥ "{LIBDIR}caml:config.h" + find /Å'#include 'Å°/ "{LIBDIR}caml:config.h" + catenate ::config:s.h > "{LIBDIR}caml:config.h".¤ + find ¥ "{LIBDIR}caml:config.h" + clear -c ° /Å'#include "'Å/ "{LIBDIR}caml:config.h" + close -y "{LIBDIR}caml:config.h" + duplicate -y memory.h "{LIBDIR}caml:" + open -t "{LIBDIR}caml:memory.h" + find ¥ "{LIBDIR}caml:memory.h" + clear -c ° /Å'#include "'Å'gc.h'Å/ "{LIBDIR}caml:memory.h" + find ¥ "{LIBDIR}caml:memory.h" + clear /'#define Alloc_small'/:/¥}/ "{LIBDIR}caml:memory.h" + find ¥ "{LIBDIR}caml:memory.h" + clear /'#define Modify'/:/¥}/ "{LIBDIR}caml:memory.h" + close -y "{LIBDIR}caml:memory.h" + +clean Ä + delete -i Å.[ox] || set status 0 + delete -i ocamlrun primitives prims.c opnames.h interp.a.lst + delete -i ocamlrun.xcoff ocamlrun.dbg + +primitives Ä {PRIMS} + streamedit -d -e "/CAMLprim value ([a-z0-9_]+)¨0Å/ print ¨0" {PRIMS} ¶ + > primitives + +:prims.c Ä primitives + begin + echo '#include "mlvalues.h"' + echo '#include "prims.h"' + streamedit -e '1,$ change "extern value " . "();"' primitives + echo 'c_primitive builtin_cprim [] = {' + streamedit -e '1,$ change " " . ","' primitives + echo '0 };' + echo 'char * names_of_builtin_cprim [] = {' + streamedit -e '1,$ change " ¶"" . "¶","' primitives + echo '0 };' + end > prims.c + +:opnames.h Ä :instruct.h + streamedit -e "/¶¶/'*'/ delete" ¶ + -e "/enum / replace // 'char * names_of_'" ¶ + -e '/{°/ replace // "[] = {"' ¶ + -e "1,$ replace /([A-Z][A-Z_0-9]*)¨0/ '¶"' ¨0 '¶"' -c °" ¶ + instruct.h > opnames.h + +:md5.c.x Ä + {PPCC} :md5.c -o :md5.c.x -opt off {PPCCOptions} -opt off + +depend Ä :prims.c :opnames.h + begin + makedepend -w -objext .x Å.c + end | streamedit -e "/¶t/ replace // ' ' -c °" > Makefile.Mac.depend diff --git a/byterun/Makefile.Mac.depend b/byterun/Makefile.Mac.depend new file mode 100644 index 00000000..7f018d36 --- /dev/null +++ b/byterun/Makefile.Mac.depend @@ -0,0 +1,1180 @@ +#*** Dependencies: Cut here *** +# These dependencies were produced at 20:33:13 on Tue, Aug 21, 2001 by MakeDepend + +:alloc.c.x Ä ¶ + :alloc.c ¶ + "{CIncludes}"string.h ¶ + :alloc.h ¶ + :custom.h ¶ + :major_gc.h ¶ + :memory.h ¶ + :mlvalues.h ¶ + :stacks.h ¶ + "{CIncludes}"NullDef.h ¶ + "{CIncludes}"SizeTDef.h ¶ + :misc.h ¶ + :freelist.h ¶ + :config.h ¶ + :gc.h ¶ + :minor_gc.h ¶ + "{CIncludes}"stddef.h ¶ + "{CIncludes}"stdlib.h ¶ + ::config:m.h ¶ + ::config:s.h ¶ + "{CIncludes}"WCharTDef.h + +:array.c.x Ä ¶ + :array.c ¶ + :alloc.h ¶ + :fail.h ¶ + :memory.h ¶ + :misc.h ¶ + :mlvalues.h ¶ + "{CIncludes}"setjmp.h ¶ + :config.h ¶ + :gc.h ¶ + :major_gc.h ¶ + :minor_gc.h ¶ + "{CIncludes}"stddef.h ¶ + "{CIncludes}"stdlib.h ¶ + ::config:m.h ¶ + ::config:s.h ¶ + :freelist.h ¶ + "{CIncludes}"NullDef.h ¶ + "{CIncludes}"SizeTDef.h ¶ + "{CIncludes}"WCharTDef.h + +:backtrace.c.x Ä ¶ + :backtrace.c ¶ + "{CIncludes}"stdio.h ¶ + "{CIncludes}"stdlib.h ¶ + "{CIncludes}"fcntl.h ¶ + :config.h ¶ + :mlvalues.h ¶ + :alloc.h ¶ + :io.h ¶ + :instruct.h ¶ + :intext.h ¶ + :exec.h ¶ + :fix_code.h ¶ + :startup.h ¶ + :stacks.h ¶ + :sys.h ¶ + :backtrace.h ¶ + "{CIncludes}"NullDef.h ¶ + "{CIncludes}"SizeTDef.h ¶ + "{CIncludes}"SeekDefs.h ¶ + "{CIncludes}"VaListTDef.h ¶ + "{CIncludes}"WCharTDef.h ¶ + ::config:m.h ¶ + ::config:s.h ¶ + :misc.h ¶ + :memory.h ¶ + "{CIncludes}"stddef.h ¶ + :gc.h ¶ + :major_gc.h ¶ + :minor_gc.h ¶ + :freelist.h + +:callback.c.x Ä ¶ + :callback.c ¶ + "{CIncludes}"string.h ¶ + :callback.h ¶ + :fail.h ¶ + :memory.h ¶ + :mlvalues.h ¶ + :interp.h ¶ + :instruct.h ¶ + :fix_code.h ¶ + :stacks.h ¶ + "{CIncludes}"NullDef.h ¶ + "{CIncludes}"SizeTDef.h ¶ + "{CIncludes}"setjmp.h ¶ + :misc.h ¶ + :config.h ¶ + :gc.h ¶ + :major_gc.h ¶ + :minor_gc.h ¶ + "{CIncludes}"stddef.h ¶ + "{CIncludes}"stdlib.h ¶ + ::config:m.h ¶ + ::config:s.h ¶ + :freelist.h ¶ + "{CIncludes}"WCharTDef.h + +:compact.c.x Ä ¶ + :compact.c ¶ + "{CIncludes}"string.h ¶ + :config.h ¶ + :finalise.h ¶ + :freelist.h ¶ + :gc.h ¶ + :gc_ctrl.h ¶ + :major_gc.h ¶ + :memory.h ¶ + :mlvalues.h ¶ + :roots.h ¶ + :weak.h ¶ + "{CIncludes}"NullDef.h ¶ + "{CIncludes}"SizeTDef.h ¶ + ::config:m.h ¶ + ::config:s.h ¶ + :misc.h ¶ + :minor_gc.h ¶ + "{CIncludes}"stddef.h ¶ + "{CIncludes}"stdlib.h ¶ + "{CIncludes}"WCharTDef.h + +:compare.c.x Ä ¶ + :compare.c ¶ + "{CIncludes}"string.h ¶ + "{CIncludes}"stdlib.h ¶ + :custom.h ¶ + :fail.h ¶ + :memory.h ¶ + :misc.h ¶ + :mlvalues.h ¶ + "{CIncludes}"NullDef.h ¶ + "{CIncludes}"SizeTDef.h ¶ + "{CIncludes}"WCharTDef.h ¶ + "{CIncludes}"setjmp.h ¶ + :config.h ¶ + :gc.h ¶ + :major_gc.h ¶ + :minor_gc.h ¶ + "{CIncludes}"stddef.h ¶ + ::config:m.h ¶ + ::config:s.h ¶ + :freelist.h + +:custom.c.x Ä ¶ + :custom.c ¶ + "{CIncludes}"string.h ¶ + :alloc.h ¶ + :custom.h ¶ + :fail.h ¶ + :memory.h ¶ + :mlvalues.h ¶ + "{CIncludes}"NullDef.h ¶ + "{CIncludes}"SizeTDef.h ¶ + :misc.h ¶ + "{CIncludes}"setjmp.h ¶ + :config.h ¶ + :gc.h ¶ + :major_gc.h ¶ + :minor_gc.h ¶ + "{CIncludes}"stddef.h ¶ + "{CIncludes}"stdlib.h ¶ + ::config:m.h ¶ + ::config:s.h ¶ + :freelist.h ¶ + "{CIncludes}"WCharTDef.h + +:debugger.c.x Ä ¶ + :debugger.c ¶ + "{CIncludes}"string.h ¶ + :config.h ¶ + :debugger.h ¶ + :fail.h ¶ + :fix_code.h ¶ + :instruct.h ¶ + :intext.h ¶ + :io.h ¶ + :misc.h ¶ + :mlvalues.h ¶ + :stacks.h ¶ + :sys.h ¶ + "{CIncludes}"NullDef.h ¶ + "{CIncludes}"SizeTDef.h ¶ + ::config:m.h ¶ + ::config:s.h ¶ + "{CIncludes}"setjmp.h ¶ + "{CIncludes}"stddef.h ¶ + "{CIncludes}"stdlib.h ¶ + :memory.h ¶ + "{CIncludes}"WCharTDef.h ¶ + :gc.h ¶ + :major_gc.h ¶ + :minor_gc.h ¶ + :freelist.h + +:extern.c.x Ä ¶ + :extern.c ¶ + "{CIncludes}"string.h ¶ + :alloc.h ¶ + :custom.h ¶ + :fail.h ¶ + :gc.h ¶ + :intext.h ¶ + :io.h ¶ + :memory.h ¶ + :misc.h ¶ + :mlvalues.h ¶ + :reverse.h ¶ + "{CIncludes}"NullDef.h ¶ + "{CIncludes}"SizeTDef.h ¶ + "{CIncludes}"setjmp.h ¶ + :fix_code.h ¶ + :config.h ¶ + :major_gc.h ¶ + :minor_gc.h ¶ + "{CIncludes}"stddef.h ¶ + "{CIncludes}"stdlib.h ¶ + ::config:m.h ¶ + ::config:s.h ¶ + :freelist.h ¶ + "{CIncludes}"WCharTDef.h + +:fail.c.x Ä ¶ + :fail.c ¶ + :alloc.h ¶ + :fail.h ¶ + :io.h ¶ + :gc.h ¶ + :memory.h ¶ + :misc.h ¶ + :mlvalues.h ¶ + :printexc.h ¶ + :signals.h ¶ + :stacks.h ¶ + "{CIncludes}"setjmp.h ¶ + :config.h ¶ + :major_gc.h ¶ + :minor_gc.h ¶ + "{CIncludes}"stddef.h ¶ + "{CIncludes}"stdlib.h ¶ + ::config:m.h ¶ + ::config:s.h ¶ + :freelist.h ¶ + "{CIncludes}"NullDef.h ¶ + "{CIncludes}"SizeTDef.h ¶ + "{CIncludes}"WCharTDef.h + +:finalise.c.x Ä ¶ + :finalise.c ¶ + :callback.h ¶ + :fail.h ¶ + :mlvalues.h ¶ + :roots.h ¶ + :signals.h ¶ + "{CIncludes}"setjmp.h ¶ + :misc.h ¶ + :config.h ¶ + :memory.h ¶ + "{CIncludes}"stddef.h ¶ + "{CIncludes}"stdlib.h ¶ + ::config:m.h ¶ + ::config:s.h ¶ + :gc.h ¶ + :major_gc.h ¶ + :minor_gc.h ¶ + "{CIncludes}"NullDef.h ¶ + "{CIncludes}"SizeTDef.h ¶ + "{CIncludes}"WCharTDef.h ¶ + :freelist.h + +:fix_code.c.x Ä ¶ + :fix_code.c ¶ + :config.h ¶ + :debugger.h ¶ + :fix_code.h ¶ + :instruct.h ¶ + :md5.h ¶ + :memory.h ¶ + :misc.h ¶ + :mlvalues.h ¶ + :reverse.h ¶ + ::config:m.h ¶ + ::config:s.h ¶ + :io.h ¶ + :gc.h ¶ + :major_gc.h ¶ + :minor_gc.h ¶ + "{CIncludes}"stddef.h ¶ + "{CIncludes}"stdlib.h ¶ + :freelist.h ¶ + "{CIncludes}"NullDef.h ¶ + "{CIncludes}"SizeTDef.h ¶ + "{CIncludes}"WCharTDef.h + +:floats.c.x Ä ¶ + :floats.c ¶ + "{CIncludes}"math.h ¶ + "{CIncludes}"stdio.h ¶ + "{CIncludes}"stdlib.h ¶ + :alloc.h ¶ + :fail.h ¶ + :memory.h ¶ + :mlvalues.h ¶ + :misc.h ¶ + :reverse.h ¶ + :stacks.h ¶ + "{CIncludes}"NullDef.h ¶ + "{CIncludes}"SizeTDef.h ¶ + "{CIncludes}"SeekDefs.h ¶ + "{CIncludes}"VaListTDef.h ¶ + "{CIncludes}"WCharTDef.h ¶ + "{CIncludes}"setjmp.h ¶ + :config.h ¶ + :gc.h ¶ + :major_gc.h ¶ + :minor_gc.h ¶ + "{CIncludes}"stddef.h ¶ + ::config:m.h ¶ + ::config:s.h ¶ + :freelist.h + +:freelist.c.x Ä ¶ + :freelist.c ¶ + :config.h ¶ + :freelist.h ¶ + :gc.h ¶ + :gc_ctrl.h ¶ + :major_gc.h ¶ + :misc.h ¶ + :mlvalues.h ¶ + ::config:m.h ¶ + ::config:s.h ¶ + "{CIncludes}"stddef.h ¶ + "{CIncludes}"stdlib.h ¶ + "{CIncludes}"NullDef.h ¶ + "{CIncludes}"SizeTDef.h ¶ + "{CIncludes}"WCharTDef.h + +:gc_ctrl.c.x Ä ¶ + :gc_ctrl.c ¶ + :alloc.h ¶ + :compact.h ¶ + :custom.h ¶ + :finalise.h ¶ + :gc.h ¶ + :gc_ctrl.h ¶ + :major_gc.h ¶ + :minor_gc.h ¶ + :misc.h ¶ + :mlvalues.h ¶ + :stacks.h ¶ + :config.h ¶ + :roots.h ¶ + :freelist.h ¶ + "{CIncludes}"stddef.h ¶ + "{CIncludes}"stdlib.h ¶ + :memory.h ¶ + ::config:m.h ¶ + ::config:s.h ¶ + "{CIncludes}"NullDef.h ¶ + "{CIncludes}"SizeTDef.h ¶ + "{CIncludes}"WCharTDef.h + +:globroots.c.x Ä ¶ + :globroots.c ¶ + :memory.h ¶ + :misc.h ¶ + :mlvalues.h ¶ + :globroots.h ¶ + :config.h ¶ + :gc.h ¶ + :major_gc.h ¶ + :minor_gc.h ¶ + "{CIncludes}"stddef.h ¶ + "{CIncludes}"stdlib.h ¶ + ::config:m.h ¶ + ::config:s.h ¶ + :freelist.h ¶ + "{CIncludes}"NullDef.h ¶ + "{CIncludes}"SizeTDef.h ¶ + "{CIncludes}"WCharTDef.h + +:hash.c.x Ä ¶ + :hash.c ¶ + :mlvalues.h ¶ + :custom.h ¶ + :memory.h ¶ + :config.h ¶ + :misc.h ¶ + :gc.h ¶ + :major_gc.h ¶ + :minor_gc.h ¶ + ::config:m.h ¶ + ::config:s.h ¶ + "{CIncludes}"stddef.h ¶ + "{CIncludes}"stdlib.h ¶ + :freelist.h ¶ + "{CIncludes}"NullDef.h ¶ + "{CIncludes}"SizeTDef.h ¶ + "{CIncludes}"WCharTDef.h + +:instrtrace.c.x Ä ¶ + :instrtrace.c ¶ + "{CIncludes}"stdio.h ¶ + :instruct.h ¶ + :misc.h ¶ + :mlvalues.h ¶ + :opnames.h ¶ + "{CIncludes}"NullDef.h ¶ + "{CIncludes}"SizeTDef.h ¶ + "{CIncludes}"SeekDefs.h ¶ + "{CIncludes}"VaListTDef.h ¶ + :config.h ¶ + "{CIncludes}"stddef.h ¶ + "{CIncludes}"stdlib.h ¶ + ::config:m.h ¶ + ::config:s.h ¶ + "{CIncludes}"WCharTDef.h + +:intern.c.x Ä ¶ + :intern.c ¶ + "{CIncludes}"string.h ¶ + :alloc.h ¶ + :custom.h ¶ + :fail.h ¶ + :gc.h ¶ + :intext.h ¶ + :io.h ¶ + :memory.h ¶ + :mlvalues.h ¶ + :misc.h ¶ + :reverse.h ¶ + :md5.h ¶ + :fix_code.h ¶ + "{CIncludes}"NullDef.h ¶ + "{CIncludes}"SizeTDef.h ¶ + "{CIncludes}"setjmp.h ¶ + :config.h ¶ + :major_gc.h ¶ + :minor_gc.h ¶ + "{CIncludes}"stddef.h ¶ + "{CIncludes}"stdlib.h ¶ + ::config:m.h ¶ + ::config:s.h ¶ + :freelist.h ¶ + "{CIncludes}"WCharTDef.h + +:interp.c.x Ä ¶ + :interp.c ¶ + "{CIncludes}"stdio.h ¶ + :alloc.h ¶ + :backtrace.h ¶ + :callback.h ¶ + :debugger.h ¶ + :fail.h ¶ + :fix_code.h ¶ + :instrtrace.h ¶ + :instruct.h ¶ + :interp.h ¶ + :major_gc.h ¶ + :memory.h ¶ + :misc.h ¶ + :mlvalues.h ¶ + :prims.h ¶ + :signals.h ¶ + :stacks.h ¶ + "{CIncludes}"NullDef.h ¶ + "{CIncludes}"SizeTDef.h ¶ + "{CIncludes}"SeekDefs.h ¶ + "{CIncludes}"VaListTDef.h ¶ + "{CIncludes}"setjmp.h ¶ + :config.h ¶ + :freelist.h ¶ + :gc.h ¶ + :minor_gc.h ¶ + "{CIncludes}"stddef.h ¶ + "{CIncludes}"stdlib.h ¶ + ::config:m.h ¶ + ::config:s.h ¶ + "{CIncludes}"WCharTDef.h + +:ints.c.x Ä ¶ + :ints.c ¶ + "{CIncludes}"stdio.h ¶ + "{CIncludes}"string.h ¶ + :alloc.h ¶ + :custom.h ¶ + :fail.h ¶ + :intext.h ¶ + :memory.h ¶ + :misc.h ¶ + :mlvalues.h ¶ + "{CIncludes}"NullDef.h ¶ + "{CIncludes}"SizeTDef.h ¶ + "{CIncludes}"SeekDefs.h ¶ + "{CIncludes}"VaListTDef.h ¶ + "{CIncludes}"setjmp.h ¶ + :io.h ¶ + :fix_code.h ¶ + :config.h ¶ + :gc.h ¶ + :major_gc.h ¶ + :minor_gc.h ¶ + "{CIncludes}"stddef.h ¶ + "{CIncludes}"stdlib.h ¶ + ::config:m.h ¶ + ::config:s.h ¶ + :freelist.h ¶ + "{CIncludes}"WCharTDef.h + +:io.c.x Ä ¶ + :io.c ¶ + "{CIncludes}"errno.h ¶ + "{CIncludes}"fcntl.h ¶ + "{CIncludes}"limits.h ¶ + "{CIncludes}"string.h ¶ + :config.h ¶ + :alloc.h ¶ + :custom.h ¶ + :fail.h ¶ + :io.h ¶ + :memory.h ¶ + :misc.h ¶ + :mlvalues.h ¶ + :signals.h ¶ + :sys.h ¶ + :ui.h ¶ + "{CIncludes}"SeekDefs.h ¶ + "{CIncludes}"SizeTDef.h ¶ + "{CIncludes}"NullDef.h ¶ + ::config:m.h ¶ + ::config:s.h ¶ + "{CIncludes}"setjmp.h ¶ + :gc.h ¶ + :major_gc.h ¶ + :minor_gc.h ¶ + "{CIncludes}"stddef.h ¶ + "{CIncludes}"stdlib.h ¶ + :freelist.h ¶ + "{CIncludes}"WCharTDef.h + +:lexing.c.x Ä ¶ + :lexing.c ¶ + :fail.h ¶ + :mlvalues.h ¶ + :stacks.h ¶ + "{CIncludes}"setjmp.h ¶ + :misc.h ¶ + :config.h ¶ + :memory.h ¶ + "{CIncludes}"stddef.h ¶ + "{CIncludes}"stdlib.h ¶ + ::config:m.h ¶ + ::config:s.h ¶ + :gc.h ¶ + :major_gc.h ¶ + :minor_gc.h ¶ + "{CIncludes}"NullDef.h ¶ + "{CIncludes}"SizeTDef.h ¶ + "{CIncludes}"WCharTDef.h ¶ + :freelist.h + +:macintosh.c.x Ä ¶ + :macintosh.c ¶ + "{CIncludes}"stdio.h ¶ + "{CIncludes}"stdlib.h ¶ + "{CIncludes}"AppleEvents.h ¶ + "{CIncludes}"CursorCtl.h ¶ + "{CIncludes}"Errors.h ¶ + "{CIncludes}"Files.h ¶ + "{CIncludes}"IntEnv.h ¶ + "{CIncludes}"MacTypes.h ¶ + "{CIncludes}"QuickDraw.h ¶ + "{CIncludes}"TextUtils.h ¶ + :misc.h ¶ + :rotatecursor.h ¶ + "{CIncludes}"NullDef.h ¶ + "{CIncludes}"SizeTDef.h ¶ + "{CIncludes}"SeekDefs.h ¶ + "{CIncludes}"VaListTDef.h ¶ + "{CIncludes}"WCharTDef.h ¶ + "{CIncludes}"MixedMode.h ¶ + "{CIncludes}"AEDataModel.h ¶ + "{CIncludes}"AEInteraction.h ¶ + "{CIncludes}"ConditionalMacros.h ¶ + "{CIncludes}"MacErrors.h ¶ + "{CIncludes}"OSUtils.h ¶ + "{CIncludes}"TextCommon.h ¶ + "{CIncludes}"UTCUtils.h ¶ + "{CIncludes}"Finder.h ¶ + "{CIncludes}"Aliases.h ¶ + "{CIncludes}"Components.h ¶ + "{CIncludes}"QuickdrawText.h ¶ + "{CIncludes}"CGContext.h ¶ + "{CIncludes}"NumberFormatting.h ¶ + "{CIncludes}"StringCompare.h ¶ + "{CIncludes}"DateTimeUtils.h ¶ + :config.h ¶ + "{CIncludes}"stddef.h ¶ + "{CIncludes}"Notification.h ¶ + "{CIncludes}"Events.h ¶ + "{CIncludes}"MacMemory.h ¶ + "{CIncludes}"Patches.h ¶ + "{CIncludes}"CFString.h ¶ + "{CIncludes}"Endian.h ¶ + "{CIncludes}"IntlResources.h ¶ + "{CIncludes}"CGBase.h ¶ + "{CIncludes}"CGAffineTransform.h ¶ + "{CIncludes}"CGColorSpace.h ¶ + "{CIncludes}"CGFont.h ¶ + "{CIncludes}"CGImage.h ¶ + "{CIncludes}"CGPDFDocument.h ¶ + "{CIncludes}"Script.h ¶ + "{CIncludes}"TypeSelect.h ¶ + ::config:m.h ¶ + ::config:s.h ¶ + "{CIncludes}"CFBase.h ¶ + "{CIncludes}"CFArray.h ¶ + "{CIncludes}"CFData.h ¶ + "{CIncludes}"CFDictionary.h ¶ + "{CIncludes}"stdarg.h ¶ + "{CIncludes}"CGGeometry.h ¶ + "{CIncludes}"CGDataProvider.h ¶ + "{CIncludes}"CFURL.h + +:main.c.x Ä ¶ + :main.c ¶ + :misc.h ¶ + :mlvalues.h ¶ + :sys.h ¶ + :rotatecursor.h ¶ + :signals.h ¶ + :config.h ¶ + "{CIncludes}"stddef.h ¶ + "{CIncludes}"stdlib.h ¶ + ::config:m.h ¶ + ::config:s.h ¶ + "{CIncludes}"NullDef.h ¶ + "{CIncludes}"SizeTDef.h ¶ + "{CIncludes}"WCharTDef.h + +:major_gc.c.x Ä ¶ + :major_gc.c ¶ + "{CIncludes}"limits.h ¶ + :compact.h ¶ + :custom.h ¶ + :config.h ¶ + :fail.h ¶ + :finalise.h ¶ + :freelist.h ¶ + :gc.h ¶ + :gc_ctrl.h ¶ + :major_gc.h ¶ + :misc.h ¶ + :mlvalues.h ¶ + :roots.h ¶ + :weak.h ¶ + ::config:m.h ¶ + ::config:s.h ¶ + "{CIncludes}"setjmp.h ¶ + "{CIncludes}"stddef.h ¶ + "{CIncludes}"stdlib.h ¶ + :memory.h ¶ + "{CIncludes}"NullDef.h ¶ + "{CIncludes}"SizeTDef.h ¶ + "{CIncludes}"WCharTDef.h ¶ + :minor_gc.h + +:md5.c.x Ä ¶ + :md5.c ¶ + "{CIncludes}"string.h ¶ + :alloc.h ¶ + :fail.h ¶ + :md5.h ¶ + :mlvalues.h ¶ + :io.h ¶ + :reverse.h ¶ + "{CIncludes}"NullDef.h ¶ + "{CIncludes}"SizeTDef.h ¶ + :misc.h ¶ + "{CIncludes}"setjmp.h ¶ + :config.h ¶ + "{CIncludes}"stddef.h ¶ + "{CIncludes}"stdlib.h ¶ + ::config:m.h ¶ + ::config:s.h ¶ + "{CIncludes}"WCharTDef.h + +:memory.c.x Ä ¶ + :memory.c ¶ + "{CIncludes}"stdlib.h ¶ + "{CIncludes}"string.h ¶ + :fail.h ¶ + :freelist.h ¶ + :gc.h ¶ + :gc_ctrl.h ¶ + :major_gc.h ¶ + :memory.h ¶ + :minor_gc.h ¶ + :misc.h ¶ + :mlvalues.h ¶ + :signals.h ¶ + "{CIncludes}"NullDef.h ¶ + "{CIncludes}"SizeTDef.h ¶ + "{CIncludes}"WCharTDef.h ¶ + "{CIncludes}"setjmp.h ¶ + :config.h ¶ + "{CIncludes}"stddef.h ¶ + ::config:m.h ¶ + ::config:s.h + +:meta.c.x Ä ¶ + :meta.c ¶ + :alloc.h ¶ + :config.h ¶ + :fail.h ¶ + :fix_code.h ¶ + :interp.h ¶ + :major_gc.h ¶ + :memory.h ¶ + :minor_gc.h ¶ + :misc.h ¶ + :mlvalues.h ¶ + :prims.h ¶ + :stacks.h ¶ + ::config:m.h ¶ + ::config:s.h ¶ + "{CIncludes}"setjmp.h ¶ + :freelist.h ¶ + :gc.h ¶ + "{CIncludes}"stddef.h ¶ + "{CIncludes}"stdlib.h ¶ + "{CIncludes}"NullDef.h ¶ + "{CIncludes}"SizeTDef.h ¶ + "{CIncludes}"WCharTDef.h + +:minor_gc.c.x Ä ¶ + :minor_gc.c ¶ + "{CIncludes}"string.h ¶ + :config.h ¶ + :fail.h ¶ + :finalise.h ¶ + :gc.h ¶ + :gc_ctrl.h ¶ + :major_gc.h ¶ + :memory.h ¶ + :minor_gc.h ¶ + :misc.h ¶ + :mlvalues.h ¶ + :roots.h ¶ + :signals.h ¶ + "{CIncludes}"NullDef.h ¶ + "{CIncludes}"SizeTDef.h ¶ + ::config:m.h ¶ + ::config:s.h ¶ + "{CIncludes}"setjmp.h ¶ + :freelist.h ¶ + "{CIncludes}"stddef.h ¶ + "{CIncludes}"stdlib.h ¶ + "{CIncludes}"WCharTDef.h + +:misc.c.x Ä ¶ + :misc.c ¶ + "{CIncludes}"stdio.h ¶ + :config.h ¶ + :misc.h ¶ + :ui.h ¶ + "{CIncludes}"NullDef.h ¶ + "{CIncludes}"SizeTDef.h ¶ + "{CIncludes}"SeekDefs.h ¶ + "{CIncludes}"VaListTDef.h ¶ + ::config:m.h ¶ + ::config:s.h ¶ + "{CIncludes}"stddef.h ¶ + "{CIncludes}"stdlib.h ¶ + "{CIncludes}"WCharTDef.h + +:mpwtool.c.x Ä ¶ + :mpwtool.c ¶ + "{CIncludes}"stdio.h ¶ + "{CIncludes}"stdlib.h ¶ + "{CIncludes}"NullDef.h ¶ + "{CIncludes}"SizeTDef.h ¶ + "{CIncludes}"SeekDefs.h ¶ + "{CIncludes}"VaListTDef.h ¶ + "{CIncludes}"WCharTDef.h + +:obj.c.x Ä ¶ + :obj.c ¶ + :alloc.h ¶ + :fail.h ¶ + :gc.h ¶ + :major_gc.h ¶ + :memory.h ¶ + :minor_gc.h ¶ + :misc.h ¶ + :mlvalues.h ¶ + :prims.h ¶ + "{CIncludes}"setjmp.h ¶ + :freelist.h ¶ + :config.h ¶ + "{CIncludes}"stddef.h ¶ + "{CIncludes}"stdlib.h ¶ + ::config:m.h ¶ + ::config:s.h ¶ + "{CIncludes}"NullDef.h ¶ + "{CIncludes}"SizeTDef.h ¶ + "{CIncludes}"WCharTDef.h + +:parsing.c.x Ä ¶ + :parsing.c ¶ + "{CIncludes}"stdio.h ¶ + :config.h ¶ + :mlvalues.h ¶ + :memory.h ¶ + :alloc.h ¶ + "{CIncludes}"NullDef.h ¶ + "{CIncludes}"SizeTDef.h ¶ + "{CIncludes}"SeekDefs.h ¶ + "{CIncludes}"VaListTDef.h ¶ + ::config:m.h ¶ + ::config:s.h ¶ + :misc.h ¶ + :gc.h ¶ + :major_gc.h ¶ + :minor_gc.h ¶ + "{CIncludes}"stddef.h ¶ + "{CIncludes}"stdlib.h ¶ + :freelist.h ¶ + "{CIncludes}"WCharTDef.h + +:prims.c.x Ä ¶ + :prims.c ¶ + :mlvalues.h ¶ + :prims.h ¶ + :config.h ¶ + :misc.h ¶ + ::config:m.h ¶ + ::config:s.h ¶ + "{CIncludes}"stddef.h ¶ + "{CIncludes}"stdlib.h ¶ + "{CIncludes}"NullDef.h ¶ + "{CIncludes}"SizeTDef.h ¶ + "{CIncludes}"WCharTDef.h + +:printexc.c.x Ä ¶ + :printexc.c ¶ + "{CIncludes}"stdio.h ¶ + "{CIncludes}"stdlib.h ¶ + "{CIncludes}"string.h ¶ + :backtrace.h ¶ + :debugger.h ¶ + :fail.h ¶ + :misc.h ¶ + :mlvalues.h ¶ + :ui.h ¶ + :printexc.h ¶ + "{CIncludes}"NullDef.h ¶ + "{CIncludes}"SizeTDef.h ¶ + "{CIncludes}"SeekDefs.h ¶ + "{CIncludes}"VaListTDef.h ¶ + "{CIncludes}"WCharTDef.h ¶ + "{CIncludes}"setjmp.h ¶ + :config.h ¶ + "{CIncludes}"stddef.h ¶ + ::config:m.h ¶ + ::config:s.h + +:roots.c.x Ä ¶ + :roots.c ¶ + :finalise.h ¶ + :globroots.h ¶ + :major_gc.h ¶ + :memory.h ¶ + :minor_gc.h ¶ + :misc.h ¶ + :mlvalues.h ¶ + :roots.h ¶ + :stacks.h ¶ + :freelist.h ¶ + :config.h ¶ + :gc.h ¶ + "{CIncludes}"stddef.h ¶ + "{CIncludes}"stdlib.h ¶ + ::config:m.h ¶ + ::config:s.h ¶ + "{CIncludes}"NullDef.h ¶ + "{CIncludes}"SizeTDef.h ¶ + "{CIncludes}"WCharTDef.h + +:rotatecursor.c.x Ä ¶ + :rotatecursor.c ¶ + "{CIncludes}"CursorCtl.h ¶ + "{CIncludes}"MacTypes.h ¶ + "{CIncludes}"stdlib.h ¶ + "{CIncludes}"Timer.h ¶ + :rotatecursor.h ¶ + "{CIncludes}"ConditionalMacros.h ¶ + "{CIncludes}"NullDef.h ¶ + "{CIncludes}"SizeTDef.h ¶ + "{CIncludes}"WCharTDef.h ¶ + "{CIncludes}"OSUtils.h ¶ + "{CIncludes}"MixedMode.h ¶ + "{CIncludes}"MacMemory.h ¶ + "{CIncludes}"Patches.h ¶ + "{CIncludes}"DateTimeUtils.h ¶ + "{CIncludes}"CFString.h ¶ + "{CIncludes}"Endian.h ¶ + "{CIncludes}"CFBase.h ¶ + "{CIncludes}"CFArray.h ¶ + "{CIncludes}"CFData.h ¶ + "{CIncludes}"CFDictionary.h ¶ + "{CIncludes}"stdarg.h ¶ + "{CIncludes}"VaListTDef.h + +:signals.c.x Ä ¶ + :signals.c ¶ + "{CIncludes}"signal.h ¶ + :alloc.h ¶ + :callback.h ¶ + :config.h ¶ + :fail.h ¶ + :memory.h ¶ + :misc.h ¶ + :mlvalues.h ¶ + :roots.h ¶ + :signals.h ¶ + :sys.h ¶ + :rotatecursor.h ¶ + ::config:m.h ¶ + ::config:s.h ¶ + "{CIncludes}"setjmp.h ¶ + :gc.h ¶ + :major_gc.h ¶ + :minor_gc.h ¶ + "{CIncludes}"stddef.h ¶ + "{CIncludes}"stdlib.h ¶ + :freelist.h ¶ + "{CIncludes}"NullDef.h ¶ + "{CIncludes}"SizeTDef.h ¶ + "{CIncludes}"WCharTDef.h + +:stacks.c.x Ä ¶ + :stacks.c ¶ + "{CIncludes}"string.h ¶ + :config.h ¶ + :fail.h ¶ + :misc.h ¶ + :mlvalues.h ¶ + :stacks.h ¶ + "{CIncludes}"NullDef.h ¶ + "{CIncludes}"SizeTDef.h ¶ + ::config:m.h ¶ + ::config:s.h ¶ + "{CIncludes}"setjmp.h ¶ + "{CIncludes}"stddef.h ¶ + "{CIncludes}"stdlib.h ¶ + :memory.h ¶ + "{CIncludes}"WCharTDef.h ¶ + :gc.h ¶ + :major_gc.h ¶ + :minor_gc.h ¶ + :freelist.h + +:startup.c.x Ä ¶ + :startup.c ¶ + "{CIncludes}"stdio.h ¶ + "{CIncludes}"stdlib.h ¶ + "{CIncludes}"string.h ¶ + "{CIncludes}"fcntl.h ¶ + :config.h ¶ + :alloc.h ¶ + :backtrace.h ¶ + :callback.h ¶ + :custom.h ¶ + :debugger.h ¶ + :exec.h ¶ + :fail.h ¶ + :fix_code.h ¶ + :gc_ctrl.h ¶ + :instrtrace.h ¶ + :interp.h ¶ + :intext.h ¶ + :io.h ¶ + :memory.h ¶ + :minor_gc.h ¶ + :misc.h ¶ + :mlvalues.h ¶ + :prims.h ¶ + :printexc.h ¶ + :reverse.h ¶ + :signals.h ¶ + :stacks.h ¶ + :sys.h ¶ + :startup.h ¶ + "{CIncludes}"NullDef.h ¶ + "{CIncludes}"SizeTDef.h ¶ + "{CIncludes}"SeekDefs.h ¶ + "{CIncludes}"VaListTDef.h ¶ + "{CIncludes}"WCharTDef.h ¶ + ::config:m.h ¶ + ::config:s.h ¶ + "{CIncludes}"setjmp.h ¶ + :gc.h ¶ + :major_gc.h ¶ + "{CIncludes}"stddef.h ¶ + :freelist.h + +:str.c.x Ä ¶ + :str.c ¶ + "{CIncludes}"string.h ¶ + "{CIncludes}"ctype.h ¶ + :alloc.h ¶ + :fail.h ¶ + :mlvalues.h ¶ + :misc.h ¶ + "{CIncludes}"locale.h ¶ + "{CIncludes}"NullDef.h ¶ + "{CIncludes}"SizeTDef.h ¶ + "{CIncludes}"setjmp.h ¶ + :config.h ¶ + "{CIncludes}"stddef.h ¶ + "{CIncludes}"stdlib.h ¶ + ::config:m.h ¶ + ::config:s.h ¶ + "{CIncludes}"WCharTDef.h + +:sys.c.x Ä ¶ + :sys.c ¶ + "{CIncludes}"errno.h ¶ + "{CIncludes}"fcntl.h ¶ + "{CIncludes}"signal.h ¶ + "{CIncludes}"stdlib.h ¶ + "{CIncludes}"stdio.h ¶ + "{CIncludes}"string.h ¶ + "{CIncludes}"time.h ¶ + :macintosh.h ¶ + :config.h ¶ + :alloc.h ¶ + :debugger.h ¶ + :fail.h ¶ + :instruct.h ¶ + :mlvalues.h ¶ + :signals.h ¶ + :stacks.h ¶ + :sys.h ¶ + :ui.h ¶ + "{CIncludes}"SeekDefs.h ¶ + "{CIncludes}"SizeTDef.h ¶ + "{CIncludes}"NullDef.h ¶ + "{CIncludes}"WCharTDef.h ¶ + "{CIncludes}"VaListTDef.h ¶ + ::config:m.h ¶ + ::config:s.h ¶ + :misc.h ¶ + "{CIncludes}"setjmp.h ¶ + :memory.h ¶ + "{CIncludes}"stddef.h ¶ + :gc.h ¶ + :major_gc.h ¶ + :minor_gc.h ¶ + :freelist.h + +:terminfo.c.x Ä ¶ + :terminfo.c ¶ + :config.h ¶ + :alloc.h ¶ + :fail.h ¶ + :io.h ¶ + :mlvalues.h ¶ + ::config:m.h ¶ + ::config:s.h ¶ + :misc.h ¶ + "{CIncludes}"setjmp.h ¶ + "{CIncludes}"stddef.h ¶ + "{CIncludes}"stdlib.h ¶ + "{CIncludes}"NullDef.h ¶ + "{CIncludes}"SizeTDef.h ¶ + "{CIncludes}"WCharTDef.h + +:weak.c.x Ä ¶ + :weak.c ¶ + "{CIncludes}"string.h ¶ + :alloc.h ¶ + :fail.h ¶ + :memory.h ¶ + :mlvalues.h ¶ + "{CIncludes}"NullDef.h ¶ + "{CIncludes}"SizeTDef.h ¶ + :misc.h ¶ + "{CIncludes}"setjmp.h ¶ + :config.h ¶ + :gc.h ¶ + :major_gc.h ¶ + :minor_gc.h ¶ + "{CIncludes}"stddef.h ¶ + "{CIncludes}"stdlib.h ¶ + ::config:m.h ¶ + ::config:s.h ¶ + :freelist.h ¶ + "{CIncludes}"WCharTDef.h + +:win32.c.x Ä ¶ + :win32.c ¶ + "{CIncludes}"windows.h ¶ + "{CIncludes}"stdlib.h ¶ + "{CIncludes}"stdio.h ¶ + "{CIncludes}"fcntl.h ¶ + "{CIncludes}"ctype.h ¶ + "{CIncludes}"string.h ¶ + "{CIncludes}"signal.h ¶ + :signals.h ¶ + "{CIncludes}"ConditionalMacros.h ¶ + "{CIncludes}"MacWindows.h ¶ + "{CIncludes}"NullDef.h ¶ + "{CIncludes}"SizeTDef.h ¶ + "{CIncludes}"WCharTDef.h ¶ + "{CIncludes}"SeekDefs.h ¶ + "{CIncludes}"VaListTDef.h ¶ + :misc.h ¶ + :mlvalues.h ¶ + "{CIncludes}"MacTypes.h ¶ + "{CIncludes}"Aliases.h ¶ + "{CIncludes}"AppleEvents.h ¶ + "{CIncludes}"Collections.h ¶ + "{CIncludes}"Drag.h ¶ + "{CIncludes}"Events.h ¶ + "{CIncludes}"Menus.h ¶ + "{CIncludes}"MixedMode.h ¶ + "{CIncludes}"QDOffscreen.h ¶ + "{CIncludes}"QuickDraw.h ¶ + "{CIncludes}"TextCommon.h ¶ + "{CIncludes}"Icons.h ¶ + "{CIncludes}"MacErrors.h ¶ + "{CIncludes}"CFString.h ¶ + :config.h ¶ + "{CIncludes}"stddef.h ¶ + "{CIncludes}"Files.h ¶ + "{CIncludes}"AEDataModel.h ¶ + "{CIncludes}"AEInteraction.h ¶ + "{CIncludes}"OSUtils.h ¶ + "{CIncludes}"Endian.h ¶ + "{CIncludes}"Fonts.h ¶ + "{CIncludes}"Processes.h ¶ + "{CIncludes}"Components.h ¶ + "{CIncludes}"QuickdrawText.h ¶ + "{CIncludes}"CGContext.h ¶ + "{CIncludes}"CodeFragments.h ¶ + "{CIncludes}"CFBase.h ¶ + "{CIncludes}"CFArray.h ¶ + "{CIncludes}"CFData.h ¶ + "{CIncludes}"CFDictionary.h ¶ + "{CIncludes}"stdarg.h ¶ + ::config:m.h ¶ + ::config:s.h ¶ + "{CIncludes}"UTCUtils.h ¶ + "{CIncludes}"Finder.h ¶ + "{CIncludes}"Notification.h ¶ + "{CIncludes}"MacMemory.h ¶ + "{CIncludes}"Patches.h ¶ + "{CIncludes}"DateTimeUtils.h ¶ + "{CIncludes}"ATSTypes.h ¶ + "{CIncludes}"IntlResources.h ¶ + "{CIncludes}"CGBase.h ¶ + "{CIncludes}"CGAffineTransform.h ¶ + "{CIncludes}"CGColorSpace.h ¶ + "{CIncludes}"CGFont.h ¶ + "{CIncludes}"CGImage.h ¶ + "{CIncludes}"CGPDFDocument.h ¶ + "{CIncludes}"CFBundle.h ¶ + "{CIncludes}"Multiprocessing.h ¶ + "{CIncludes}"CGGeometry.h ¶ + "{CIncludes}"CGDataProvider.h ¶ + "{CIncludes}"CFURL.h + diff --git a/byterun/Makefile.nt b/byterun/Makefile.nt new file mode 100644 index 00000000..b7c44016 --- /dev/null +++ b/byterun/Makefile.nt @@ -0,0 +1,105 @@ +######################################################################### +# # +# 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: Makefile.nt,v 1.33 2002/06/17 12:24:42 xleroy Exp $ + +include ../config/Makefile + +CC=$(BYTECC) +CFLAGS=-DIN_OCAMLRUN -DOCAML_STDLIB_DIR='"$(LIBDIR)"' + +COMMONOBJS=interp.o misc.o stacks.o fix_code.o startup.o \ + fail.o signals.o freelist.o major_gc.o minor_gc.o \ + memory.o alloc.o roots.o compare.o ints.o floats.o \ + str.o array.o io.o extern.o intern.o hash.o sys.o \ + meta.o parsing.o gc_ctrl.o terminfo.o md5.o obj.o lexing.o \ + win32.o printexc.o callback.o debugger.o weak.o compact.o \ + finalise.o custom.o backtrace.o globroots.o dynlink.o + +DOBJS=$(COMMONOBJS:.o=.$(DO)) prims.$(DO) +SOBJS=$(COMMONOBJS:.o=.$(SO)) main.$(SO) + +PRIMS=alloc.c array.c compare.c extern.c floats.c gc_ctrl.c hash.c \ + intern.c interp.c ints.c io.c lexing.c md5.c meta.c obj.c parsing.c \ + signals.c str.c sys.c terminfo.c callback.c weak.c finalise.c stacks.c \ + dynlink.c + +PUBLIC_INCLUDES=alloc.h callback.h config.h custom.h fail.h intext.h \ + memory.h misc.h mlvalues.h + +all: ocamlrun.exe libcamlrun.$(A) + +ocamlrun.exe: ocamlrun.dll main.$(DO) + $(CC) -o ocamlrun.exe main.$(DO) ocamlrun.$(A) + +ocamlrun.dll: $(DOBJS) + $(call MKDLL,ocamlrun.dll,ocamlrun.$(A),$(DOBJS) $(BYTECCLIBS)) + +libcamlrun.$(A): $(SOBJS) + $(call MKLIB,libcamlrun.$(A),$(SOBJS)) + +install: + cp ocamlrun.exe $(BINDIR)/ocamlrun.exe + cp ocamlrun.dll $(BINDIR)/ocamlrun.dll + cp ocamlrun.$(A) $(LIBDIR)/ocamlrun.$(A) + cp libcamlrun.$(A) $(LIBDIR)/libcamlrun.$(A) + test -d $(LIBDIR)/caml || mkdir -p $(LIBDIR)/caml + for i in $(PUBLIC_INCLUDES); do sed -f ../tools/cleanup-header $$i > $(LIBDIR)/caml/$$i; done + +clean: + rm -f *.exe *.dll *.$(O) *.$(A) + rm -f primitives prims.c opnames.h jumptbl.h + +primitives : $(PRIMS) + sed -n -e "s/CAMLprim value \([a-z0-9_][a-z0-9_]*\).*/\1/p" \ + $(PRIMS) > primitives + +prims.c : primitives + (echo '#include "mlvalues.h"'; \ + echo '#include "prims.h"'; \ + sed -e 's/.*/extern value &();/' primitives; \ + echo 'c_primitive builtin_cprim[] = {'; \ + sed -e 's/.*/ &,/' primitives; \ + echo ' 0 };'; \ + echo 'char * names_of_builtin_cprim[] = {'; \ + sed -e 's/.*/ "&",/' primitives; \ + echo ' 0 };') > prims.c + +opnames.h : instruct.h + sed -e "/\/\*/d" \ + -e "s\enum /char * names_of_/" \ + -e "s/{$$/[] = {/" \ + -e "s/\([A-Z][A-Z_0-9]*\)/"\1"/g" instruct.h > opnames.h + +# jumptbl.h is required only if you have GCC 2.0 or later +jumptbl.h : instruct.h + sed -n -e "/^ /s/ \([A-Z]\)/ \&\&lbl_\1/gp" \ + -e "/^}/q" instruct.h > jumptbl.h + +main.$(DO): main.c + $(CC) $(DLLCCCOMPOPTS) -c main.c + mv main.$(O) main.$(DO) + +.SUFFIXES: .$(DO) .$(SO) + +.c.$(DO): + $(CC) $(CFLAGS) $(DLLCCCOMPOPTS) -c $< + mv $*.$(O) $*.$(DO) +.c.$(SO): + $(CC) $(CFLAGS) $(BYTECCCOMPOPTS) -c $< + mv $*.$(O) $*.$(SO) + +.depend.nt: + sed -e '/\.d\.o/q' -e 's/^\(.*\)\.o:/\1.$$(DO) \1.$$(SO):/' .depend > .depend.nt + +include .depend.nt diff --git a/byterun/alloc.c b/byterun/alloc.c new file mode 100644 index 00000000..7de5b2f8 --- /dev/null +++ b/byterun/alloc.c @@ -0,0 +1,164 @@ +/***********************************************************************/ +/* */ +/* 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: alloc.c,v 1.25 2002/01/18 15:13:25 doligez Exp $ */ + +/* 1. Allocation functions doing the same work as the macros in the + case where [Setup_for_gc] and [Restore_after_gc] are no-ops. + 2. Convenience functions related to allocation. +*/ + +#include +#include "alloc.h" +#include "custom.h" +#include "major_gc.h" +#include "memory.h" +#include "mlvalues.h" +#include "stacks.h" + +#define Setup_for_gc +#define Restore_after_gc + +CAMLexport value alloc (mlsize_t wosize, tag_t tag) +{ + value result; + mlsize_t i; + + Assert (tag < 256); + Assert (tag != Infix_tag); + if (wosize == 0){ + result = Atom (tag); + }else if (wosize <= Max_young_wosize){ + Alloc_small (result, wosize, tag); + if (tag < No_scan_tag){ + for (i = 0; i < wosize; i++) Field (result, i) = 0; + } + }else{ + result = alloc_shr (wosize, tag); + if (tag < No_scan_tag) memset (Bp_val (result), 0, Bsize_wsize (wosize)); + result = check_urgent_gc (result); + } + return result; +} + +CAMLexport value alloc_small (mlsize_t wosize, tag_t tag) +{ + value result; + + Assert (wosize > 0); + Assert (wosize <= Max_young_wosize); + Assert (tag < 256); + Alloc_small (result, wosize, tag); + return result; +} + +CAMLexport value alloc_tuple(mlsize_t n) +{ + return alloc(n, 0); +} + +CAMLexport value alloc_string (mlsize_t len) +{ + value result; + mlsize_t offset_index; + mlsize_t wosize = (len + sizeof (value)) / sizeof (value); + + if (wosize <= Max_young_wosize) { + Alloc_small (result, wosize, String_tag); + }else{ + result = alloc_shr (wosize, String_tag); + result = check_urgent_gc (result); + } + Field (result, wosize - 1) = 0; + offset_index = Bsize_wsize (wosize) - 1; + Byte (result, offset_index) = offset_index - len; + return result; +} + +CAMLexport value alloc_final (mlsize_t len, final_fun fun, + mlsize_t mem, mlsize_t max) +{ + return alloc_custom(final_custom_operations(fun), + len * sizeof(value), mem, max); +} + +CAMLexport value copy_string(char const *s) +{ + int len; + value res; + + len = strlen(s); + res = alloc_string(len); + memmove(String_val(res), s, len); + return res; +} + +CAMLexport value alloc_array(value (*funct)(char const *), char const ** arr) +{ + CAMLparam0 (); + mlsize_t nbr, n; + CAMLlocal2 (v, result); + + nbr = 0; + while (arr[nbr] != 0) nbr++; + if (nbr == 0) { + CAMLreturn (Atom(0)); + } else { + result = alloc (nbr, 0); + for (n = 0; n < nbr; n++) { + /* The two statements below must be separate because of evaluation + order (don't take the address &Field(result, n) before + calling funct, which may cause a GC and move result). */ + v = funct(arr[n]); + modify(&Field(result, n), v); + } + CAMLreturn (result); + } +} + +CAMLexport value copy_string_array(char const ** arr) +{ + return alloc_array(copy_string, arr); +} + +CAMLexport int convert_flag_list(value list, int *flags) +{ + int res; + res = 0; + while (list != Val_int(0)) { + res |= flags[Int_val(Field(list, 0))]; + list = Field(list, 1); + } + return res; +} + +/* For compiling let rec over values */ + +CAMLprim value alloc_dummy(value size) +{ + mlsize_t wosize = Int_val(size); + + if (wosize == 0) return Atom(0); + return alloc (wosize, 0); +} + +CAMLprim value update_dummy(value dummy, value newval) +{ + mlsize_t size, i; + size = Wosize_val(newval); + Assert (size == Wosize_val(dummy)); + Tag_val(dummy) = Tag_val(newval); + for (i = 0; i < size; i++) + modify(&Field(dummy, i), Field(newval, i)); + return Val_unit; +} diff --git a/byterun/alloc.h b/byterun/alloc.h new file mode 100644 index 00000000..a84474f9 --- /dev/null +++ b/byterun/alloc.h @@ -0,0 +1,44 @@ +/***********************************************************************/ +/* */ +/* 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: alloc.h,v 1.13 2002/11/04 13:58:10 doligez Exp $ */ + +#ifndef _alloc_ +#define _alloc_ + + +#include "misc.h" +#include "mlvalues.h" + +CAMLextern value alloc (mlsize_t, tag_t); +CAMLextern value alloc_small (mlsize_t, tag_t); +CAMLextern value alloc_tuple (mlsize_t); +CAMLextern value alloc_string (mlsize_t); /* size in bytes */ +CAMLextern value copy_string (char const *); +CAMLextern value copy_string_array (char const **); +CAMLextern value copy_double (double); +CAMLextern value copy_int32 (int32); /* defined in [ints.c] */ +CAMLextern value copy_int64 (int64); /* defined in [ints.c] */ +CAMLextern value copy_nativeint (long); /* defined in [ints.c] */ +CAMLextern value alloc_array (value (*funct) (char const *), + char const ** array); + +typedef void (*final_fun)(value); +CAMLextern value alloc_final (mlsize_t, /*size in words*/ + final_fun, /*finalization function*/ + mlsize_t, /*resources consumed*/ + mlsize_t /*max resources*/); + +CAMLextern int convert_flag_list (value, int *); + +#endif /* _alloc_ */ diff --git a/byterun/array.c b/byterun/array.c new file mode 100644 index 00000000..506ec3cc --- /dev/null +++ b/byterun/array.c @@ -0,0 +1,197 @@ +/***********************************************************************/ +/* */ +/* 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: array.c,v 1.17 2001/12/07 13:39:22 xleroy Exp $ */ + +/* Operations on arrays */ + +#include "alloc.h" +#include "fail.h" +#include "memory.h" +#include "misc.h" +#include "mlvalues.h" + +#ifndef NATIVE_CODE + +CAMLprim value array_get_addr(value array, value index) +{ + long idx = Long_val(index); + if (idx < 0 || idx >= Wosize_val(array)) invalid_argument("Array.get"); + return Field(array, idx); +} + +CAMLprim value array_get_float(value array, value index) +{ + long idx = Long_val(index); + double d; + value res; + + if (idx < 0 || idx >= Wosize_val(array) / Double_wosize) + invalid_argument("Array.get"); + d = Double_field(array, idx); +#define Setup_for_gc +#define Restore_after_gc + Alloc_small(res, Double_wosize, Double_tag); +#undef Setup_for_gc +#undef Restore_after_gc + Store_double_val(res, d); + return res; +} + +CAMLprim value array_get(value array, value index) +{ + if (Tag_val(array) == Double_array_tag) + return array_get_float(array, index); + else + return array_get_addr(array, index); +} + +CAMLprim value array_set_addr(value array, value index, value newval) +{ + long idx = Long_val(index); + if (idx < 0 || idx >= Wosize_val(array)) invalid_argument("Array.set"); + Modify(&Field(array, idx), newval); + return Val_unit; +} + +CAMLprim value array_set_float(value array, value index, value newval) +{ + long idx = Long_val(index); + if (idx < 0 || idx >= Wosize_val(array) / Double_wosize) + invalid_argument("Array.set"); + Store_double_field(array, idx, Double_val(newval)); + return Val_unit; +} + +CAMLprim value array_set(value array, value index, value newval) +{ + if (Tag_val(array) == Double_array_tag) + return array_set_float(array, index, newval); + else + return array_set_addr(array, index, newval); +} + +CAMLprim value array_unsafe_get_float(value array, value index) +{ + double d; + value res; + + d = Double_field(array, Long_val(index)); +#define Setup_for_gc +#define Restore_after_gc + Alloc_small(res, Double_wosize, Double_tag); +#undef Setup_for_gc +#undef Restore_after_gc + Store_double_val(res, d); + return res; +} + +CAMLprim value array_unsafe_get(value array, value index) +{ + if (Tag_val(array) == Double_array_tag) + return array_unsafe_get_float(array, index); + else + return Field(array, Long_val(index)); +} + +CAMLprim value array_unsafe_set_addr(value array, value index, value newval) +{ + long idx = Long_val(index); + Modify(&Field(array, idx), newval); + return Val_unit; +} + +CAMLprim value array_unsafe_set_float(value array, value index, value newval) +{ + Store_double_field(array, Long_val(index), Double_val(newval)); + return Val_unit; +} + +CAMLprim value array_unsafe_set(value array, value index, value newval) +{ + if (Tag_val(array) == Double_array_tag) + return array_unsafe_set_float(array, index, newval); + else + return array_unsafe_set_addr(array, index, newval); +} + +#endif + +CAMLprim value make_vect(value len, value init) +{ + CAMLparam2 (len, init); + CAMLlocal1 (res); + mlsize_t size, wsize, i; + double d; + + size = Long_val(len); + if (size == 0) { + res = Atom(0); + } + else if (Is_block(init) + && (Is_atom(init) || Is_young(init) || Is_in_heap(init)) + && Tag_val(init) == Double_tag) { + d = Double_val(init); + wsize = size * Double_wosize; + if (wsize > Max_wosize) invalid_argument("Array.make"); + res = alloc(wsize, Double_array_tag); + for (i = 0; i < size; i++) { + Store_double_field(res, i, d); + } + } else { + if (size > Max_wosize) invalid_argument("Array.make"); + if (size < Max_young_wosize) { + res = alloc_small(size, 0); + for (i = 0; i < size; i++) Field(res, i) = init; + } + else if (Is_block(init) && Is_young(init)) { + minor_collection(); + res = alloc_shr(size, 0); + for (i = 0; i < size; i++) Field(res, i) = init; + res = check_urgent_gc (res); + } + else { + res = alloc_shr(size, 0); + for (i = 0; i < size; i++) initialize(&Field(res, i), init); + res = check_urgent_gc (res); + } + } + CAMLreturn (res); +} + +CAMLprim value make_array(value init) +{ + CAMLparam1 (init); + mlsize_t wsize, size, i; + CAMLlocal2 (v, res); + + size = Wosize_val(init); + if (size == 0) { + CAMLreturn (init); + } else { + v = Field(init, 0); + if (Is_long(v) + || (!Is_atom(v) && !Is_young(v) && !Is_in_heap(v)) + || Tag_val(v) != Double_tag) { + CAMLreturn (init); + } else { + Assert(size < Max_young_wosize); + wsize = size * Double_wosize; + res = alloc_small(wsize, Double_array_tag); + for (i = 0; i < size; i++) { + Store_double_field(res, i, Double_val(Field(init, i))); + } + CAMLreturn (res); + } + } +} diff --git a/byterun/backtrace.c b/byterun/backtrace.c new file mode 100644 index 00000000..2bd7f758 --- /dev/null +++ b/byterun/backtrace.c @@ -0,0 +1,212 @@ +/***********************************************************************/ +/* */ +/* 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: backtrace.c,v 1.16 2003/02/24 16:44:47 doligez Exp $ */ + +/* Stack backtrace for uncaught exceptions */ + +#include +#include +#include +#include "config.h" +#ifdef HAS_UNISTD +#include +#endif +#include "mlvalues.h" +#include "alloc.h" +#include "io.h" +#include "instruct.h" +#include "intext.h" +#include "exec.h" +#include "fix_code.h" +#include "startup.h" +#include "stacks.h" +#include "sys.h" +#include "backtrace.h" + +CAMLexport int backtrace_active = 0; +CAMLexport int backtrace_pos = 0; +CAMLexport code_t * backtrace_buffer = NULL; +CAMLexport value backtrace_last_exn = Val_unit; +#define BACKTRACE_BUFFER_SIZE 1024 + +/* Location of fields in the Instruct.debug_event record */ +enum { EV_POS = 0, + EV_MODULE = 1, + EV_CHAR = 2, + EV_KIND = 3 }; + +/* Location of fields in the Lexing.position record. */ +enum { + POS_FNAME = 0, + POS_LNUM = 1, + POS_BOL = 2, + POS_CNUM = 3 +}; + +/* Initialize the backtrace machinery */ + +void init_backtrace(void) +{ + backtrace_active = 1; + register_global_root(&backtrace_last_exn); + /* Note: lazy initialization of backtrace_buffer in stash_backtrace + to simplify the interface with the thread libraries */ +} + +/* Store the return addresses contained in the given stack fragment + into the backtrace array */ + +void stash_backtrace(value exn, code_t pc, value * sp) +{ + code_t end_code = (code_t) ((char *) start_code + code_size); + if (pc != NULL) pc = pc - 1; + if (exn != backtrace_last_exn) { + backtrace_pos = 0; + backtrace_last_exn = exn; + } + if (backtrace_buffer == NULL) { + backtrace_buffer = malloc(BACKTRACE_BUFFER_SIZE * sizeof(code_t)); + if (backtrace_buffer == NULL) return; + } + if (backtrace_pos >= BACKTRACE_BUFFER_SIZE) return; + if (pc >= start_code && pc < end_code){ + backtrace_buffer[backtrace_pos++] = pc; + } + for (/*nothing*/; sp < trapsp; sp++) { + code_t p = (code_t) *sp; + if (p >= start_code && p < end_code) { + if (backtrace_pos >= BACKTRACE_BUFFER_SIZE) break; + backtrace_buffer[backtrace_pos++] = p; + } + } +} + +/* Read the debugging info contained in the current bytecode executable. + Return a Caml array of Caml lists of debug_event records in "events", + or Val_false on failure. */ + +#ifndef O_BINARY +#define O_BINARY 0 +#endif + +static value read_debug_info(void) +{ + CAMLparam0(); + CAMLlocal1(events); + char * exec_name; + int fd; + struct exec_trailer trail; + struct channel * chan; + uint32 num_events, orig, i; + value evl, l; + + exec_name = caml_exe_name; + fd = attempt_open(&exec_name, &trail, 1); + if (fd < 0) CAMLreturn(Val_false); + read_section_descriptors(fd, &trail); + if (seek_optional_section(fd, &trail, "DBUG") == -1) { + close(fd); + CAMLreturn(Val_false); + } + chan = open_descriptor_in(fd); + num_events = getword(chan); + events = alloc(num_events, 0); + for (i = 0; i < num_events; i++) { + orig = getword(chan); + evl = input_val(chan); + /* Relocate events in event list */ + for (l = evl; l != Val_int(0); l = Field(l, 1)) { + value ev = Field(l, 0); + Field(ev, EV_POS) = Val_long(Long_val(Field(ev, EV_POS)) + orig); + } + /* Record event list */ + Store_field(events, i, evl); + } + close_channel(chan); + CAMLreturn(events); +} + +/* Search the event for the given PC. Return Val_false if not found. */ + +static value event_for_location(value events, code_t pc) +{ + mlsize_t i; + value pos, l, ev, ev_pos; + + Assert(pc >= start_code && pc < start_code + code_size); + pos = Val_long((char *) pc - (char *) start_code); + for (i = 0; i < Wosize_val(events); i++) { + for (l = Field(events, i); l != Val_int(0); l = Field(l, 1)) { + ev = Field(l, 0); + ev_pos = Field(ev, EV_POS); + /* ocamlc sometimes moves an event past a following PUSH instruction; + allow mismatch by 1 instruction. */ + if (ev_pos == pos || ev_pos == pos + 8) return ev; + } + } + return Val_false; +} + +/* Print the location corresponding to the given PC */ + +static void print_location(value events, int index) +{ + code_t pc = backtrace_buffer[index]; + char * info; + value ev; + + ev = event_for_location(events, pc); + if (is_instruction(*pc, RAISE)) { + /* Ignore compiler-inserted raise */ + if (ev == Val_false) return; + /* Initial raise if index == 0, re-raise otherwise */ + if (index == 0) + info = "Raised at"; + else + info = "Re-raised at"; + } else { + if (index == 0) + info = "Raised by primitive operation at"; + else + info = "Called from"; + } + if (ev == Val_false) { + fprintf(stderr, "%s unknown location\n", info); + } else { + value ev_char = Field (ev, EV_CHAR); + char *fname = String_val (Field (ev_char, POS_FNAME)); + int lnum = Int_val (Field (ev_char, POS_LNUM)); + int chr = Int_val (Field (ev_char, POS_CNUM)) + - Int_val (Field (ev_char, POS_BOL)); + fprintf (stderr, "%s file \"%s\", line %d, character %d\n", info, fname, + lnum, chr); + } +} + +/* Print a backtrace */ + +CAMLexport void print_exception_backtrace(void) +{ + value events; + int i; + + events = read_debug_info(); + if (events == Val_false) { + fprintf(stderr, + "(Program not linked with -g, cannot print stack backtrace)\n"); + return; + } + for (i = 0; i < backtrace_pos; i++) + print_location(events, i); +} diff --git a/byterun/backtrace.h b/byterun/backtrace.h new file mode 100644 index 00000000..8040627b --- /dev/null +++ b/byterun/backtrace.h @@ -0,0 +1,15 @@ +#ifndef _backtrace_ +#define _backtrace_ + +#include "mlvalues.h" + +CAMLextern int backtrace_active; +CAMLextern int backtrace_pos; +CAMLextern code_t * backtrace_buffer; +CAMLextern value backtrace_last_exn; + +extern void init_backtrace(void); +extern void stash_backtrace(value exn, code_t pc, value * sp); +CAMLextern void print_exception_backtrace(void); + +#endif diff --git a/byterun/callback.c b/byterun/callback.c new file mode 100644 index 00000000..69ab25fd --- /dev/null +++ b/byterun/callback.c @@ -0,0 +1,211 @@ +/***********************************************************************/ +/* */ +/* 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: callback.c,v 1.15 2002/07/11 15:37:18 xleroy Exp $ */ + +/* Callbacks from C to Caml */ + +#include +#include "callback.h" +#include "fail.h" +#include "memory.h" +#include "mlvalues.h" + +#ifndef NATIVE_CODE + +/* Bytecode callbacks */ + +#include "interp.h" +#include "instruct.h" +#include "fix_code.h" +#include "stacks.h" + +int callback_depth = 0; + +static opcode_t callback_code[] = { ACC, 0, APPLY, 0, POP, 1, STOP }; + +#ifdef THREADED_CODE + +static int callback_code_threaded = 0; + +static void thread_callback(void) +{ + thread_code(callback_code, sizeof(callback_code)); + callback_code_threaded = 1; +} + +#define Init_callback() if (!callback_code_threaded) thread_callback() + +#else + +#define Init_callback() + +#endif + +CAMLexport value callbackN_exn(value closure, int narg, value args[]) +{ + int i; + value res; + + Assert(narg + 4 <= 256); + Init_callback(); + extern_sp -= narg + 4; + for (i = 0; i < narg; i++) extern_sp[i] = args[i]; /* arguments */ + extern_sp[narg] = (value) (callback_code + 4); /* return address */ + extern_sp[narg + 1] = Val_unit; /* environment */ + extern_sp[narg + 2] = Val_long(0); /* extra args */ + extern_sp[narg + 3] = closure; + callback_code[1] = narg + 3; + callback_code[3] = narg; + res = interprete(callback_code, sizeof(callback_code)); + if (Is_exception_result(res)) extern_sp += narg + 4; /* PR#1228 */ + return res; +} + +CAMLexport value callback_exn(value closure, value arg1) +{ + value arg[1]; + arg[0] = arg1; + return callbackN_exn(closure, 1, arg); +} + +CAMLexport value callback2_exn(value closure, value arg1, value arg2) +{ + value arg[2]; + arg[0] = arg1; + arg[1] = arg2; + return callbackN_exn(closure, 2, arg); +} + +CAMLexport value callback3_exn(value closure, + value arg1, value arg2, value arg3) +{ + value arg[3]; + arg[0] = arg1; + arg[1] = arg2; + arg[2] = arg3; + return callbackN_exn(closure, 3, arg); +} + +#else + +/* Native-code callbacks. callback[123]_exn are implemented in asm. */ + +CAMLexport value callbackN_exn(value closure, int narg, value args[]) +{ + CAMLparam1 (closure); + CAMLxparamN (args, narg); + CAMLlocal1 (res); + int i; + + res = closure; + for (i = 0; i < narg; /*nothing*/) { + /* Pass as many arguments as possible */ + switch (narg - i) { + case 1: + res = callback_exn(res, args[i]); + if (Is_exception_result(res)) CAMLreturn (res); + i += 1; + break; + case 2: + res = callback2_exn(res, args[i], args[i + 1]); + if (Is_exception_result(res)) CAMLreturn (res); + i += 2; + break; + default: + res = callback3_exn(res, args[i], args[i + 1], args[i + 2]); + if (Is_exception_result(res)) CAMLreturn (res); + i += 3; + break; + } + } + CAMLreturn (res); +} + +#endif + +/* Exception-propagating variants of the above */ + +CAMLexport value callback (value closure, value arg) +{ + value res = callback_exn(closure, arg); + if (Is_exception_result(res)) mlraise(Extract_exception(res)); + return res; +} + +CAMLexport value callback2 (value closure, value arg1, value arg2) +{ + value res = callback2_exn(closure, arg1, arg2); + if (Is_exception_result(res)) mlraise(Extract_exception(res)); + return res; +} + +CAMLexport value callback3 (value closure, value arg1, value arg2, value arg3) +{ + value res = callback3_exn(closure, arg1, arg2, arg3); + if (Is_exception_result(res)) mlraise(Extract_exception(res)); + return res; +} + +CAMLexport value callbackN (value closure, int narg, value args[]) +{ + value res = callbackN_exn(closure, narg, args); + if (Is_exception_result(res)) mlraise(Extract_exception(res)); + return res; +} + +/* Naming of Caml values */ + +struct named_value { + value val; + struct named_value * next; + char name[1]; +}; + +#define Named_value_size 13 + +static struct named_value * named_value_table[Named_value_size] = { NULL, }; + +static unsigned int hash_value_name(char *name) +{ + unsigned int h; + for (h = 0; *name != 0; name++) h = h * 19 + *name; + return h % Named_value_size; +} + +CAMLprim value register_named_value(value vname, value val) +{ + struct named_value * nv; + char * name = String_val(vname); + unsigned int h = hash_value_name(name); + + nv = (struct named_value *) + stat_alloc(sizeof(struct named_value) + strlen(name)); + strcpy(nv->name, name); + nv->val = val; + nv->next = named_value_table[h]; + named_value_table[h] = nv; + register_global_root(&nv->val); + return Val_unit; +} + +CAMLexport value * caml_named_value(char *name) +{ + struct named_value * nv; + for (nv = named_value_table[hash_value_name(name)]; + nv != NULL; + nv = nv->next) { + if (strcmp(name, nv->name) == 0) return &nv->val; + } + return NULL; +} diff --git a/byterun/callback.h b/byterun/callback.h new file mode 100644 index 00000000..062d3287 --- /dev/null +++ b/byterun/callback.h @@ -0,0 +1,47 @@ +/***********************************************************************/ +/* */ +/* 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: callback.h,v 1.8 2001/12/07 13:39:22 xleroy Exp $ */ + +/* Callbacks from C to Caml */ + +#ifndef _callback_ +#define _callback_ + +#include "mlvalues.h" + +CAMLextern value callback (value closure, value arg); +CAMLextern value callback2 (value closure, value arg1, value arg2); +CAMLextern value callback3 (value closure, value arg1, value arg2, value arg3); +CAMLextern value callbackN (value closure, int narg, value args[]); + +CAMLextern value callback_exn (value closure, value arg); +CAMLextern value callback2_exn (value closure, value arg1, value arg2); +CAMLextern value callback3_exn (value closure, + value arg1, value arg2, value arg3); +CAMLextern value callbackN_exn (value closure, int narg, value args[]); + +#define Make_exception_result(v) ((v) | 2) +#define Is_exception_result(v) (((v) & 3) == 2) +#define Extract_exception(v) ((v) & ~3) + +CAMLextern char * format_caml_exception(value exn); /* in [printexc.c] */ + +CAMLextern value * caml_named_value (char * name); + +CAMLextern void caml_main (char ** argv); +CAMLextern void caml_startup (char ** argv); + +CAMLextern int callback_depth; + +#endif diff --git a/byterun/compact.c b/byterun/compact.c new file mode 100644 index 00000000..575d573c --- /dev/null +++ b/byterun/compact.c @@ -0,0 +1,433 @@ +/***********************************************************************/ +/* */ +/* Objective Caml */ +/* */ +/* Damien Doligez, projet Para, 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: compact.c,v 1.17 2002/12/12 18:59:11 doligez Exp $ */ + +#include + +#include "config.h" +#include "finalise.h" +#include "freelist.h" +#include "gc.h" +#include "gc_ctrl.h" +#include "major_gc.h" +#include "memory.h" +#include "mlvalues.h" +#include "roots.h" +#include "weak.h" + +extern unsigned long percent_free; /* major_gc.c */ +extern void shrink_heap (char *); /* memory.c */ + +/* Encoded headers: the color is stored in the 2 least significant bits. + (For pointer inversion, we need to distinguish headers from pointers.) + s is a Wosize, t is a tag, and c is a color (a two-bit number) + + For the purpose of compaction, "colors" are: + 0: pointers (direct or inverted) + 1: integer or (unencoded) infix header + 2: inverted pointer for infix header + 3: integer or encoded (noninfix) header + + XXX Should be fixed: + XXX The above assumes that all roots are aligned on a 4-byte boundary, + XXX which is not always guaranteed by C. + XXX (see [register_global_roots] and [init_exceptions]) + XXX Should be able to fix it to only assume 2-byte alignment. +*/ +#define Make_ehd(s,t,c) (((s) << 10) | (t) << 2 | (c)) +#define Whsize_ehd(h) Whsize_hd (h) +#define Wosize_ehd(h) Wosize_hd (h) +#define Tag_ehd(h) (((h) >> 2) & 0xFF) +#define Ecolor(w) ((w) & 3) + +typedef unsigned long word; + +static void invert_pointer_at (word *p) +{ + word q = *p; + Assert (Ecolor ((long) p) == 0); + + /* Use Ecolor (q) == 0 instead of Is_block (q) because q could be an + inverted pointer for an infix header (with Ecolor == 2). */ + if (Ecolor (q) == 0 && Is_in_heap (q)){ + switch (Ecolor (Hd_val (q))){ + case 0: + case 3: /* Pointer or header: insert in inverted list. */ + *p = Hd_val (q); + Hd_val (q) = (header_t) p; + break; + case 1: /* Infix header: make inverted infix list. */ + /* Double inversion: the last of the inverted infix list points to + the next infix header in this block. The last of the last list + contains the original block header. */ + { + /* This block as a value. */ + value val = (value) q - Infix_offset_val (q); + /* Get the block header. */ + word *hp = (word *) Hp_val (val); + + while (Ecolor (*hp) == 0) hp = (word *) *hp; + Assert (Ecolor (*hp) == 3); + if (Tag_ehd (*hp) == Closure_tag){ + /* This is the first infix found in this block. */ + /* Save original header. */ + *p = *hp; + /* Link inverted infix list. */ + Hd_val (q) = (header_t) ((word) p | 2); + /* Change block header's tag to Infix_tag, and change its size + to point to the infix list. */ + *hp = Make_ehd (Wosize_bhsize (q - val), Infix_tag, 3); + }else{ Assert (Tag_ehd (*hp) == Infix_tag); + /* Point the last of this infix list to the current first infix + list of the block. */ + *p = (word) &Field (val, Wosize_ehd (*hp)) | 1; + /* Point the head of this infix list to the above. */ + Hd_val (q) = (header_t) ((word) p | 2); + /* Change block header's size to point to this infix list. */ + *hp = Make_ehd (Wosize_bhsize (q - val), Infix_tag, 3); + } + } + break; + case 2: /* Inverted infix list: insert. */ + *p = Hd_val (q); + Hd_val (q) = (header_t) ((word) p | 2); + break; + } + } +} + +static void invert_root (value v, value *p) +{ + invert_pointer_at ((word *) p); +} + +static char *compact_fl; + +static void init_compact_allocate (void) +{ + char *ch = heap_start; + while (ch != NULL){ + Chunk_alloc (ch) = 0; + ch = Chunk_next (ch); + } + compact_fl = heap_start; +} + +static char *compact_allocate (mlsize_t size) + /* in bytes, including header */ +{ + char *chunk, *adr; + + while (Chunk_size (compact_fl) - Chunk_alloc (compact_fl) <= Bhsize_wosize (3) + && Chunk_size (Chunk_next (compact_fl)) + - Chunk_alloc (Chunk_next (compact_fl)) + <= Bhsize_wosize (3)){ + compact_fl = Chunk_next (compact_fl); + } + chunk = compact_fl; + while (Chunk_size (chunk) - Chunk_alloc (chunk) < size){ + chunk = Chunk_next (chunk); Assert (chunk != NULL); + } + adr = chunk + Chunk_alloc (chunk); + Chunk_alloc (chunk) += size; + return adr; +} + +void compact_heap (void) +{ + char *ch, *chend; + Assert (gc_phase == Phase_idle); + gc_message (0x10, "Compacting heap...\n", 0); + +#ifdef DEBUG + heap_check (); +#endif + + /* First pass: encode all noninfix headers. */ + { + ch = heap_start; + while (ch != NULL){ + header_t *p = (header_t *) ch; + + chend = ch + Chunk_size (ch); + while ((char *) p < chend){ + header_t hd = Hd_hp (p); + mlsize_t sz = Wosize_hd (hd); + + if (Is_blue_hd (hd)){ + /* Free object. Give it a string tag. */ + Hd_hp (p) = Make_ehd (sz, String_tag, 3); + }else{ Assert (Is_white_hd (hd)); + /* Live object. Keep its tag. */ + Hd_hp (p) = Make_ehd (sz, Tag_hd (hd), 3); + } + p += Whsize_wosize (sz); + } + ch = Chunk_next (ch); + } + } + + + /* Second pass: invert pointers. + Link infix headers in each block in an inverted list of inverted lists. + Don't forget roots and weak pointers. */ + { + /* Invert roots first because the threads library needs some heap + data structures to find its roots. Fortunately, it doesn't need + the headers (see above). */ + do_roots (invert_root); + final_do_weak_roots (invert_root); + + ch = heap_start; + while (ch != NULL){ + word *p = (word *) ch; + chend = ch + Chunk_size (ch); + + while ((char *) p < chend){ + word q = *p; + size_t sz, i; + tag_t t; + word *infixes; + + while (Ecolor (q) == 0) q = * (word *) q; + sz = Whsize_ehd (q); + t = Tag_ehd (q); + + if (t == Infix_tag){ + /* Get the original header of this block. */ + infixes = p + sz; + q = *infixes; + while (Ecolor (q) != 3) q = * (word *) (q & ~(unsigned long)3); + sz = Whsize_ehd (q); + t = Tag_ehd (q); + } + + if (t < No_scan_tag){ + for (i = 1; i < sz; i++) invert_pointer_at (&(p[i])); + } + p += sz; + } + ch = Chunk_next (ch); + } + /* Invert weak pointers. */ + { + value *pp = &weak_list_head; + value p; + word q; + size_t sz, i; + + while (1){ + p = *pp; + if (p == (value) NULL) break; + q = Hd_val (p); + while (Ecolor (q) == 0) q = * (word *) q; + sz = Wosize_ehd (q); + for (i = 1; i < sz; i++){ + if (Field (p,i) != 0) invert_pointer_at ((word *) &(Field (p,i))); + } + invert_pointer_at ((word *) pp); + pp = &Field (p, 0); + } + } + } + + + /* Third pass: reallocate virtually; revert pointers; decode headers. + Rebuild infix headers. */ + { + init_compact_allocate (); + ch = heap_start; + while (ch != NULL){ + word *p = (word *) ch; + + chend = ch + Chunk_size (ch); + while ((char *) p < chend){ + word q = *p; + + if (Ecolor (q) == 0 || Tag_ehd (q) == Infix_tag){ + /* There were (normal or infix) pointers to this block. */ + size_t sz; + tag_t t; + char *newadr; + word *infixes = NULL; + + while (Ecolor (q) == 0) q = * (word *) q; + sz = Whsize_ehd (q); + t = Tag_ehd (q); + + if (t == Infix_tag){ + /* Get the original header of this block. */ + infixes = p + sz; + q = *infixes; Assert (Ecolor (q) == 2); + while (Ecolor (q) != 3) q = * (word *) (q & ~(unsigned long)3); + sz = Whsize_ehd (q); + t = Tag_ehd (q); + } + + newadr = compact_allocate (Bsize_wsize (sz)); + q = *p; + while (Ecolor (q) == 0){ + word next = * (word *) q; + * (word *) q = (word) Val_hp (newadr); + q = next; + } + *p = Make_header (Wosize_whsize (sz), t, Caml_white); + + if (infixes != NULL){ + /* Rebuild the infix headers and revert the infix pointers. */ + while (Ecolor ((word) infixes) != 3){ + infixes = (word *) ((word) infixes & ~(unsigned long) 3); + q = *infixes; + while (Ecolor (q) == 2){ + word next; + q = (word) q & ~(unsigned long) 3; + next = * (word *) q; + * (word *) q = (word) Val_hp ((word *) newadr + (infixes - p)); + q = next; + } Assert (Ecolor (q) == 1 || Ecolor (q) == 3); + *infixes = Make_header (infixes - p, Infix_tag, Caml_white); + infixes = (word *) q; + } + } + p += sz; + }else{ Assert (Ecolor (q) == 3); + /* This is guaranteed only if compact_heap was called after a + nonincremental major GC: Assert (Tag_ehd (q) == String_tag); + */ + /* No pointers to the header and no infix header: + the object was free. */ + *p = Make_header (Wosize_ehd (q), Tag_ehd (q), Caml_blue); + p += Whsize_ehd (q); + } + } + ch = Chunk_next (ch); + } + } + + + /* Fourth pass: reallocate and move objects. + Use the exact same allocation algorithm as pass 3. */ + { + init_compact_allocate (); + ch = heap_start; + while (ch != NULL){ + word *p = (word *) ch; + + chend = ch + Chunk_size (ch); + while ((char *) p < chend){ + word q = *p; + if (Color_hd (q) == Caml_white){ + size_t sz = Bhsize_hd (q); + char *newadr = compact_allocate (sz); Assert (newadr <= (char *)p); + memmove (newadr, p, sz); + p += Wsize_bsize (sz); + }else{ + Assert (Color_hd (q) == Caml_blue); + p += Whsize_hd (q); + } + } + ch = Chunk_next (ch); + } + } + + /* Shrink the heap if needed. */ + { + /* Find the amount of live data and the unshrinkable free space. */ + asize_t live = 0; + asize_t free = 0; + asize_t wanted; + + ch = heap_start; + while (ch != NULL){ + if (Chunk_alloc (ch) != 0){ + live += Wsize_bsize (Chunk_alloc (ch)); + free += Wsize_bsize (Chunk_size (ch) - Chunk_alloc (ch)); + } + ch = Chunk_next (ch); + } + + /* Add up the empty chunks until there are enough, then remove the + other empty chunks. */ + wanted = percent_free * (live / 100 + 1); + ch = heap_start; + while (ch != NULL){ + char *next_chunk = Chunk_next (ch); /* Chunk_next (ch) will be erased */ + + if (Chunk_alloc (ch) == 0){ + if (free < wanted){ + free += Wsize_bsize (Chunk_size (ch)); + }else{ + shrink_heap (ch); + } + } + ch = next_chunk; + } + } + + /* Rebuild the free list. */ + { + ch = heap_start; + fl_reset (); + while (ch != NULL){ + if (Chunk_size (ch) > Chunk_alloc (ch)){ + make_free_blocks ((value *) (ch + Chunk_alloc (ch)), + Wsize_bsize (Chunk_size (ch) - Chunk_alloc (ch)), 1); + } + ch = Chunk_next (ch); + } + } + ++ stat_compactions; + gc_message (0x10, "done.\n", 0); +} + +unsigned long percent_max; + +void compact_heap_maybe (void) +{ + /* Estimated free words in the heap: + FW = fl_size_at_change + 3 * (fl_cur_size - fl_size_at_change) + FW = 3 * fl_cur_size - 2 * fl_size_at_change + Estimated live words: LW = stat_heap_size - FW + Estimated free percentage: FP = 100 * FW / LW + We compact the heap if FP > percent_max + */ + float fw, fp; + Assert (gc_phase == Phase_idle); + if (percent_max >= 1000000) return; + if (stat_major_collections < 5 || stat_heap_chunks < 5) return; + + fw = 3.0 * fl_cur_size - 2.0 * fl_size_at_phase_change; + if (fw < 0) fw = fl_cur_size; + + if (fw >= Wsize_bsize (stat_heap_size)){ + fp = 1000000.0; + }else{ + fp = 100.0 * fw / (Wsize_bsize (stat_heap_size) - fw); + if (fp > 1000000.0) fp = 1000000.0; + } + gc_message (0x200, "FL size at phase change = %lu\n", + (unsigned long) fl_size_at_phase_change); + gc_message (0x200, "Estimated overhead = %lu%%\n", (unsigned long) fp); + if (fp >= percent_max){ + gc_message (0x200, "Automatic compaction triggered.\n", 0); + finish_major_cycle (); + + /* We just did a complete GC, so we can measure the overhead exactly. */ + fw = fl_cur_size; + fp = 100.0 * fw / (Wsize_bsize (stat_heap_size) - fw); + gc_message (0x200, "Measured overhead: %lu%%\n", (unsigned long) fp); + + compact_heap (); + } +} diff --git a/byterun/compact.h b/byterun/compact.h new file mode 100644 index 00000000..60a66e52 --- /dev/null +++ b/byterun/compact.h @@ -0,0 +1,27 @@ +/***********************************************************************/ +/* */ +/* Objective Caml */ +/* */ +/* Damien Doligez, projet Para, 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: compact.h,v 1.5 2001/12/07 13:39:23 xleroy Exp $ */ + +#ifndef _compact_ +#define _compact_ + + +#include "config.h" +#include "misc.h" + +extern void compact_heap (void); +extern void compact_heap_maybe (void); + + +#endif /* _compact_ */ diff --git a/byterun/compare.c b/byterun/compare.c new file mode 100644 index 00000000..b7fb30d5 --- /dev/null +++ b/byterun/compare.c @@ -0,0 +1,255 @@ +/***********************************************************************/ +/* */ +/* 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: compare.c,v 1.27 2003/07/16 17:28:00 doligez Exp $ */ + +#include +#include +#include "custom.h" +#include "fail.h" +#include "memory.h" +#include "misc.h" +#include "mlvalues.h" + +/* Structural comparison on trees. */ + +struct compare_item { value * v1, * v2; mlsize_t count; }; + +#define COMPARE_STACK_INIT_SIZE 256 +#define COMPARE_STACK_MAX_SIZE (1024*1024) + +static struct compare_item compare_stack_init[COMPARE_STACK_INIT_SIZE]; + +static struct compare_item * compare_stack = compare_stack_init; +static struct compare_item * compare_stack_limit = compare_stack_init + + COMPARE_STACK_INIT_SIZE; + +/* Free the compare stack if needed */ +static void compare_free_stack(void) +{ + if (compare_stack != compare_stack_init) { + stat_free(compare_stack); + /* Reinitialize the globals for next time around */ + compare_stack = compare_stack_init; + compare_stack_limit = compare_stack + COMPARE_STACK_INIT_SIZE; + } +} + +/* Same, then raise Out_of_memory */ +static void compare_stack_overflow(void) +{ + compare_free_stack(); + raise_out_of_memory(); +} + +/* Grow the compare stack */ +static struct compare_item * compare_resize_stack(struct compare_item * sp) +{ + asize_t newsize = 2 * (compare_stack_limit - compare_stack); + asize_t sp_offset = sp - compare_stack; + struct compare_item * newstack; + + if (newsize >= COMPARE_STACK_MAX_SIZE) compare_stack_overflow(); + if (compare_stack == compare_stack_init) { + newstack = malloc(sizeof(struct compare_item) * newsize); + if (newstack == NULL) compare_stack_overflow(); + memcpy(newstack, compare_stack_init, + sizeof(struct compare_item) * COMPARE_STACK_INIT_SIZE); + } else { + newstack = + realloc(compare_stack, sizeof(struct compare_item) * newsize); + if (newstack == NULL) compare_stack_overflow(); + } + compare_stack = newstack; + compare_stack_limit = newstack + newsize; + return newstack + sp_offset; +} + +/* Structural comparison */ + +static long compare_val(value v1, value v2) +{ + struct compare_item * sp; + tag_t t1, t2; + + sp = compare_stack; + while (1) { + if (v1 == v2) goto next_item; + if (Is_long(v1)) { + if (Is_long(v2)) + return Long_val(v1) - Long_val(v2); + if ((Is_atom(v2) || Is_young(v2) || Is_in_heap(v2)) && + Tag_val(v2) == Forward_tag) { + v2 = Forward_val(v2); + continue; + } + return -1; /* v1 long < v2 block */ + } + if (Is_long(v2)) { + if ((Is_atom(v1) || Is_young(v1) || Is_in_heap(v1)) && + Tag_val(v1) == Forward_tag) { + v1 = Forward_val(v1); + continue; + } + return 1; /* v1 block > v2 long */ + } + /* If one of the objects is outside the heap (but is not an atom), + use address comparison. Since both addresses are 2-aligned, + shift lsb off to avoid overflow in subtraction. */ + if ((!Is_atom(v1) && !Is_young(v1) && !Is_in_heap(v1)) || + (!Is_atom(v2) && !Is_young(v2) && !Is_in_heap(v2))) + return (v1 >> 1) - (v2 >> 1); + t1 = Tag_val(v1); + t2 = Tag_val(v2); + if (t1 == Forward_tag) { v1 = Forward_val (v1); continue; } + if (t2 == Forward_tag) { v2 = Forward_val (v2); continue; } + if (t1 != t2) return (long)t1 - (long)t2; + switch(t1) { + case String_tag: { + mlsize_t len1, len2, len; + unsigned char * p1, * p2; + len1 = string_length(v1); + len2 = string_length(v2); + for (len = (len1 <= len2 ? len1 : len2), + p1 = (unsigned char *) String_val(v1), + p2 = (unsigned char *) String_val(v2); + len > 0; + len--, p1++, p2++) + if (*p1 != *p2) return (long)*p1 - (long)*p2; + if (len1 != len2) return len1 - len2; + break; + } + case Double_tag: { + double d1 = Double_val(v1); + double d2 = Double_val(v2); + if (d1 < d2) return -1; + if (d1 > d2) return 1; + break; + } + case Double_array_tag: { + mlsize_t sz1 = Wosize_val(v1) / Double_wosize; + mlsize_t sz2 = Wosize_val(v2) / Double_wosize; + mlsize_t i; + if (sz1 != sz2) return sz1 - sz2; + for (i = 0; i < sz1; i++) { + double d1 = Double_field(v1, i); + double d2 = Double_field(v2, i); + if (d1 < d2) return -1; + if (d1 > d2) return 1; + } + break; + } + case Abstract_tag: + compare_free_stack(); + invalid_argument("equal: abstract value"); + case Closure_tag: + case Infix_tag: + compare_free_stack(); + invalid_argument("equal: functional value"); + case Object_tag: { + long oid1 = Oid_val(v1); + long oid2 = Oid_val(v2); + if (oid1 != oid2) return oid1 - oid2; + break; + } + case Custom_tag: { + int res; + int (*compare)(value v1, value v2) = Custom_ops_val(v1)->compare; + if (compare == NULL) invalid_argument("equal: abstract value"); + res = Custom_ops_val(v1)->compare(v1, v2); + if (res != 0) return res; + break; + } + default: { + mlsize_t sz1 = Wosize_val(v1); + mlsize_t sz2 = Wosize_val(v2); + /* Compare sizes first for speed */ + if (sz1 != sz2) return sz1 - sz2; + if (sz1 == 0) break; + /* Remember that we still have to compare fields 1 ... sz - 1 */ + if (sz1 > 1) { + sp++; + if (sp >= compare_stack_limit) sp = compare_resize_stack(sp); + sp->v1 = &Field(v1, 1); + sp->v2 = &Field(v2, 1); + sp->count = sz1 - 1; + } + /* Continue comparison with first field */ + v1 = Field(v1, 0); + v2 = Field(v2, 0); + continue; + } + } + next_item: + /* Pop one more item to compare, if any */ + if (sp == compare_stack) return 0; /* we're done */ + v1 = *(sp->v1)++; + v2 = *(sp->v2)++; + if (--(sp->count) == 0) sp--; + } +} + +CAMLprim value compare(value v1, value v2) +{ + long res = compare_val(v1, v2); + /* Free stack if needed */ + if (compare_stack != compare_stack_init) compare_free_stack(); + if (res < 0) + return Val_int(-1); + else if (res > 0) + return Val_int(1); + else + return Val_int(0); +} + +CAMLprim value equal(value v1, value v2) +{ + long res = compare_val(v1, v2); + if (compare_stack != compare_stack_init) compare_free_stack(); + return Val_int(res == 0); +} + +CAMLprim value notequal(value v1, value v2) +{ + long res = compare_val(v1, v2); + if (compare_stack != compare_stack_init) compare_free_stack(); + return Val_int(res != 0); +} + +CAMLprim value lessthan(value v1, value v2) +{ + long res = compare_val(v1, v2); + if (compare_stack != compare_stack_init) compare_free_stack(); + return Val_int(res < 0); +} + +CAMLprim value lessequal(value v1, value v2) +{ + long res = compare_val(v1, v2); + if (compare_stack != compare_stack_init) compare_free_stack(); + return Val_int(res <= 0); +} + +CAMLprim value greaterthan(value v1, value v2) +{ + long res = compare_val(v1, v2); + if (compare_stack != compare_stack_init) compare_free_stack(); + return Val_int(res > 0); +} + +CAMLprim value greaterequal(value v1, value v2) +{ + long res = compare_val(v1, v2); + if (compare_stack != compare_stack_init) compare_free_stack(); + return Val_int(res >= 0); +} diff --git a/byterun/config.h b/byterun/config.h new file mode 100644 index 00000000..1caa7ea1 --- /dev/null +++ b/byterun/config.h @@ -0,0 +1,146 @@ +/***********************************************************************/ +/* */ +/* 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: config.h,v 1.32 2002/12/15 23:27:06 doligez Exp $ */ + +#ifndef _config_ +#define _config_ + +/* */ +/* */ +/* */ +#if !macintosh +#include "../config/m.h" +#include "../config/s.h" +#else +#include +#include +#endif +/* */ + +/* Types for signed chars, 16-bit integers, 32-bit integers, 64-bit integers */ + +typedef signed char schar; + +typedef short int16; /* FIXME -- not true on the Cray T3E */ +typedef unsigned short uint16; /* FIXME -- not true on the Cray T3E */ + +#if SIZEOF_INT == 4 +typedef int int32; +typedef unsigned int uint32; +#elif SIZEOF_LONG == 4 +typedef long int32; +typedef unsigned long uint32; +#elif SIZEOF_SHORT == 4 +typedef short int32; +typedef unsigned short uint32; +#endif + +#if defined(ARCH_INT64_TYPE) +typedef ARCH_INT64_TYPE int64; +typedef ARCH_UINT64_TYPE uint64; +#else +# if ARCH_BIG_ENDIAN +typedef struct { uint32 h, l; } uint64, int64; +# else +typedef struct { uint32 l, h; } uint64, int64; +# endif +#endif + +/* Endianness of floats */ + +/* ARCH_FLOAT_ENDIANNESS encodes the byte order of doubles as follows: + the value [0xabcdefgh] means that the least significant byte of the + float is at byte offset [a], the next lsb at [b], ..., and the + most significant byte at [h]. */ + +#if defined(__arm__) +#define ARCH_FLOAT_ENDIANNESS 0x45670123 +#elif defined(ARCH_BIG_ENDIAN) +#define ARCH_FLOAT_ENDIANNESS 0x76543210 +#else +#define ARCH_FLOAT_ENDIANNESS 0x01234567 +#endif + +/* We use threaded code interpretation if the compiler provides labels + as first-class values (GCC 2.x). */ + +#if defined(__GNUC__) && __GNUC__ >= 2 && !defined(DEBUG) && !defined (SHRINKED_GNUC) +#define THREADED_CODE +#endif + + +/* Do not change this definition. */ +#define Page_size (1 << Page_log) + +/* Memory model parameters */ + +/* The size of a page for memory management (in bytes) is [1 << Page_log]. + It must be a multiple of [sizeof (long)]. */ +#define Page_log 12 /* A page is 4 kilobytes. */ + +/* Initial size of stack (bytes). */ +#define Stack_size (4096 * sizeof(value)) + +/* Minimum free size of stack (bytes); below that, it is reallocated. */ +#define Stack_threshold (256 * sizeof(value)) + +/* Default maximum size of the stack (words). */ +#define Max_stack_def (256 * 1024) + + +/* Maximum size of a block allocated in the young generation (words). */ +/* Must be > 4 */ +#define Max_young_wosize 256 + + +/* Minimum size of the minor zone (words). + This must be at least [Max_young_wosize + 1]. */ +#define Minor_heap_min 4096 + +/* Maximum size of the minor zone (words). + Must be greater than or equal to [Minor_heap_min]. +*/ +#define Minor_heap_max (1 << 28) + +/* Default size of the minor zone. (words) */ +#define Minor_heap_def 32768 + + +/* Minimum size increment when growing the heap (words). + Must be a multiple of [Page_size / sizeof (value)]. */ +#define Heap_chunk_min (2 * Page_size / sizeof (value)) + +/* Default size increment when growing the heap. (words) + Must be a multiple of [Page_size / sizeof (value)]. */ +#define Heap_chunk_def (15 * Page_size) + +/* Default initial size of the major heap (words); + same constraints as for Heap_chunk_def. */ +#define Init_heap_def (15 * Page_size) + + +/* Default speed setting for the major GC. The heap will grow until + the dead objects and the free list represent this percentage of the + total size of live objects. */ +#define Percent_free_def 80 + +/* Default setting for the compacter: 500% + (i.e. trigger the compacter when 5/6 of the heap is free or garbage) + This can be set quite high because the overhead is over-estimated + when fragmentation occurs. + */ +#define Max_percent_free_def 500 + + +#endif /* _config_ */ diff --git a/byterun/custom.c b/byterun/custom.c new file mode 100644 index 00000000..135e6684 --- /dev/null +++ b/byterun/custom.c @@ -0,0 +1,100 @@ +/***********************************************************************/ +/* */ +/* Objective Caml */ +/* */ +/* Manuel Serrano and Xavier Leroy, 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: custom.c,v 1.10 2002/06/07 09:49:36 xleroy Exp $ */ + +#include + +#include "alloc.h" +#include "custom.h" +#include "fail.h" +#include "memory.h" +#include "mlvalues.h" + +CAMLextern value alloc_custom(struct custom_operations * ops, + unsigned long size, + mlsize_t mem, + mlsize_t max) +{ + mlsize_t wosize; + value result; + + wosize = 1 + (size + sizeof(value) - 1) / sizeof(value); + if (ops->finalize == NULL && wosize <= Max_young_wosize) { + result = alloc_small(wosize, Custom_tag); + Custom_ops_val(result) = ops; + } else { + result = alloc_shr(wosize, Custom_tag); + Custom_ops_val(result) = ops; + adjust_gc_speed(mem, max); + result = check_urgent_gc(result); + } + return result; +} + +struct custom_operations_list { + struct custom_operations * ops; + struct custom_operations_list * next; +}; + +static struct custom_operations_list * custom_ops_table = NULL; + +CAMLextern void register_custom_operations(struct custom_operations * ops) +{ + struct custom_operations_list * l = + stat_alloc(sizeof(struct custom_operations_list)); + Assert(ops->identifier != NULL); + Assert(ops->deserialize != NULL); + l->ops = ops; + l->next = custom_ops_table; + custom_ops_table = l; +} + +struct custom_operations * find_custom_operations(char * ident) +{ + struct custom_operations_list * l; + for (l = custom_ops_table; l != NULL; l = l->next) + if (strcmp(l->ops->identifier, ident) == 0) return l->ops; + return NULL; +} + +static struct custom_operations_list * custom_ops_final_table = NULL; + +struct custom_operations * final_custom_operations(final_fun fn) +{ + struct custom_operations_list * l; + struct custom_operations * ops; + for (l = custom_ops_final_table; l != NULL; l = l->next) + if (l->ops->finalize == fn) return l->ops; + ops = stat_alloc(sizeof(struct custom_operations)); + ops->identifier = "_final"; + ops->finalize = fn; + ops->compare = custom_compare_default; + ops->hash = custom_hash_default; + ops->serialize = custom_serialize_default; + ops->deserialize = custom_deserialize_default; + l = stat_alloc(sizeof(struct custom_operations_list)); + l->ops = ops; + l->next = custom_ops_final_table; + custom_ops_final_table = l; + return ops; +} + +extern struct custom_operations int32_ops, nativeint_ops, int64_ops; + +void init_custom_operations(void) +{ + register_custom_operations(&int32_ops); + register_custom_operations(&nativeint_ops); + register_custom_operations(&int64_ops); +} diff --git a/byterun/custom.h b/byterun/custom.h new file mode 100644 index 00000000..83267cc9 --- /dev/null +++ b/byterun/custom.h @@ -0,0 +1,55 @@ +/***********************************************************************/ +/* */ +/* Objective Caml */ +/* */ +/* Manuel Serrano and Xavier Leroy, 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: custom.h,v 1.8 2002/06/07 09:49:37 xleroy Exp $ */ + +#ifndef _custom_ +#define _custom_ + + +#include "mlvalues.h" + +struct custom_operations { + char *identifier; + void (*finalize)(value v); + int (*compare)(value v1, value v2); + long (*hash)(value v); + void (*serialize)(value v, + /*out*/ unsigned long * wsize_32 /*size in bytes*/, + /*out*/ unsigned long * wsize_64 /*size in bytes*/); + unsigned long (*deserialize)(void * dst); +}; + +#define custom_finalize_default NULL +#define custom_compare_default NULL +#define custom_hash_default NULL +#define custom_serialize_default NULL +#define custom_deserialize_default NULL + +#define Custom_ops_val(v) (*((struct custom_operations **) (v))) + +CAMLextern value alloc_custom(struct custom_operations * ops, + unsigned long size, /*size in bytes*/ + mlsize_t mem, /*resources consumed*/ + mlsize_t max /*max resources*/); + +CAMLextern void register_custom_operations(struct custom_operations * ops); + +/* */ +extern struct custom_operations * find_custom_operations(char * ident); +extern struct custom_operations * final_custom_operations(void (*fn)(value)); + +extern void init_custom_operations(void); +/* */ + +#endif diff --git a/byterun/debugger.c b/byterun/debugger.c new file mode 100644 index 00000000..15a2ba9d --- /dev/null +++ b/byterun/debugger.c @@ -0,0 +1,338 @@ +/***********************************************************************/ +/* */ +/* 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: debugger.c,v 1.24 2002/10/22 12:30:03 doligez Exp $ */ + +/* Interface with the debugger */ + +#include + +#include "config.h" +#include "debugger.h" +#include "fail.h" +#include "fix_code.h" +#include "instruct.h" +#include "intext.h" +#include "io.h" +#include "misc.h" +#include "mlvalues.h" +#include "stacks.h" +#include "sys.h" + +int debugger_in_use = 0; +unsigned long event_count; + +#if !defined(HAS_SOCKETS) || defined(_WIN32) + +void debugger_init(void) +{ +} + +void debugger(enum event_kind event) +{ +} + +#else + +#ifdef HAS_UNISTD +#include +#endif +#include +#include +#include +#include +#include +#include +#include + +static int sock_domain; /* Socket domain for the debugger */ +static union { /* Socket address for the debugger */ + struct sockaddr s_gen; + struct sockaddr_un s_unix; + struct sockaddr_in s_inet; +} sock_addr; +static int sock_addr_len; /* Length of sock_addr */ + +static int dbg_socket = -1; /* The socket connected to the debugger */ +static struct channel * dbg_in; /* Input channel on the socket */ +static struct channel * dbg_out;/* Output channel on the socket */ + +static void open_connection(void) +{ + dbg_socket = socket(sock_domain, SOCK_STREAM, 0); + if (dbg_socket == -1 || + connect(dbg_socket, &sock_addr.s_gen, sock_addr_len) == -1) + fatal_error("cannot connect to debugger"); + dbg_in = open_descriptor_in(dbg_socket); + dbg_out = open_descriptor_out(dbg_socket); + if (!debugger_in_use) putword(dbg_out, -1); /* first connection */ + putword(dbg_out, getpid()); + flush(dbg_out); +} + +static void close_connection(void) +{ + close_channel(dbg_in); + close_channel(dbg_out); + dbg_socket = -1; /* was closed by close_channel */ +} + +void debugger_init(void) +{ + char * address; + char * port, * p; + struct hostent * host; + int n; + + address = getenv("CAML_DEBUG_SOCKET"); + if (address == NULL) return; + + /* Parse the address */ + port = NULL; + for (p = address; *p != 0; p++) { + if (*p == ':') { *p = 0; port = p+1; break; } + } + if (port == NULL) { + /* Unix domain */ + sock_domain = PF_UNIX; + sock_addr.s_unix.sun_family = AF_UNIX; + strncpy(sock_addr.s_unix.sun_path, address, + sizeof(sock_addr.s_unix.sun_path)); + sock_addr_len = + ((char *)&(sock_addr.s_unix.sun_path) - (char *)&(sock_addr.s_unix)) + + strlen(address); + } else { + /* Internet domain */ + sock_domain = PF_INET; + for (p = (char *) &sock_addr.s_inet, n = sizeof(sock_addr.s_inet); + n > 0; n--) *p++ = 0; + sock_addr.s_inet.sin_family = AF_INET; + sock_addr.s_inet.sin_addr.s_addr = inet_addr(address); + if (sock_addr.s_inet.sin_addr.s_addr == -1) { + host = gethostbyname(address); + if (host == NULL) + fatal_error_arg("Unknown debugging host %s\n", address); + memmove(&sock_addr.s_inet.sin_addr, host->h_addr, host->h_length); + } + sock_addr.s_inet.sin_port = htons(atoi(port)); + sock_addr_len = sizeof(sock_addr.s_inet); + } + open_connection(); + debugger_in_use = 1; + trap_barrier = stack_high; +} + +static value getval(struct channel *chan) +{ + value res; + if (really_getblock(chan, (char *) &res, sizeof(res)) == 0) + raise_end_of_file(); /* Bad, but consistent with getword */ + return res; +} + +static void putval(struct channel *chan, value val) +{ + really_putblock(chan, (char *) &val, sizeof(val)); +} + +static void safe_output_value(struct channel *chan, value val) +{ + struct longjmp_buffer raise_buf, * saved_external_raise; + + /* Catch exceptions raised by output_val */ + saved_external_raise = external_raise; + if (sigsetjmp(raise_buf.buf, 0) == 0) { + external_raise = &raise_buf; + output_val(chan, val, Val_unit); + } else { + /* Send wrong magic number, will cause input_value to fail */ + really_putblock(chan, "\000\000\000\000", 4); + } + external_raise = saved_external_raise; +} + +#define Pc(sp) ((code_t)((sp)[0])) +#define Env(sp) ((sp)[1]) +#define Extra_args(sp) (Long_val(((sp)[2]))) +#define Locals(sp) ((sp) + 3) + +void debugger(enum event_kind event) +{ + int frame_number; + value * frame; + long i, pos; + value val; + + if (dbg_socket == -1) return; /* Not connected to a debugger. */ + + /* Reset current frame */ + frame_number = 0; + frame = extern_sp + 1; + + /* Report the event to the debugger */ + switch(event) { + case PROGRAM_START: /* Nothing to report */ + goto command_loop; + case EVENT_COUNT: + putch(dbg_out, REP_EVENT); + break; + case BREAKPOINT: + putch(dbg_out, REP_BREAKPOINT); + break; + case PROGRAM_EXIT: + putch(dbg_out, REP_EXITED); + break; + case TRAP_BARRIER: + putch(dbg_out, REP_TRAP); + break; + case UNCAUGHT_EXC: + putch(dbg_out, REP_UNCAUGHT_EXC); + break; + } + putword(dbg_out, event_count); + if (event == EVENT_COUNT || event == BREAKPOINT) { + putword(dbg_out, stack_high - frame); + putword(dbg_out, (Pc(frame) - start_code) * sizeof(opcode_t)); + } else { + /* No PC and no stack frame associated with other events */ + putword(dbg_out, 0); + putword(dbg_out, 0); + } + flush(dbg_out); + + command_loop: + + /* Read and execute the commands sent by the debugger */ + while(1) { + switch(getch(dbg_in)) { + case REQ_SET_EVENT: + pos = getword(dbg_in); + Assert (pos >= 0); + Assert (pos < code_size); + set_instruction(start_code + pos / sizeof(opcode_t), EVENT); + break; + case REQ_SET_BREAKPOINT: + pos = getword(dbg_in); + Assert (pos >= 0); + Assert (pos < code_size); + set_instruction(start_code + pos / sizeof(opcode_t), BREAK); + break; + case REQ_RESET_INSTR: + pos = getword(dbg_in); + Assert (pos >= 0); + Assert (pos < code_size); + pos = pos / sizeof(opcode_t); + set_instruction(start_code + pos, saved_code[pos]); + break; + case REQ_CHECKPOINT: + i = fork(); + if (i == 0) { + close_connection(); /* Close parent connection. */ + open_connection(); /* Open new connection with debugger */ + } else { + putword(dbg_out, i); + flush(dbg_out); + } + break; + case REQ_GO: + event_count = getword(dbg_in); + return; + case REQ_STOP: + exit(0); + break; + case REQ_WAIT: + wait(NULL); + break; + case REQ_INITIAL_FRAME: + frame = extern_sp + 1; + /* Fall through */ + case REQ_GET_FRAME: + putword(dbg_out, stack_high - frame); + if (frame < stack_high){ + putword(dbg_out, (Pc(frame) - start_code) * sizeof(opcode_t)); + }else{ + putword (dbg_out, 0); + } + flush(dbg_out); + break; + case REQ_SET_FRAME: + i = getword(dbg_in); + frame = stack_high - i; + break; + case REQ_UP_FRAME: + i = getword(dbg_in); + if (frame + Extra_args(frame) + i + 3 >= stack_high) { + putword(dbg_out, -1); + } else { + frame += Extra_args(frame) + i + 3; + putword(dbg_out, stack_high - frame); + putword(dbg_out, (Pc(frame) - start_code) * sizeof(opcode_t)); + } + flush(dbg_out); + break; + case REQ_SET_TRAP_BARRIER: + i = getword(dbg_in); + trap_barrier = stack_high - i; + break; + case REQ_GET_LOCAL: + i = getword(dbg_in); + putval(dbg_out, Locals(frame)[i]); + flush(dbg_out); + break; + case REQ_GET_ENVIRONMENT: + i = getword(dbg_in); + putval(dbg_out, Field(Env(frame), i)); + flush(dbg_out); + break; + case REQ_GET_GLOBAL: + i = getword(dbg_in); + putval(dbg_out, Field(global_data, i)); + flush(dbg_out); + break; + case REQ_GET_ACCU: + putval(dbg_out, *extern_sp); + flush(dbg_out); + break; + case REQ_GET_HEADER: + val = getval(dbg_in); + putword(dbg_out, Hd_val(val)); + flush(dbg_out); + break; + case REQ_GET_FIELD: + val = getval(dbg_in); + i = getword(dbg_in); + if (Tag_val(val) != Double_array_tag) { + putch(dbg_out, 0); + putval(dbg_out, Field(val, i)); + } else { + double d = Double_field(val, i); + putch(dbg_out, 1); + really_putblock(dbg_out, (char *) &d, 8); + } + flush(dbg_out); + break; + case REQ_MARSHAL_OBJ: + val = getval(dbg_in); + safe_output_value(dbg_out, val); + flush(dbg_out); + break; + case REQ_GET_CLOSURE_CODE: + val = getval(dbg_in); + putword(dbg_out, (Code_val(val) - start_code) * sizeof(opcode_t)); + flush(dbg_out); + break; + } + } +} + +#endif diff --git a/byterun/debugger.h b/byterun/debugger.h new file mode 100644 index 00000000..754fd1f5 --- /dev/null +++ b/byterun/debugger.h @@ -0,0 +1,112 @@ +/***********************************************************************/ +/* */ +/* 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: debugger.h,v 1.7 2001/12/07 13:39:24 xleroy Exp $ */ + +/* Interface with the debugger */ + +#ifndef _debugger_ +#define _debugger_ + +#include "misc.h" +#include "mlvalues.h" + +extern int debugger_in_use; +extern int running; +extern unsigned long event_count; + +enum event_kind { + EVENT_COUNT, BREAKPOINT, PROGRAM_START, PROGRAM_EXIT, + TRAP_BARRIER, UNCAUGHT_EXC +}; + +void debugger_init (void); +void debugger (enum event_kind event); + +/* Communication protocol */ + +/* Requests from the debugger to the runtime system */ + +enum debugger_request { + REQ_SET_EVENT = 'e', /* uint32 pos */ + /* Set an event on the instruction at position pos */ + REQ_SET_BREAKPOINT = 'B', /* uint32 pos, (char k) */ + /* Set a breakpoint at position pos */ + /* In profiling mode, the breakpoint kind is set to k */ + REQ_RESET_INSTR = 'i', /* uint32 pos */ + /* Clear an event or breapoint at position pos, restores initial instr. */ + REQ_CHECKPOINT = 'c', /* no args */ + /* Checkpoint the runtime system by forking a child process. + Reply is pid of child process or -1 if checkpoint failed. */ + REQ_GO = 'g', /* uint32 n */ + /* Run the program for n events. + Reply is one of debugger_reply described below. */ + REQ_STOP = 's', /* no args */ + /* Terminate the runtime system */ + REQ_WAIT = 'w', /* no args */ + /* Reap one dead child (a discarded checkpoint). */ + REQ_INITIAL_FRAME = '0', /* no args */ + /* Set current frame to bottom frame (the one currently executing). + Reply is stack offset and current pc. */ + REQ_GET_FRAME = 'f', /* no args */ + /* Return current frame location (stack offset + current pc). */ + REQ_SET_FRAME = 'S', /* uint32 stack_offset */ + /* Set current frame to given stack offset. No reply. */ + REQ_UP_FRAME = 'U', /* uint32 n */ + /* Move one frame up. Argument n is size of current frame (in words). + Reply is stack offset and current pc, or -1 if top of stack reached. */ + REQ_SET_TRAP_BARRIER = 'b', /* uint32 offset */ + /* Set the trap barrier at the given offset. */ + REQ_GET_LOCAL = 'L', /* uint32 slot_number */ + /* Return the local variable at the given slot in the current frame. + Reply is one value. */ + REQ_GET_ENVIRONMENT = 'E', /* uint32 slot_number */ + /* Return the local variable at the given slot in the heap environment + of the current frame. Reply is one value. */ + REQ_GET_GLOBAL = 'G', /* uint32 global_number */ + /* Return the specified global variable. Reply is one value. */ + REQ_GET_ACCU = 'A', /* no args */ + /* Return the current contents of the accumulator. Reply is one value. */ + REQ_GET_HEADER = 'H', /* mlvalue v */ + /* As REQ_GET_OBJ, but sends only the header. */ + REQ_GET_FIELD = 'F', /* mlvalue v, uint32 fieldnum */ + /* As REQ_GET_OBJ, but sends only one field. */ + REQ_MARSHAL_OBJ = 'M', /* mlvalue v */ + /* Send a copy of the data structure rooted at v, using the same + format as output_value. */ + REQ_GET_CLOSURE_CODE = 'C' /* mlvalue v */ + /* Send the code address of the given closure. + Reply is one uint32. */ +}; + +/* Replies to a REQ_GO request. All replies are followed by three uint32: + - the value of the event counter + - the position of the stack + - the current pc. */ + +enum debugger_reply { + REP_EVENT = 'e', + /* Event counter reached 0. */ + REP_BREAKPOINT = 'b', + /* Breakpoint hit. */ + REP_EXITED = 'x', + /* Program exited by calling exit or reaching the end of the source. */ + REP_TRAP = 's', + /* Trap barrier crossed. */ + REP_UNCAUGHT_EXC = 'u' + /* Program exited due to a stray exception. */ +}; + +#endif + + diff --git a/byterun/dynlink.c b/byterun/dynlink.c new file mode 100644 index 00000000..f85f4252 --- /dev/null +++ b/byterun/dynlink.c @@ -0,0 +1,251 @@ +/***********************************************************************/ +/* */ +/* 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$ */ + +/* Dynamic loading of C primitives. */ + +#include +#include +#include +#include +#include +#include "config.h" +#ifdef HAS_UNISTD +#include +#endif +#include "alloc.h" +#include "dynlink.h" +#include "fail.h" +#include "mlvalues.h" +#include "memory.h" +#include "misc.h" +#include "osdeps.h" +#include "prims.h" + +#ifndef NATIVE_CODE + +/* The table of primitives */ +struct ext_table prim_table; + +#ifdef DEBUG +/* The names of primitives (for instrtrace.c) */ +struct ext_table prim_name_table; +#endif + +/* The table of shared libraries currently opened */ +static struct ext_table shared_libs; + +/* The search path for shared libraries */ +struct ext_table shared_libs_path; + +/* Look up the given primitive name in the built-in primitive table, + then in the opened shared libraries (shared_libs) */ +static c_primitive lookup_primitive(char * name) +{ + int i; + void * res; + + for (i = 0; names_of_builtin_cprim[i] != NULL; i++) { + if (strcmp(name, names_of_builtin_cprim[i]) == 0) + return builtin_cprim[i]; + } + for (i = 0; i < shared_libs.size; i++) { + res = caml_dlsym(shared_libs.contents[i], name); + if (res != NULL) return (c_primitive) res; + } + return NULL; +} + +/* Parse the OCAML_STDLIB_DIR/ld.conf file and add the directories + listed there to the search path */ + +#define LD_CONF_NAME "ld.conf" + +static char * parse_ld_conf(void) +{ + char * stdlib, * ldconfname, * config, * p, * q; + struct stat st; + int ldconf, nread; + + stdlib = getenv("OCAMLLIB"); + if (stdlib == NULL) stdlib = getenv("CAMLLIB"); + if (stdlib == NULL) stdlib = OCAML_STDLIB_DIR; + ldconfname = stat_alloc(strlen(stdlib) + 2 + sizeof(LD_CONF_NAME)); + strcpy(ldconfname, stdlib); + strcat(ldconfname, "/" LD_CONF_NAME); + if (stat(ldconfname, &st) == -1) { + stat_free(ldconfname); + return NULL; + } + ldconf = open(ldconfname, O_RDONLY, 0); + if (ldconf == -1) + fatal_error_arg("Fatal error: cannot read loader config file %s\n", + ldconfname); + config = stat_alloc(st.st_size + 1); + nread = read(ldconf, config, st.st_size); + if (nread == -1) + fatal_error_arg("Fatal error: error while reading loader config file %s\n", + ldconfname); + config[nread] = 0; + q = config; + for (p = config; *p != 0; p++) { + if (*p == '\n') { + *p = 0; + ext_table_add(&shared_libs_path, q); + q = p + 1; + } + } + if (q < p) ext_table_add(&shared_libs_path, q); + close(ldconf); + stat_free(ldconfname); + return config; +} + +/* Open the given shared library and add it to shared_libs. + Abort on error. */ +static void open_shared_lib(char * name) +{ + char * realname; + void * handle; + + realname = search_dll_in_path(&shared_libs_path, name); + gc_message(0x100, "Loading shared library %s\n", (unsigned long) realname); + handle = caml_dlopen(realname); + if (handle == NULL) + fatal_error_arg2("Fatal error: cannot load shared library %s\n", name, + "Reason: %s\n", caml_dlerror()); + ext_table_add(&shared_libs, handle); + stat_free(realname); +} + +/* Build the table of primitives, given a search path and a list + of shared libraries (both 0-separated in a char array). + Abort the runtime system on error. */ +void build_primitive_table(char * lib_path, + char * libs, + char * req_prims) +{ + char * tofree1, * tofree2; + char * p; + + /* Initialize the search path for dynamic libraries: + - directories specified on the command line with the -I option + - directories specified in the CAML_LD_LIBRARY_PATH + - directories specified in the executable + - directories specified in the file /ld.conf */ + tofree1 = decompose_path(&shared_libs_path, getenv("CAML_LD_LIBRARY_PATH")); + if (lib_path != NULL) + for (p = lib_path; *p != 0; p += strlen(p) + 1) + ext_table_add(&shared_libs_path, p); + tofree2 = parse_ld_conf(); + /* Open the shared libraries */ + ext_table_init(&shared_libs, 8); + if (libs != NULL) + for (p = libs; *p != 0; p += strlen(p) + 1) + open_shared_lib(p); + /* Build the primitive table */ + ext_table_init(&prim_table, 0x180); +#ifdef DEBUG + ext_table_init(&prim_name_table, 0x180); +#endif + for (p = req_prims; *p != 0; p += strlen(p) + 1) { + c_primitive prim = lookup_primitive(p); + if (prim == NULL) + fatal_error_arg("Fatal error: unknown C primitive `%s'\n", p); + ext_table_add(&prim_table, (void *) prim); +#ifdef DEBUG + ext_table_add(&prim_name_table, strdup(p)); +#endif + } + /* Clean up */ + stat_free(tofree1); + stat_free(tofree2); + ext_table_free(&shared_libs_path, 0); +} + +#endif + +/** dlopen interface for the bytecode linker **/ + +#define Handle_val(v) (*((void **) (v))) + +CAMLprim value dynlink_open_lib(value filename) +{ + void * handle; + value result; + + handle = caml_dlopen(String_val(filename)); + if (handle == NULL) failwith(caml_dlerror()); + result = alloc_small(1, Abstract_tag); + Handle_val(result) = handle; + return result; +} + +CAMLprim value dynlink_close_lib(value handle) +{ + caml_dlclose(Handle_val(handle)); + return Val_unit; +} + +#include +CAMLprim value dynlink_lookup_symbol(value handle, value symbolname) +{ + void * symb; + value result; + symb = caml_dlsym(Handle_val(handle), String_val(symbolname)); + /* printf("%s = 0x%lx\n", String_val(symbolname), symb); + fflush(stdout); */ + if (symb == NULL) return Val_unit /*failwith(caml_dlerror())*/; + result = alloc_small(1, Abstract_tag); + Handle_val(result) = symb; + return result; +} + +#ifndef NATIVE_CODE + +CAMLprim value dynlink_add_primitive(value handle) +{ + return Val_int(ext_table_add(&prim_table, Handle_val(handle))); +} + +CAMLprim value dynlink_get_current_libs(value unit) +{ + CAMLparam0(); + CAMLlocal1(res); + int i; + + res = alloc_tuple(shared_libs.size); + for (i = 0; i < shared_libs.size; i++) { + value v = alloc_small(1, Abstract_tag); + Handle_val(v) = shared_libs.contents[i]; + Store_field(res, i, v); + } + CAMLreturn(res); +} + +#else + +value dynlink_add_primitive(value handle) +{ + invalid_argument("dynlink_add_primitive"); + return Val_unit; /* not reached */ +} + +value dynlink_get_current_libs(value unit) +{ + invalid_argument("dynlink_get_current_libs"); + return Val_unit; /* not reached */ +} + +#endif diff --git a/byterun/dynlink.h b/byterun/dynlink.h new file mode 100644 index 00000000..df0ce7df --- /dev/null +++ b/byterun/dynlink.h @@ -0,0 +1,34 @@ +/***********************************************************************/ +/* */ +/* 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$ */ + +/* Dynamic loading of C primitives. */ + +#ifndef _dynlink_ +#define _dynlink_ + +#include "misc.h" + +/* Build the table of primitives, given a search path, a list + of shared libraries, and a list of primitive names + (all three 0-separated in char arrays). + Abort the runtime system on error. */ +extern void build_primitive_table(char * lib_path, + char * libs, + char * req_prims); + +/* The search path for shared libraries */ +extern struct ext_table shared_libs_path; + +#endif diff --git a/byterun/exec.h b/byterun/exec.h new file mode 100644 index 00000000..d2b4a93e --- /dev/null +++ b/byterun/exec.h @@ -0,0 +1,62 @@ +/***********************************************************************/ +/* */ +/* 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: exec.h,v 1.12 2001/12/07 13:39:26 xleroy Exp $ */ + +/* exec.h : format of executable bytecode files */ + +#ifndef _exec_ +#define _exec_ + +/* Executable bytecode files are composed of a number of sections, + identified by 4-character names. A table of contents at the + end of the file lists the section names along with their sizes, + in the order in which they appear in the file: + + offset 0 ---> initial junk + data for section 1 + data for section 2 + ... + data for section N + table of contents: + descriptor for section 1 + ... + descriptor for section N + trailer + end of file ---> +*/ + +/* Structure of t.o.c. entries + Numerical quantities are 32-bit unsigned integers, big endian */ + +struct section_descriptor { + char name[4]; /* Section name */ + uint32 len; /* Length of data in bytes */ +}; + +/* Structure of the trailer. */ + +struct exec_trailer { + uint32 num_sections; /* Number of sections */ + char magic[12]; /* The magic number */ + struct section_descriptor * section; /* Not part of file */ +}; + +#define TRAILER_SIZE (4+12) + +/* Magic number for this release */ + +#define EXEC_MAGIC "Caml1999X007" + + +#endif diff --git a/byterun/extern.c b/byterun/extern.c new file mode 100644 index 00000000..bc0a72c5 --- /dev/null +++ b/byterun/extern.c @@ -0,0 +1,623 @@ +/***********************************************************************/ +/* */ +/* 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: extern.c,v 1.45 2003/06/19 13:05:17 xleroy Exp $ */ + +/* Structured output */ + +#include +#include "alloc.h" +#include "custom.h" +#include "fail.h" +#include "gc.h" +#include "intext.h" +#include "io.h" +#include "memory.h" +#include "misc.h" +#include "mlvalues.h" +#include "reverse.h" + +/* To keep track of sharing in externed objects */ + +typedef unsigned long byteoffset_t; + +struct extern_obj { + byteoffset_t ofs; + value obj; +}; + +static byteoffset_t initial_ofs = 1; /* Initial value of object offsets */ +static byteoffset_t obj_counter; /* Number of objects emitted so far */ +static struct extern_obj * extern_table = NULL; /* Table of objects seen */ +static unsigned long extern_table_size; +static unsigned long extern_table_mask; +static unsigned int extern_hash_shift; +/* extern_table_size, extern_table_mask and extern_hash_shift are such that + extern_table_size == 1 << (wordsize - extern_hash_shift) + extern_table_mask == extern_table_size - 1 */ + +/* Multiplicative Fibonacci hashing (Knuth vol 3, section 6.4, page 518). + HASH_FACTOR is (sqrt(5) - 1) / 2 * 2^wordsize. */ +#ifdef ARCH_SIXTYFOUR +#define HASH_FACTOR 11400714819323198485UL +#else +#define HASH_FACTOR 2654435769UL +#endif +#define Hash(v) (((unsigned long)(v) * HASH_FACTOR) >> extern_hash_shift) + +/* Allocate a new extern table */ +static void alloc_extern_table(void) +{ + asize_t i; + extern_table = (struct extern_obj *) + stat_alloc(extern_table_size * sizeof(struct extern_obj)); + for (i = 0; i < extern_table_size; i++) extern_table[i].ofs = 0; +} + +/* Grow the extern table */ +static void resize_extern_table(void) +{ + asize_t oldsize; + struct extern_obj * oldtable; + value obj; + byteoffset_t ofs; + asize_t i, h; + + oldsize = extern_table_size; + oldtable = extern_table; + extern_hash_shift = extern_hash_shift - 1; + extern_table_size = 2 * extern_table_size; + extern_table_mask = extern_table_size - 1; + alloc_extern_table(); + for (i = 0; i < oldsize; i++) { + ofs = oldtable[i].ofs; + if (ofs >= initial_ofs) { + obj = oldtable[i].obj; + h = Hash(obj); + while (extern_table[h].ofs > 0) h = (h + 1) & extern_table_mask; + extern_table[h].ofs = ofs; + extern_table[h].obj = obj; + } + } + stat_free(oldtable); +} + +/* Free the extern table. We keep it around for next call if + it's still small (we did not grow it) and the initial offset + does not risk overflowing next time. */ +static void free_extern_table(void) +{ + if (extern_table_size > INITIAL_EXTERN_TABLE_SIZE || + initial_ofs >= INITIAL_OFFSET_MAX) { + stat_free(extern_table); + extern_table = NULL; + } +} + +/* To buffer the output */ + +static char * extern_block, * extern_ptr, * extern_limit; +static int extern_block_malloced; + +static void alloc_extern_block(void) +{ + extern_block = stat_alloc(INITIAL_EXTERN_BLOCK_SIZE); + extern_limit = extern_block + INITIAL_EXTERN_BLOCK_SIZE; + extern_ptr = extern_block; + extern_block_malloced = 1; +} + +static void resize_extern_block(int required) +{ + long curr_pos, size, reqd_size; + + if (! extern_block_malloced) { + initial_ofs += obj_counter; + free_extern_table(); + failwith("Marshal.to_buffer: buffer overflow"); + } + curr_pos = extern_ptr - extern_block; + size = extern_limit - extern_block; + reqd_size = curr_pos + required; + while (size <= reqd_size) size *= 2; + extern_block = stat_resize(extern_block, size); + extern_limit = extern_block + size; + extern_ptr = extern_block + curr_pos; +} + +/* Write characters, integers, and blocks in the output buffer */ + +#define Write(c) \ + if (extern_ptr >= extern_limit) resize_extern_block(1); \ + *extern_ptr++ = (c) + +static void writeblock(char *data, long int len) +{ + if (extern_ptr + len > extern_limit) resize_extern_block(len); + memmove(extern_ptr, data, len); + extern_ptr += len; +} + +#if ARCH_FLOAT_ENDIANNESS == 0x01234567 || ARCH_FLOAT_ENDIANNESS == 0x76543210 +#define writeblock_float8(data,ndoubles) \ + writeblock((char *)(data), (ndoubles) * 8) +#else +#define writeblock_float8(data,ndoubles) \ + serialize_block_float_8((data), (ndoubles)) +#endif + +static void writecode8(int code, long int val) +{ + if (extern_ptr + 2 > extern_limit) resize_extern_block(2); + extern_ptr[0] = code; + extern_ptr[1] = val; + extern_ptr += 2; +} + +static void writecode16(int code, long int val) +{ + if (extern_ptr + 3 > extern_limit) resize_extern_block(3); + extern_ptr[0] = code; + extern_ptr[1] = val >> 8; + extern_ptr[2] = val; + extern_ptr += 3; +} + +static void write32(long int val) +{ + if (extern_ptr + 4 > extern_limit) resize_extern_block(4); + extern_ptr[0] = val >> 24; + extern_ptr[1] = val >> 16; + extern_ptr[2] = val >> 8; + extern_ptr[3] = val; + extern_ptr += 4; +} + +static void writecode32(int code, long int val) +{ + if (extern_ptr + 5 > extern_limit) resize_extern_block(5); + extern_ptr[0] = code; + extern_ptr[1] = val >> 24; + extern_ptr[2] = val >> 16; + extern_ptr[3] = val >> 8; + extern_ptr[4] = val; + extern_ptr += 5; +} + +#ifdef ARCH_SIXTYFOUR +static void writecode64(int code, long val) +{ + int i; + if (extern_ptr + 9 > extern_limit) resize_extern_block(9); + *extern_ptr ++ = code; + for (i = 64 - 8; i >= 0; i -= 8) *extern_ptr++ = val >> i; +} +#endif + +/* Marshal the given value in the output buffer */ + +static unsigned long size_32; /* Size in words of 32-bit block for struct. */ +static unsigned long size_64; /* Size in words of 64-bit block for struct. */ + +static int extern_ignore_sharing; /* Flag to ignore sharing */ +static int extern_closures; /* Flag to allow externing code pointers */ + +static void extern_invalid_argument(char *msg) +{ + if (extern_block_malloced) stat_free(extern_block); + initial_ofs += obj_counter; + free_extern_table(); + invalid_argument(msg); +} + +static void extern_rec(value v) +{ + tailcall: + if (Is_long(v)) { + long n = Long_val(v); + if (n >= 0 && n < 0x40) { + Write(PREFIX_SMALL_INT + n); + } else if (n >= -(1 << 7) && n < (1 << 7)) { + writecode8(CODE_INT8, n); + } else if (n >= -(1 << 15) && n < (1 << 15)) { + writecode16(CODE_INT16, n); +#ifdef ARCH_SIXTYFOUR + } else if (n < -(1L << 31) || n >= (1L << 31)) { + writecode64(CODE_INT64, n); +#endif + } else + writecode32(CODE_INT32, n); + return; + } + if (Is_young(v) || Is_in_heap(v) || Is_atom(v)) { + header_t hd = Hd_val(v); + tag_t tag = Tag_hd(hd); + mlsize_t sz = Wosize_hd(hd); + asize_t h; + + if (tag == Forward_tag) { + v = Forward_val (v); + goto tailcall; + } + /* Atoms are treated specially for two reasons: they are not allocated + in the externed block, and they are automatically shared. */ + if (sz == 0) { + if (tag < 16) { + Write(PREFIX_SMALL_BLOCK + tag); + } else { + writecode32(CODE_BLOCK32, hd); + } + return; + } + /* Check if already seen */ + if (! extern_ignore_sharing && tag != Infix_tag) { + if (2 * obj_counter >= extern_table_size) resize_extern_table(); + h = Hash(v); + while (extern_table[h].ofs >= initial_ofs) { + if (extern_table[h].obj == v) { + byteoffset_t d = obj_counter - (extern_table[h].ofs - initial_ofs); + if (d < 0x100) { + writecode8(CODE_SHARED8, d); + } else if (d < 0x10000) { + writecode16(CODE_SHARED16, d); + } else { + writecode32(CODE_SHARED32, d); + } + return; + } + h = (h + 1) & extern_table_mask; + } + /* Not seen yet. Record the object */ + extern_table[h].ofs = initial_ofs + obj_counter; + extern_table[h].obj = v; + obj_counter++; + } + /* Output the contents of the object */ + switch(tag) { + case String_tag: { + mlsize_t len = string_length(v); + if (len < 0x20) { + Write(PREFIX_SMALL_STRING + len); + } else if (len < 0x100) { + writecode8(CODE_STRING8, len); + } else { + writecode32(CODE_STRING32, len); + } + writeblock(String_val(v), len); + size_32 += 1 + (len + 4) / 4; + size_64 += 1 + (len + 8) / 8; + break; + } + case Double_tag: { + if (sizeof(double) != 8) + extern_invalid_argument("output_value: non-standard floats"); + Write(CODE_DOUBLE_NATIVE); + writeblock_float8((double *) v, 1); + size_32 += 1 + 2; + size_64 += 1 + 1; + break; + } + case Double_array_tag: { + mlsize_t nfloats; + if (sizeof(double) != 8) + extern_invalid_argument("output_value: non-standard floats"); + nfloats = Wosize_val(v) / Double_wosize; + if (nfloats < 0x100) { + writecode8(CODE_DOUBLE_ARRAY8_NATIVE, nfloats); + } else { + writecode32(CODE_DOUBLE_ARRAY32_NATIVE, nfloats); + } + writeblock_float8((double *) v, nfloats); + size_32 += 1 + nfloats * 2; + size_64 += 1 + nfloats; + break; + } + case Abstract_tag: + extern_invalid_argument("output_value: abstract value"); + break; + case Infix_tag: + writecode32(CODE_INFIXPOINTER, Infix_offset_hd(hd)); + extern_rec(v - Infix_offset_hd(hd)); + break; + case Object_tag: + extern_invalid_argument("output_value: object value"); + break; + case Custom_tag: { + unsigned long sz_32, sz_64; + char * ident = Custom_ops_val(v)->identifier; + void (*serialize)(value v, unsigned long * wsize_32, + unsigned long * wsize_64) + = Custom_ops_val(v)->serialize; + if (serialize == NULL) + extern_invalid_argument("output_value: abstract value"); + Write(CODE_CUSTOM); + writeblock(ident, strlen(ident) + 1); + Custom_ops_val(v)->serialize(v, &sz_32, &sz_64); + size_32 += 2 + ((sz_32 + 3) >> 2); /* header + ops + data */ + size_64 += 2 + ((sz_64 + 7) >> 3); + break; + } + case Forward_tag: + Assert(0); + /*fallthrough*/ + default: { + mlsize_t i; + if (tag < 16 && sz < 8) { + Write(PREFIX_SMALL_BLOCK + tag + (sz << 4)); +#ifdef ARCH_SIXTYFOUR + } else if (hd >= (1UL << 32)) { + writecode64(CODE_BLOCK64, Whitehd_hd (hd)); +#endif + } else { + writecode32(CODE_BLOCK32, Whitehd_hd (hd)); + } + size_32 += 1 + sz; + size_64 += 1 + sz; + for (i = 0; i < sz - 1; i++) extern_rec(Field(v, i)); + v = Field(v, i); + goto tailcall; + } + } + return; + } + if ((char *) v >= code_area_start && (char *) v < code_area_end) { + if (!extern_closures) + extern_invalid_argument("output_value: functional value"); + writecode32(CODE_CODEPOINTER, (char *) v - code_area_start); + writeblock((char *) code_checksum(), 16); + return; + } + extern_invalid_argument("output_value: abstract value"); +} + +enum { NO_SHARING = 1, CLOSURES = 2 }; +static int extern_flags[] = { NO_SHARING, CLOSURES }; + +static long extern_value(value v, value flags) +{ + long res_len; + int fl; + /* Parse flag list */ + fl = convert_flag_list(flags, extern_flags); + extern_ignore_sharing = fl & NO_SHARING; + extern_closures = fl & CLOSURES; + /* Allocate hashtable of objects already seen, if needed */ + extern_table_size = INITIAL_EXTERN_TABLE_SIZE; + extern_table_mask = extern_table_size - 1; + extern_hash_shift = 8 * sizeof(value) - INITIAL_EXTERN_TABLE_SIZE_LOG2; + if (extern_table == NULL) { + alloc_extern_table(); + initial_ofs = 1; + } + obj_counter = 0; + size_32 = 0; + size_64 = 0; + /* Write magic number */ + write32(Intext_magic_number); + /* Set aside space for the sizes */ + extern_ptr += 4*4; + /* Marshal the object */ + extern_rec(v); + /* Update initial offset for next call to extern_value(), + if we decide to keep the table of shared objects. */ + initial_ofs += obj_counter; + /* Free the table of shared objects (if needed) */ + free_extern_table(); + /* Write the sizes */ + res_len = extern_ptr - extern_block; +#ifdef ARCH_SIXTYFOUR + if (res_len >= (1L << 32) || + size_32 >= (1L << 32) || size_64 >= (1L << 32)) { + /* The object is so big its size cannot be written in the header. + Besides, some of the array lengths or string lengths or shared offsets + it contains may have overflowed the 32 bits used to write them. */ + failwith("output_value: object too big"); + } +#endif + extern_ptr = extern_block + 4; + write32(res_len - 5*4); + write32(obj_counter); + write32(size_32); + write32(size_64); + /* Result is res_len bytes starting at extern_block */ + return res_len; +} + +void output_val(struct channel *chan, value v, value flags) +{ + long len; + char * block; + + if (! channel_binary_mode(chan)) + failwith("output_value: not a binary channel"); + alloc_extern_block(); + len = extern_value(v, flags); + /* During really_putblock, concurrent output_val operations can take + place (via signal handlers or context switching in systhreads), + and extern_block may change. So, save the pointer in a local variable. */ + block = extern_block; + really_putblock(chan, extern_block, len); + stat_free(block); +} + +CAMLprim value output_value(value vchan, value v, value flags) +{ + CAMLparam3 (vchan, v, flags); + struct channel * channel = Channel(vchan); + + Lock(channel); + output_val(channel, v, flags); + Unlock(channel); + CAMLreturn (Val_unit); +} + +CAMLprim value output_value_to_string(value v, value flags) +{ + long len; + value res; + alloc_extern_block(); + len = extern_value(v, flags); + res = alloc_string(len); + memmove(String_val(res), extern_block, len); + stat_free(extern_block); + return res; +} + +CAMLprim value output_value_to_buffer(value buf, value ofs, value len, + value v, value flags) +{ + long len_res; + extern_block = &Byte(buf, Long_val(ofs)); + extern_limit = extern_block + Long_val(len); + extern_ptr = extern_block; + extern_block_malloced = 0; + len_res = extern_value(v, flags); + return Val_long(len_res); +} + +CAMLexport void output_value_to_malloc(value v, value flags, + /*out*/ char ** buf, /*out*/ long * len) +{ + long len_res; + alloc_extern_block(); + len_res = extern_value(v, flags); + *buf = extern_block; + *len = len_res; +} + +CAMLexport long output_value_to_block(value v, value flags, + char * buf, long len) +{ + long len_res; + extern_block = buf; + extern_limit = extern_block + len; + extern_ptr = extern_block; + extern_block_malloced = 0; + len_res = extern_value(v, flags); + return len_res; +} + +/* Functions for writing user-defined marshallers */ + +CAMLexport void serialize_int_1(int i) +{ + if (extern_ptr + 1 > extern_limit) resize_extern_block(1); + extern_ptr[0] = i; + extern_ptr += 1; +} + +CAMLexport void serialize_int_2(int i) +{ + if (extern_ptr + 2 > extern_limit) resize_extern_block(2); + extern_ptr[0] = i >> 8; + extern_ptr[1] = i; + extern_ptr += 2; +} + +CAMLexport void serialize_int_4(int32 i) +{ + if (extern_ptr + 4 > extern_limit) resize_extern_block(4); + extern_ptr[0] = i >> 24; + extern_ptr[1] = i >> 16; + extern_ptr[2] = i >> 8; + extern_ptr[3] = i; + extern_ptr += 4; +} + +CAMLexport void serialize_int_8(int64 i) +{ + serialize_block_8(&i, 1); +} + +CAMLexport void serialize_float_4(float f) +{ + serialize_block_4(&f, 1); +} + +CAMLexport void serialize_float_8(double f) +{ + serialize_block_8(&f, 1); +} + +CAMLexport void serialize_block_1(void * data, long len) +{ + if (extern_ptr + len > extern_limit) resize_extern_block(len); + memmove(extern_ptr, data, len); + extern_ptr += len; +} + +CAMLexport void serialize_block_2(void * data, long len) +{ + unsigned char * p; + char * q; + if (extern_ptr + 2 * len > extern_limit) resize_extern_block(2 * len); +#ifndef ARCH_BIG_ENDIAN + for (p = data, q = extern_ptr; len > 0; len--, p += 2, q += 2) + Reverse_16(q, p); + extern_ptr = q; +#else + memmove(extern_ptr, data, len * 2); + extern_ptr += len * 2; +#endif +} + +CAMLexport void serialize_block_4(void * data, long len) +{ + unsigned char * p; + char * q; + if (extern_ptr + 4 * len > extern_limit) resize_extern_block(4 * len); +#ifndef ARCH_BIG_ENDIAN + for (p = data, q = extern_ptr; len > 0; len--, p += 4, q += 4) + Reverse_32(q, p); + extern_ptr = q; +#else + memmove(extern_ptr, data, len * 4); + extern_ptr += len * 4; +#endif +} + +CAMLexport void serialize_block_8(void * data, long len) +{ + unsigned char * p; + char * q; + if (extern_ptr + 8 * len > extern_limit) resize_extern_block(8 * len); +#ifndef ARCH_BIG_ENDIAN + for (p = data, q = extern_ptr; len > 0; len--, p += 8, q += 8) + Reverse_64(q, p); + extern_ptr = q; +#else + memmove(extern_ptr, data, len * 8); + extern_ptr += len * 8; +#endif +} + +CAMLexport void serialize_block_float_8(void * data, long len) +{ + unsigned char * p; + char * q; + if (extern_ptr + 8 * len > extern_limit) resize_extern_block(8 * len); +#if ARCH_FLOAT_ENDIANNESS == 0x01234567 + memmove(extern_ptr, data, len * 8); + extern_ptr += len * 8; +#elif ARCH_FLOAT_ENDIANNESS == 0x76543210 + for (p = data, q = extern_ptr; len > 0; len--, p += 8, q += 8) + Reverse_64(q, p); + extern_ptr = q; +#else + for (p = data, q = extern_ptr; len > 0; len--, p += 8, q += 8) + Permute_64(q, 0x01234567, p, ARCH_FLOAT_ENDIANNESS); + extern_ptr = q; +#endif +} + + diff --git a/byterun/fail.c b/byterun/fail.c new file mode 100644 index 00000000..176ad8ca --- /dev/null +++ b/byterun/fail.c @@ -0,0 +1,137 @@ +/***********************************************************************/ +/* */ +/* 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: fail.c,v 1.22 2001/12/07 13:39:26 xleroy Exp $ */ + +/* Raising exceptions from C. */ + +#include "alloc.h" +#include "fail.h" +#include "io.h" +#include "gc.h" +#include "memory.h" +#include "misc.h" +#include "mlvalues.h" +#include "printexc.h" +#include "signals.h" +#include "stacks.h" + +struct longjmp_buffer * external_raise = NULL; +value exn_bucket; + +CAMLexport void mlraise(value v) +{ +#ifdef DEBUG + extern int volatile async_signal_mode; /* from signals.c */ + Assert(! async_signal_mode); +#endif + Unlock_exn(); + exn_bucket = v; + if (external_raise == NULL) fatal_uncaught_exception(v); + siglongjmp(external_raise->buf, 1); +} + +CAMLexport void raise_constant(value tag) +{ + CAMLparam1 (tag); + CAMLlocal1 (bucket); + + bucket = alloc_small (1, 0); + Field(bucket, 0) = tag; + mlraise(bucket); +} + +CAMLexport void raise_with_arg(value tag, value arg) +{ + CAMLparam2 (tag, arg); + CAMLlocal1 (bucket); + + bucket = alloc_small (2, 0); + Field(bucket, 0) = tag; + Field(bucket, 1) = arg; + mlraise(bucket); +} + +CAMLexport void raise_with_string(value tag, char *msg) +{ + CAMLparam1 (tag); + CAMLlocal1 (vmsg); + + vmsg = copy_string(msg); + raise_with_arg(tag, vmsg); +} + +CAMLexport void failwith (char *msg) +{ + raise_with_string(Field(global_data, FAILURE_EXN), msg); +} + +CAMLexport void invalid_argument (char *msg) +{ + raise_with_string(Field(global_data, INVALID_EXN), msg); +} + +/* Problem: we can't use raise_constant, because it allocates and + we're out of memory... Here, we allocate statically the exn bucket + for Out_of_memory. */ + +static struct { + header_t hdr; + value exn; +} out_of_memory_bucket = { 0, 0 }; + +CAMLexport void raise_out_of_memory(void) +{ + if (out_of_memory_bucket.exn == 0) + fatal_error("Fatal error: out of memory while raising Out_of_memory\n"); + mlraise((value) &(out_of_memory_bucket.exn)); +} + +CAMLexport void raise_stack_overflow(void) +{ + raise_constant(Field(global_data, STACK_OVERFLOW_EXN)); +} + +CAMLexport void raise_sys_error(value msg) +{ + raise_with_arg(Field(global_data, SYS_ERROR_EXN), msg); +} + +CAMLexport void raise_end_of_file(void) +{ + raise_constant(Field(global_data, END_OF_FILE_EXN)); +} + +CAMLexport void raise_zero_divide(void) +{ + raise_constant(Field(global_data, ZERO_DIVIDE_EXN)); +} + +CAMLexport void raise_not_found(void) +{ + raise_constant(Field(global_data, NOT_FOUND_EXN)); +} + +CAMLexport void raise_sys_blocked_io(void) +{ + raise_constant(Field(global_data, SYS_BLOCKED_IO)); +} + +/* Initialization of statically-allocated exception buckets */ + +void init_exceptions(void) +{ + out_of_memory_bucket.hdr = Make_header(1, 0, Caml_white); + out_of_memory_bucket.exn = Field(global_data, OUT_OF_MEMORY_EXN); + register_global_root(&out_of_memory_bucket.exn); +} diff --git a/byterun/fail.h b/byterun/fail.h new file mode 100644 index 00000000..9a2eccd3 --- /dev/null +++ b/byterun/fail.h @@ -0,0 +1,76 @@ +/***********************************************************************/ +/* */ +/* 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: fail.h,v 1.20 2003/06/19 15:53:49 xleroy Exp $ */ + +#ifndef _fail_ +#define _fail_ + +/* */ +#include +/* */ +#include "misc.h" +#include "mlvalues.h" + +/* */ +#define OUT_OF_MEMORY_EXN 0 /* "Out_of_memory" */ +#define SYS_ERROR_EXN 1 /* "Sys_error" */ +#define FAILURE_EXN 2 /* "Failure" */ +#define INVALID_EXN 3 /* "Invalid_argument" */ +#define END_OF_FILE_EXN 4 /* "End_of_file" */ +#define ZERO_DIVIDE_EXN 5 /* "Division_by_zero" */ +#define NOT_FOUND_EXN 6 /* "Not_found" */ +#define MATCH_FAILURE_EXN 7 /* "Match_failure" */ +#define STACK_OVERFLOW_EXN 8 /* "Stack_overflow" */ +#define SYS_BLOCKED_IO 9 /* "Sys_blocked_io" */ +#define ASSERT_FAILURE_EXN 10 /* "Assert_failure" */ +#define UNDEFINED_RECURSIVE_MODULE_EXN 11 /* "Undefined_recursive_module" */ + +#ifdef POSIX_SIGNALS +struct longjmp_buffer { + sigjmp_buf buf; +}; +#else +struct longjmp_buffer { + jmp_buf buf; +}; +#define sigsetjmp(buf,save) setjmp(buf) +#define siglongjmp(buf,val) longjmp(buf,val) +#endif + +CAMLextern struct longjmp_buffer * external_raise; +extern value exn_bucket; + +/* */ + +CAMLextern void mlraise (value bucket) Noreturn; +CAMLextern void raise_constant (value tag) Noreturn; +CAMLextern void raise_with_arg (value tag, value arg) Noreturn; +CAMLextern void raise_with_string (value tag, char * msg) Noreturn; +CAMLextern void failwith (char *) Noreturn; +CAMLextern void invalid_argument (char *) Noreturn; +CAMLextern void raise_out_of_memory (void) Noreturn; +CAMLextern void raise_stack_overflow (void) Noreturn; +CAMLextern void raise_sys_error (value) Noreturn; +CAMLextern void raise_end_of_file (void) Noreturn; +CAMLextern void raise_zero_divide (void) Noreturn; +CAMLextern void raise_not_found (void) Noreturn; +CAMLextern void init_exceptions (void); +CAMLextern void array_bound_error (void) Noreturn; +CAMLextern void raise_sys_blocked_io (void) Noreturn; + +/* */ +CAMLextern void (*caml_reset_sigmask)(void); +/* */ + +#endif /* _fail_ */ diff --git a/byterun/finalise.c b/byterun/finalise.c new file mode 100644 index 00000000..b9af1009 --- /dev/null +++ b/byterun/finalise.c @@ -0,0 +1,182 @@ +/***********************************************************************/ +/* */ +/* 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: finalise.c,v 1.9 2002/09/18 13:59:27 doligez Exp $ */ + +/* Handling of finalised values. */ + +#include "callback.h" +#include "fail.h" +#include "mlvalues.h" +#include "roots.h" +#include "signals.h" + +struct final { + value fun; + value val; +}; + +static struct final *final_table = NULL; +static unsigned long old = 0, young = 0, active = 0, size = 0; +/* [0..old) : finalisable set + [old..young) : recent set + [young..active) : free space + [active..size) : finalising set +*/ + +/* Find white finalisable values, darken them, and put them in the + finalising set. + The recent set is empty. +*/ +void final_update (void) +{ + unsigned long i; + unsigned long oldactive = active; + + Assert (young == old); + Assert (young <= active); + for (i = 0; i < old; i++){ + again: + Assert (Is_block (final_table[i].val)); + Assert (Is_in_heap (final_table[i].val)); + if (Is_white_val (final_table[i].val)){ + struct final f; + + if (Tag_val (final_table[i].val) == Forward_tag){ + final_table[i].val = Forward_val (final_table[i].val); + if (Is_block (final_table[i].val) && Is_in_heap (final_table[i].val)){ + goto again; + } + } + f = final_table[i]; + final_table[i] = final_table[--old]; + final_table[--active] = f; + -- i; + } + } + young = old; + for (i = active; i < oldactive; i++) darken (final_table[i].val, NULL); +} + +/* Call the finalisation functions for the finalising set. + Note that this function must be reentrant. +*/ +void final_do_calls (void) +{ + struct final f; + + Assert (active <= size); + if (active < size){ + gc_message (0x80, "Calling finalisation functions.\n", 0); + while (active < size){ + f = final_table[active++]; + callback (f.fun, f.val); + } + gc_message (0x80, "Done calling finalisation functions.\n", 0); + } +} + +/* Call a scanning_action [f] on [x]. */ +#define Call_action(f,x) (*(f)) ((x), &(x)) + +/* Call [*f] on the closures of the finalisable set and + the closures and values of the finalising set. + The recent set is empty. + This is called by the major GC and the compactor through [darken_all_roots]. +*/ +void final_do_strong_roots (scanning_action f) +{ + unsigned long i; + + Assert (old == young); + Assert (young <= active); + Assert (active <= size); + for (i = 0; i < old; i++) Call_action (f, final_table[i].fun); + for (i = active; i < size; i++){ + Call_action (f, final_table[i].fun); + Call_action (f, final_table[i].val); + } +} + +/* Call [*f] on the values of the finalisable set. + The recent set is empty. + This is called directly by the compactor. +*/ +void final_do_weak_roots (scanning_action f) +{ + unsigned long i; + + Assert (old == young); + for (i = 0; i < old; i++) Call_action (f, final_table[i].val); +} + +/* Call [*f] on the closures and values of the recent set. + This is called by the minor GC through [oldify_local_roots]. +*/ +void final_do_young_roots (scanning_action f) +{ + unsigned long i; + + Assert (old <= young); + for (i = old; i < young; i++){ + Call_action (f, final_table[i].fun); + Call_action (f, final_table[i].val); + } +} + +/* Empty the recent set into the finalisable set. + This is called at the end of each minor collection. + The minor heap must be empty when this is called. +*/ +void final_empty_young (void) +{ + old = young; +} + +/* Put (f,v) in the recent set. */ +CAMLprim value final_register (value f, value v) +{ + if (!(Is_block (v) && (Is_in_heap (v) || Is_young (v)))){ + invalid_argument ("Gc.finalise"); + } + + Assert (old <= young); + Assert (young <= active); + Assert (active <= size); + + if (young >= active){ + if (final_table == NULL){ + unsigned long new_size = 30; + final_table = stat_alloc (new_size * sizeof (struct final)); + Assert (old == 0); + Assert (young == 0); + active = size = new_size; + }else{ + unsigned long new_size = size * 2; + unsigned long i; + final_table = stat_resize (final_table, new_size * sizeof (struct final)); + for (i = size-1; i >= active; i--){ + final_table[i + new_size - size] = final_table[i]; + } + active += new_size - size; + size = new_size; + } + } + Assert (young < active); + final_table[young].fun = f; + if (Tag_val (v) == Infix_tag) v -= Infix_offset_val (v); + final_table[young].val = v; + ++ young; + + return Val_unit; +} diff --git a/byterun/finalise.h b/byterun/finalise.h new file mode 100644 index 00000000..0f7a6caf --- /dev/null +++ b/byterun/finalise.h @@ -0,0 +1,24 @@ +/***********************************************************************/ +/* */ +/* 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: finalise.h,v 1.3 2001/12/07 13:39:27 xleroy Exp $ */ + +#include "roots.h" + +void final_update (void); +void final_do_calls (void); +void final_do_strong_roots (scanning_action f); +void final_do_weak_roots (scanning_action f); +void final_do_young_roots (scanning_action f); +void final_empty_young (void); +value final_register (value f, value v); diff --git a/byterun/fix_code.c b/byterun/fix_code.c new file mode 100644 index 00000000..e10f00fb --- /dev/null +++ b/byterun/fix_code.c @@ -0,0 +1,162 @@ +/***********************************************************************/ +/* */ +/* 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: fix_code.c,v 1.26 2002/04/18 07:27:37 garrigue Exp $ */ + +/* Handling of blocks of bytecode (endianness switch, threading). */ + +#include "config.h" + +#ifdef HAS_UNISTD +#include +#endif + +#include "debugger.h" +#include "fix_code.h" +#include "instruct.h" +#include "md5.h" +#include "memory.h" +#include "misc.h" +#include "mlvalues.h" +#include "reverse.h" + +code_t start_code; +asize_t code_size; +unsigned char * saved_code; +unsigned char code_md5[16]; + +/* Read the main bytecode block from a file */ + +void load_code(int fd, asize_t len) +{ + int i; + struct MD5Context ctx; + + code_size = len; + start_code = (code_t) stat_alloc(code_size); + if (read(fd, (char *) start_code, code_size) != code_size) + fatal_error("Fatal error: truncated bytecode file.\n"); + MD5Init(&ctx); + MD5Update(&ctx, (unsigned char *) start_code, code_size); + MD5Final(code_md5, &ctx); +#ifdef ARCH_BIG_ENDIAN + fixup_endianness(start_code, code_size); +#endif + if (debugger_in_use) { + len /= sizeof(opcode_t); + saved_code = (unsigned char *) stat_alloc(len); + for (i = 0; i < len; i++) saved_code[i] = start_code[i]; + } +#ifdef THREADED_CODE + /* Better to thread now than at the beginning of interprete(), + since the debugger interface needs to perform SET_EVENT requests + on the code. */ + thread_code(start_code, code_size); +#endif +} + +/* This code is needed only if the processor is big endian */ + +#ifdef ARCH_BIG_ENDIAN + +void fixup_endianness(code_t code, asize_t len) +{ + code_t p; + len /= sizeof(opcode_t); + for (p = code; p < code + len; p++) { + Reverse_32(p, p); + } +} + +#endif + +/* This code is needed only if we're using threaded code */ + +#ifdef THREADED_CODE + +char ** instr_table; +char * instr_base; + +void thread_code (code_t code, asize_t len) +{ + code_t p; + int l [STOP + 1]; + int i; + + for (i = 0; i <= STOP; i++) { + l [i] = 0; + } + /* Instructions with one operand */ + l[PUSHACC] = l[ACC] = l[POP] = l[ASSIGN] = + l[PUSHENVACC] = l[ENVACC] = l[PUSH_RETADDR] = l[APPLY] = + l[APPTERM1] = l[APPTERM2] = l[APPTERM3] = l[RETURN] = + l[GRAB] = l[PUSHGETGLOBAL] = l[GETGLOBAL] = l[SETGLOBAL] = + l[PUSHATOM] = l[ATOM] = l[MAKEBLOCK1] = l[MAKEBLOCK2] = + l[MAKEBLOCK3] = l[MAKEFLOATBLOCK] = l[GETFIELD] = + l[GETFLOATFIELD] = l[SETFIELD] = l[SETFLOATFIELD] = + l[BRANCH] = l[BRANCHIF] = l[BRANCHIFNOT] = l[PUSHTRAP] = + l[C_CALL1] = l[C_CALL2] = l[C_CALL3] = l[C_CALL4] = l[C_CALL5] = + l[CONSTINT] = l[PUSHCONSTINT] = l[OFFSETINT] = + l[OFFSETREF] = l[OFFSETCLOSURE] = l[PUSHOFFSETCLOSURE] = 1; + + /* Instructions with two operands */ + l[APPTERM] = l[CLOSURE] = l[PUSHGETGLOBALFIELD] = + l[GETGLOBALFIELD] = l[MAKEBLOCK] = l[C_CALLN] = + l[BEQ] = l[BNEQ] = l[BLTINT] = l[BLEINT] = l[BGTINT] = l[BGEINT] = + l[BULTINT] = l[BUGEINT] = 2; + len /= sizeof(opcode_t); + for (p = code; p < code + len; /*nothing*/) { + opcode_t instr = *p; + if (instr < 0 || instr > STOP){ + /* + fatal_error_arg ("Fatal error in fix_code: bad opcode (%lx)\n", + (char *)(long)instr); + */ + instr = STOP; + } + *p++ = (opcode_t)(instr_table[instr] - instr_base); + if (instr == SWITCH) { + uint32 sizes = *p++; + uint32 const_size = sizes & 0xFFFF; + uint32 block_size = sizes >> 16; + p += const_size + block_size; + } else if (instr == CLOSUREREC) { + uint32 nfuncs = *p++; + p++; /* skip nvars */ + p += nfuncs; + } else { + p += l[instr]; + } + } + Assert(p == code + len); +} + +#endif /* THREADED_CODE */ + +void set_instruction(code_t pos, opcode_t instr) +{ +#ifdef THREADED_CODE + *pos = (opcode_t)(instr_table[instr] - instr_base); +#else + *pos = instr; +#endif +} + +int is_instruction(opcode_t instr1, opcode_t instr2) +{ +#ifdef THREADED_CODE + return instr1 == (opcode_t)(instr_table[instr2] - instr_base); +#else + return instr1 == instr2; +#endif +} diff --git a/byterun/fix_code.h b/byterun/fix_code.h new file mode 100644 index 00000000..6e9a597f --- /dev/null +++ b/byterun/fix_code.h @@ -0,0 +1,42 @@ +/***********************************************************************/ +/* */ +/* 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: fix_code.h,v 1.15 2001/12/07 13:39:27 xleroy Exp $ */ + +/* Handling of blocks of bytecode (endianness switch, threading). */ + +#ifndef _fix_code_ +#define _fix_code_ + + +#include "config.h" +#include "misc.h" +#include "mlvalues.h" + +extern code_t start_code; +extern asize_t code_size; +extern unsigned char * saved_code; +extern unsigned char code_md5[16]; + +void load_code (int fd, asize_t len); +void fixup_endianness (code_t code, asize_t len); +void set_instruction (code_t pos, opcode_t instr); +int is_instruction (opcode_t instr1, opcode_t instr2); + +#ifdef THREADED_CODE +extern char ** instr_table; +extern char * instr_base; +void thread_code (code_t code, asize_t len); +#endif + +#endif diff --git a/byterun/floats.c b/byterun/floats.c new file mode 100644 index 00000000..b22b637b --- /dev/null +++ b/byterun/floats.c @@ -0,0 +1,406 @@ +/***********************************************************************/ +/* */ +/* 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: floats.c,v 1.37 2003/05/05 14:16:29 xleroy Exp $ */ + +#include +#include +#include +#include + +#include "alloc.h" +#include "fail.h" +#include "memory.h" +#include "mlvalues.h" +#include "misc.h" +#include "reverse.h" +#include "stacks.h" + +#ifdef ARCH_ALIGN_DOUBLE + +CAMLexport double Double_val(value val) +{ + union { value v[2]; double d; } buffer; + + Assert(sizeof(double) == 2 * sizeof(value)); + buffer.v[0] = Field(val, 0); + buffer.v[1] = Field(val, 1); + return buffer.d; +} + +CAMLexport void Store_double_val(value val, double dbl) +{ + union { value v[2]; double d; } buffer; + + Assert(sizeof(double) == 2 * sizeof(value)); + buffer.d = dbl; + Field(val, 0) = buffer.v[0]; + Field(val, 1) = buffer.v[1]; +} + +#endif + +CAMLexport value copy_double(double d) +{ + value res; + +#define Setup_for_gc +#define Restore_after_gc + Alloc_small(res, Double_wosize, Double_tag); +#undef Setup_for_gc +#undef Restore_after_gc + Store_double_val(res, d); + return res; +} + +CAMLprim value format_float(value fmt, value arg) +{ +#define MAX_DIGITS 350 +/* Max number of decimal digits in a "natural" (not artificially padded) + representation of a float. Can be quite big for %f format. + Max exponent for IEEE format is 308 decimal digits. + Rounded up for good measure. */ + char format_buffer[MAX_DIGITS + 20]; + int prec, i; + char * p; + char * dest; + value res; + + prec = MAX_DIGITS; + for (p = String_val(fmt); *p != 0; p++) { + if (*p >= '0' && *p <= '9') { + i = atoi(p) + MAX_DIGITS; + if (i > prec) prec = i; + break; + } + } + for( ; *p != 0; p++) { + if (*p == '.') { + i = atoi(p+1) + MAX_DIGITS; + if (i > prec) prec = i; + break; + } + } + if (prec < sizeof(format_buffer)) { + dest = format_buffer; + } else { + dest = stat_alloc(prec); + } + sprintf(dest, String_val(fmt), Double_val(arg)); + res = copy_string(dest); + if (dest != format_buffer) { + stat_free(dest); + } + return res; +} + +CAMLprim value float_of_string(value vs) +{ + char parse_buffer[64]; + char * buf, * src, * dst, * end; + mlsize_t len; + double d; + + len = string_length(vs); + buf = len < sizeof(parse_buffer) ? parse_buffer : stat_alloc(len + 1); + src = String_val(vs); + dst = buf; + while (len--) { + char c = *src++; + if (c != '_') *dst++ = c; + } + *dst = 0; + if (dst == buf) failwith("float_of_string"); + d = strtod((const char *) buf, &end); + if (buf != parse_buffer) stat_free(buf); + if (end != dst) failwith("float_of_string"); + return copy_double(d); +} + +CAMLprim value int_of_float(value f) +{ + return Val_long((long) Double_val(f)); +} + +CAMLprim value float_of_int(value n) +{ + return copy_double((double) Long_val(n)); +} + +CAMLprim value neg_float(value f) +{ + return copy_double(- Double_val(f)); +} + +CAMLprim value abs_float(value f) +{ + return copy_double(fabs(Double_val(f))); +} + +CAMLprim value add_float(value f, value g) +{ + return copy_double(Double_val(f) + Double_val(g)); +} + +CAMLprim value sub_float(value f, value g) +{ + return copy_double(Double_val(f) - Double_val(g)); +} + +CAMLprim value mul_float(value f, value g) +{ + return copy_double(Double_val(f) * Double_val(g)); +} + +CAMLprim value div_float(value f, value g) +{ + return copy_double(Double_val(f) / Double_val(g)); +} + +CAMLprim value exp_float(value f) +{ + return copy_double(exp(Double_val(f))); +} + +CAMLprim value floor_float(value f) +{ + return copy_double(floor(Double_val(f))); +} + +CAMLprim value fmod_float(value f1, value f2) +{ + return copy_double(fmod(Double_val(f1), Double_val(f2))); +} + +CAMLprim value frexp_float(value f) +{ + CAMLparam1 (f); + CAMLlocal2 (res, mantissa); + int exponent; + + mantissa = copy_double(frexp (Double_val(f), &exponent)); + res = alloc_tuple(2); + Field(res, 0) = mantissa; + Field(res, 1) = Val_int(exponent); + CAMLreturn (res); +} + +CAMLprim value ldexp_float(value f, value i) +{ + return copy_double(ldexp(Double_val(f), Int_val(i))); +} + +CAMLprim value log_float(value f) +{ + return copy_double(log(Double_val(f))); +} + +CAMLprim value log10_float(value f) +{ + return copy_double(log10(Double_val(f))); +} + +CAMLprim value modf_float(value f) +{ +#if __SC__ + _float_eval frem; /* Problem with Apple's */ +#else + double frem; +#endif + CAMLparam1 (f); + CAMLlocal3 (res, quo, rem); + + quo = copy_double(modf (Double_val(f), &frem)); + rem = copy_double(frem); + res = alloc_tuple(2); + Field(res, 0) = quo; + Field(res, 1) = rem; + CAMLreturn (res); +} + +CAMLprim value sqrt_float(value f) +{ + return copy_double(sqrt(Double_val(f))); +} + +CAMLprim value power_float(value f, value g) +{ + return copy_double(pow(Double_val(f), Double_val(g))); +} + +CAMLprim value sin_float(value f) +{ + return copy_double(sin(Double_val(f))); +} + +CAMLprim value sinh_float(value f) +{ + return copy_double(sinh(Double_val(f))); +} + +CAMLprim value cos_float(value f) +{ + return copy_double(cos(Double_val(f))); +} + +CAMLprim value cosh_float(value f) +{ + return copy_double(cosh(Double_val(f))); +} + +CAMLprim value tan_float(value f) +{ + return copy_double(tan(Double_val(f))); +} + +CAMLprim value tanh_float(value f) +{ + return copy_double(tanh(Double_val(f))); +} + +CAMLprim value asin_float(value f) +{ + return copy_double(asin(Double_val(f))); +} + +CAMLprim value acos_float(value f) +{ + return copy_double(acos(Double_val(f))); +} + +CAMLprim value atan_float(value f) +{ + return copy_double(atan(Double_val(f))); +} + +CAMLprim value atan2_float(value f, value g) +{ + return copy_double(atan2(Double_val(f), Double_val(g))); +} + +CAMLprim value ceil_float(value f) +{ + return copy_double(ceil(Double_val(f))); +} + +CAMLprim value eq_float(value f, value g) +{ + return Val_bool(Double_val(f) == Double_val(g)); +} + +CAMLprim value neq_float(value f, value g) +{ + return Val_bool(Double_val(f) != Double_val(g)); +} + +CAMLprim value le_float(value f, value g) +{ + return Val_bool(Double_val(f) <= Double_val(g)); +} + +CAMLprim value lt_float(value f, value g) +{ + return Val_bool(Double_val(f) < Double_val(g)); +} + +CAMLprim value ge_float(value f, value g) +{ + return Val_bool(Double_val(f) >= Double_val(g)); +} + +CAMLprim value gt_float(value f, value g) +{ + return Val_bool(Double_val(f) > Double_val(g)); +} + +CAMLprim value float_compare(value vf, value vg) +{ + double f = Double_val(vf); + double g = Double_val(vg); + return f < g ? Val_int(-1) : f > g ? Val_int(1) : Val_int(0); +} + +CAMLprim value float_of_bytes(value s) +{ + value d = copy_double(0.0); +#ifdef ARCH_BIG_ENDIAN + memcpy(String_val(d), String_val(s), 8); +#else + Reverse_64(String_val(d), String_val(s)); +#endif + return d; +} + +enum { FP_normal, FP_subnormal, FP_zero, FP_infinite, FP_nan }; + +CAMLprim value classify_float(value vd) +{ + /* Cygwin 1.3 has problems with fpclassify (PR#1293), so don't use it */ +#if defined(fpclassify) && !defined(__CYGWIN32__) && !defined(__MINGW32__) + switch (fpclassify(Double_val(vd))) { + case FP_NAN: + return Val_int(FP_nan); + case FP_INFINITE: + return Val_int(FP_infinite); + case FP_ZERO: + return Val_int(FP_zero); + case FP_SUBNORMAL: + return Val_int(FP_subnormal); + default: /* case FP_NORMAL */ + return Val_int(FP_normal); + } +#else + double d = Double_val(vd); + uint32 h, l; +#ifdef ARCH_BIG_ENDIAN + h = ((uint32 *) &d)[0]; + l = ((uint32 *) &d)[1]; +#else + l = ((uint32 *) &d)[0]; + h = ((uint32 *) &d)[1]; +#endif + l = l | (h & 0xFFFFF); + h = h & 0x7FF00000; + if ((h | l) == 0) + return Val_int(FP_zero); + if (h == 0) + return Val_int(FP_subnormal); + if (h == 0x7FF00000) { + if (l == 0) + return Val_int(FP_infinite); + else + return Val_int(FP_nan); + } + return Val_int(FP_normal); +#endif +} + +/* The init_ieee_float function should initialize floating-point hardware + so that it behaves as much as possible like the IEEE standard. + In particular, return special numbers like Infinity and NaN instead + of signalling exceptions. Currently, everyone is in IEEE mode + at program startup, except FreeBSD prior to 4.0R. */ + +#ifdef __FreeBSD__ +#include +#if (__FreeBSD_version < 400017) +#include +#endif +#endif + +void init_ieee_floats(void) +{ +#if defined(__FreeBSD__) && (__FreeBSD_version < 400017) + fpsetmask(0); +#endif +} diff --git a/byterun/freelist.c b/byterun/freelist.c new file mode 100644 index 00000000..51a86aff --- /dev/null +++ b/byterun/freelist.c @@ -0,0 +1,316 @@ +/***********************************************************************/ +/* */ +/* Objective Caml */ +/* */ +/* Damien Doligez, projet Para, 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: freelist.c,v 1.14 2002/12/12 18:59:11 doligez Exp $ */ + +#include "config.h" +#include "freelist.h" +#include "gc.h" +#include "gc_ctrl.h" +#include "major_gc.h" +#include "misc.h" +#include "mlvalues.h" + +/* The free-list is kept sorted by increasing addresses. + This makes the merging of adjacent free blocks possible. + (See [fl_merge_block].) +*/ + +typedef struct { + char *next_bp; /* Pointer to the first byte of the next block. */ +} block; + +/* The sentinel can be located anywhere in memory, but it must not be + adjacent to any heap object. */ +static struct { + value filler1; /* Make sure the sentinel is never adjacent to any block. */ + header_t h; + value first_bp; + value filler2; /* Make sure the sentinel is never adjacent to any block. */ +} sentinel = {0, Make_header (0, 0, Caml_blue), 0, 0}; + +#define Fl_head ((char *) (&(sentinel.first_bp))) +static char *fl_prev = Fl_head; /* Current allocation pointer. */ +static char *fl_last = NULL; /* Last block in the list. Only valid + just after fl_allocate returned NULL. */ +char *fl_merge = Fl_head; /* Current insertion pointer. Managed + jointly with [sweep_slice]. */ +asize_t fl_cur_size = 0; /* Number of words in the free list, + including headers but not fragments. */ + +#define Next(b) (((block *) (b))->next_bp) + +#ifdef DEBUG +void fl_check (void) +{ + char *cur, *prev; + int prev_found = 0, merge_found = 0; + unsigned long size_found = 0; + + prev = Fl_head; + cur = Next (prev); + while (cur != NULL){ + size_found += Whsize_bp (cur); + Assert (Is_in_heap (cur)); + if (cur == fl_prev) prev_found = 1; + if (cur == fl_merge) merge_found = 1; + prev = cur; + cur = Next (prev); + } + Assert (prev_found || fl_prev == Fl_head); + Assert (merge_found || fl_merge == Fl_head); + Assert (size_found == fl_cur_size); +} +#endif + +/* [allocate_block] is called by [fl_allocate]. Given a suitable free + block and the desired size, it allocates a new block from the free + block. There are three cases: + 0. The free block has the desired size. Detach the block from the + free-list and return it. + 1. The free block is 1 word longer than the desired size. Detach + the block from the free list. The remaining word cannot be linked: + turn it into an empty block (header only), and return the rest. + 2. The free block is big enough. Split it in two and return the right + block. + In all cases, the allocated block is right-justified in the free block: + it is located in the high-address words of the free block. This way, + the linking of the free-list does not change in case 2. +*/ +static char *allocate_block (mlsize_t wh_sz, char *prev, char *cur) +{ + header_t h = Hd_bp (cur); + Assert (Whsize_hd (h) >= wh_sz); + if (Wosize_hd (h) < wh_sz + 1){ /* Cases 0 and 1. */ + fl_cur_size -= Whsize_hd (h); + Next (prev) = Next (cur); + Assert (Is_in_heap (Next (prev)) || Next (prev) == NULL); + if (fl_merge == cur) fl_merge = prev; +#ifdef DEBUG + fl_last = NULL; +#endif + /* In case 1, the following creates the empty block correctly. + In case 0, it gives an invalid header to the block. The function + calling [fl_allocate] will overwrite it. */ + Hd_op (cur) = Make_header (0, 0, Caml_white); + }else{ /* Case 2. */ + fl_cur_size -= wh_sz; + Hd_op (cur) = Make_header (Wosize_hd (h) - wh_sz, 0, Caml_blue); + } + fl_prev = prev; + return cur + Bosize_hd (h) - Bsize_wsize (wh_sz); +} + +/* [fl_allocate] does not set the header of the newly allocated block. + The calling function must do it before any GC function gets called. + [fl_allocate] returns a head pointer. +*/ +char *fl_allocate (mlsize_t wo_sz) +{ + char *cur, *prev; + Assert (sizeof (char *) == sizeof (value)); + Assert (fl_prev != NULL); + Assert (wo_sz >= 1); + /* Search from [fl_prev] to the end of the list. */ + prev = fl_prev; + cur = Next (prev); + while (cur != NULL){ Assert (Is_in_heap (cur)); + if (Wosize_bp (cur) >= wo_sz){ + return allocate_block (Whsize_wosize (wo_sz), prev, cur); + } + prev = cur; + cur = Next (prev); + } + fl_last = prev; + /* Search from the start of the list to [fl_prev]. */ + prev = Fl_head; + cur = Next (prev); + while (prev != fl_prev){ + if (Wosize_bp (cur) >= wo_sz){ + return allocate_block (Whsize_wosize (wo_sz), prev, cur); + } + prev = cur; + cur = Next (prev); + } + /* No suitable block was found. */ + return NULL; +} + +static char *last_fragment; + +void fl_init_merge (void) +{ + last_fragment = NULL; + fl_merge = Fl_head; +#ifdef DEBUG + fl_check (); +#endif +} + +/* This is called by compact_heap. */ +void fl_reset (void) +{ + Next (Fl_head) = 0; + fl_prev = Fl_head; + fl_cur_size = 0; + fl_init_merge (); +} + +/* [fl_merge_block] returns the head pointer of the next block after [bp], + because merging blocks may change the size of [bp]. */ +char *fl_merge_block (char *bp) +{ + char *prev, *cur, *adj; + header_t hd = Hd_bp (bp); + mlsize_t prev_wosz; + + fl_cur_size += Whsize_hd (hd); + +#ifdef DEBUG + { + mlsize_t i; + for (i = 0; i < Wosize_hd (hd); i++){ + Field (Val_bp (bp), i) = Debug_free_major; + } + } +#endif + prev = fl_merge; + cur = Next (prev); + /* The sweep code makes sure that this is the right place to insert + this block: */ + Assert (prev < bp || prev == Fl_head); + Assert (cur > bp || cur == NULL); + + /* If [last_fragment] and [bp] are adjacent, merge them. */ + if (last_fragment == Hp_bp (bp)){ + mlsize_t bp_whsz = Whsize_bp (bp); + if (bp_whsz <= Max_wosize){ + hd = Make_header (bp_whsz, 0, Caml_white); + bp = last_fragment; + Hd_bp (bp) = hd; + fl_cur_size += Whsize_wosize (0); + } + } + + /* If [bp] and [cur] are adjacent, remove [cur] from the free-list + and merge them. */ + adj = bp + Bosize_hd (hd); + if (adj == Hp_bp (cur)){ + char *next_cur = Next (cur); + mlsize_t cur_whsz = Whsize_bp (cur); + + if (Wosize_hd (hd) + cur_whsz <= Max_wosize){ + Next (prev) = next_cur; + if (fl_prev == cur) fl_prev = prev; + hd = Make_header (Wosize_hd (hd) + cur_whsz, 0, Caml_blue); + Hd_bp (bp) = hd; + adj = bp + Bosize_hd (hd); +#ifdef DEBUG + fl_last = NULL; + Next (cur) = (char *) Debug_free_major; + Hd_bp (cur) = Debug_free_major; +#endif + cur = next_cur; + } + } + /* If [prev] and [bp] are adjacent merge them, else insert [bp] into + the free-list if it is big enough. */ + prev_wosz = Wosize_bp (prev); + if (prev + Bsize_wsize (prev_wosz) == Hp_bp (bp) + && prev_wosz + Whsize_hd (hd) < Max_wosize){ + Hd_bp (prev) = Make_header (prev_wosz + Whsize_hd (hd), 0,Caml_blue); +#ifdef DEBUG + Hd_bp (bp) = Debug_free_major; +#endif + Assert (fl_merge == prev); + }else if (Wosize_hd (hd) != 0){ + Hd_bp (bp) = Bluehd_hd (hd); + Next (bp) = cur; + Next (prev) = bp; + fl_merge = bp; + }else{ + /* This is a fragment. Leave it in white but remember it for eventual + merging with the next block. */ + last_fragment = bp; + fl_cur_size -= Whsize_wosize (0); + } + return adj; +} + +/* This is a heap extension. We have to insert it in the right place + in the free-list. + [fl_add_block] can only be called just after a call to [fl_allocate] + that returned NULL. + Most of the heap extensions are expected to be at the end of the + free list. (This depends on the implementation of [malloc].) +*/ +void fl_add_block (char *bp) +{ + Assert (fl_last != NULL); + Assert (Next (fl_last) == NULL); +#ifdef DEBUG + { + mlsize_t i; + for (i = 0; i < Wosize_bp (bp); i++){ + Field (Val_bp (bp), i) = Debug_free_major; + } + } +#endif + + fl_cur_size += Whsize_bp (bp); + + if (bp > fl_last){ + Next (fl_last) = bp; + Next (bp) = NULL; + }else{ + char *cur, *prev; + + prev = Fl_head; + cur = Next (prev); + while (cur != NULL && cur < bp){ Assert (prev < bp || prev == Fl_head); + prev = cur; + cur = Next (prev); + } Assert (prev < bp || prev == Fl_head); + Assert (cur > bp || cur == NULL); + Next (bp) = cur; + Next (prev) = bp; + /* When inserting a block between fl_merge and gc_sweep_hp, we must + advance fl_merge to the new block, so that fl_merge is always the + last free-list block before gc_sweep_hp. */ + if (prev == fl_merge && bp <= gc_sweep_hp) fl_merge = bp; + } +} + +/* Cut a block of memory into Max_wosize pieces, give them headers, + and optionally merge them into the free list. + arguments: + p: pointer to the first word of the block + size: size of the block (in words) + do_merge: 1 -> do merge; 0 -> do not merge +*/ +void make_free_blocks (value *p, mlsize_t size, int do_merge) +{ + mlsize_t sz; + + while (size > 0){ + if (size > Whsize_wosize (Max_wosize)){ + sz = Whsize_wosize (Max_wosize); + }else{ + sz = size; + } + *(header_t *)p = Make_header (Wosize_whsize (sz), 0, Caml_white); + if (do_merge) fl_merge_block (Bp_hp (p)); + size -= sz; + p += sz; + } +} diff --git a/byterun/freelist.h b/byterun/freelist.h new file mode 100644 index 00000000..a5b64179 --- /dev/null +++ b/byterun/freelist.h @@ -0,0 +1,35 @@ +/***********************************************************************/ +/* */ +/* Objective Caml */ +/* */ +/* Damien Doligez, projet Para, 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: freelist.h,v 1.10 2002/12/12 18:59:11 doligez Exp $ */ + +/* Free lists of heap blocks. */ + +#ifndef _freelist_ +#define _freelist_ + + +#include "misc.h" +#include "mlvalues.h" + +extern asize_t fl_cur_size; /* size in words */ + +char *fl_allocate (mlsize_t); +void fl_init_merge (void); +void fl_reset (void); +char *fl_merge_block (char *); +void fl_add_block (char *); +void make_free_blocks (value *, mlsize_t, int); + + +#endif /* _freelist_ */ diff --git a/byterun/gc.h b/byterun/gc.h new file mode 100644 index 00000000..49dd2180 --- /dev/null +++ b/byterun/gc.h @@ -0,0 +1,55 @@ +/***********************************************************************/ +/* */ +/* Objective Caml */ +/* */ +/* Damien Doligez, projet Para, 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: gc.h,v 1.13 2002/12/16 16:42:12 doligez Exp $ */ + +#ifndef _gc_ +#define _gc_ + + +#include "mlvalues.h" + +#define Caml_white (0 << 8) +#define Caml_gray (1 << 8) +#define Caml_blue (2 << 8) +#define Caml_black (3 << 8) + +#define Color_hd(hd) ((color_t) ((hd) & Caml_black)) +#define Color_hp(hp) (Color_hd (Hd_hp (hp))) +#define Color_val(val) (Color_hd (Hd_val (val))) + +#define Is_white_hd(hd) (Color_hd (hd) == Caml_white) +#define Is_gray_hd(hd) (Color_hd (hd) == Caml_gray) +#define Is_blue_hd(hd) (Color_hd (hd) == Caml_blue) +#define Is_black_hd(hd) (Color_hd (hd) == Caml_black) + +#define Whitehd_hd(hd) (((hd) & ~Caml_black)/*| Caml_white*/) +#define Grayhd_hd(hd) (((hd) & ~Caml_black) | Caml_gray) +#define Blackhd_hd(hd) (((hd)/*& ~Caml_black*/)| Caml_black) +#define Bluehd_hd(hd) (((hd) & ~Caml_black) | Caml_blue) + +/* This depends on the layout of the header. See [mlvalues.h]. */ +#define Make_header(wosize, tag, color) \ + (/*Assert ((wosize) <= Max_wosize),*/ \ + ((header_t) (((header_t) (wosize) << 10) \ + + (color) \ + + (tag_t) (tag))) \ + ) + +#define Is_white_val(val) (Color_val(val) == Caml_white) +#define Is_gray_val(val) (Color_val(val) == Caml_gray) +#define Is_blue_val(val) (Color_val(val) == Caml_blue) +#define Is_black_val(val) (Color_val(val) == Caml_black) + + +#endif /* _gc_ */ diff --git a/byterun/gc_ctrl.c b/byterun/gc_ctrl.c new file mode 100644 index 00000000..baf7c676 --- /dev/null +++ b/byterun/gc_ctrl.c @@ -0,0 +1,428 @@ +/***********************************************************************/ +/* */ +/* Objective Caml */ +/* */ +/* Damien Doligez, projet Para, 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: gc_ctrl.c,v 1.41 2002/12/15 23:27:06 doligez Exp $ */ + +#include "alloc.h" +#include "compact.h" +#include "custom.h" +#include "finalise.h" +#include "gc.h" +#include "gc_ctrl.h" +#include "major_gc.h" +#include "minor_gc.h" +#include "misc.h" +#include "mlvalues.h" +#include "stacks.h" + +#ifndef NATIVE_CODE +extern unsigned long max_stack_size; /* defined in stacks.c */ +#endif + +double stat_minor_words = 0.0, + stat_promoted_words = 0.0, + stat_major_words = 0.0; + +long stat_minor_collections = 0, + stat_major_collections = 0, + stat_heap_size = 0, /* bytes */ + stat_top_heap_size = 0, /* bytes */ + stat_compactions = 0, + stat_heap_chunks = 0; + +extern asize_t major_heap_increment; /* bytes; see major_gc.c */ +extern unsigned long percent_free; /* see major_gc.c */ +extern unsigned long percent_max; /* see compact.c */ + +#define Next(hp) ((hp) + Bhsize_hp (hp)) + +#ifdef DEBUG + +/* Check that [v]'s header looks good. [v] must be a block in the heap. */ +static void check_head (value v) +{ + Assert (Is_block (v)); + Assert (Is_in_heap (v)); + + Assert (Wosize_val (v) != 0); + Assert (Color_hd (Hd_val (v)) != Caml_blue); + Assert (Is_in_heap (v)); + if (Tag_val (v) == Infix_tag){ + int offset = Wsize_bsize (Infix_offset_val (v)); + value trueval = Val_op (&Field (v, -offset)); + Assert (Tag_val (trueval) == Closure_tag); + Assert (Wosize_val (trueval) > offset); + Assert (Is_in_heap (&Field (trueval, Wosize_val (trueval) - 1))); + }else{ + Assert (Is_in_heap (&Field (v, Wosize_val (v) - 1))); + } + if (Tag_val (v) == Double_tag){ + Assert (Wosize_val (v) == Double_wosize); + }else if (Tag_val (v) == Double_array_tag){ + Assert (Wosize_val (v) % Double_wosize == 0); + } +} + +static void check_block (char *hp) +{ + mlsize_t nfields = Wosize_hp (hp); + mlsize_t i; + value v = Val_hp (hp); + value f; + mlsize_t lastbyte; + + check_head (v); + switch (Tag_hp (hp)){ + case Abstract_tag: break; + case String_tag: + /* not true when check_urgent_gc is called by alloc or alloc_string: + lastbyte = Bosize_val (v) - 1; + i = Byte (v, lastbyte); + Assert (i >= 0); + Assert (i < sizeof (value)); + Assert (Byte (v, lastbyte - i) == 0); + */ + break; + case Double_tag: + Assert (Wosize_val (v) == Double_wosize); + break; + case Double_array_tag: + Assert (Wosize_val (v) % Double_wosize == 0); + break; + case Custom_tag: + Assert (!Is_in_heap (Custom_ops_val (v))); + break; + + case Infix_tag: + Assert (0); + break; + + default: + Assert (Tag_hp (hp) < No_scan_tag); + for (i = 0; i < Wosize_hp (hp); i++){ + f = Field (v, i); + if (Is_block (f) && Is_in_heap (f)) check_head (f); + } + } +} + +#endif /* DEBUG */ + +/* Check the heap structure (if compiled in debug mode) and + gather statistics; return the stats if [returnstats] is true, + otherwise return [Val_unit]. +*/ +static value heap_stats (int returnstats) +{ + CAMLparam0 (); + long live_words = 0, live_blocks = 0, + free_words = 0, free_blocks = 0, largest_free = 0, + fragments = 0, heap_chunks = 0; + char *chunk = heap_start, *chunk_end; + char *cur_hp, *prev_hp; + header_t cur_hd; + +#ifdef DEBUG + gc_message (-1, "### O'Caml runtime: heap check ###\n", 0); +#endif + + while (chunk != NULL){ + ++ heap_chunks; + chunk_end = chunk + Chunk_size (chunk); + prev_hp = NULL; + cur_hp = chunk; + while (cur_hp < chunk_end){ + cur_hd = Hd_hp (cur_hp); + Assert (Next (cur_hp) <= chunk_end); + switch (Color_hd (cur_hd)){ + case Caml_white: + if (Wosize_hd (cur_hd) == 0){ + ++ fragments; + Assert (prev_hp == NULL + || Color_hp (prev_hp) != Caml_blue + || cur_hp == gc_sweep_hp); + }else{ + if (gc_phase == Phase_sweep && cur_hp >= gc_sweep_hp){ + ++ free_blocks; + free_words += Whsize_hd (cur_hd); + if (Whsize_hd (cur_hd) > largest_free){ + largest_free = Whsize_hd (cur_hd); + } + }else{ + ++ live_blocks; + live_words += Whsize_hd (cur_hd); +#ifdef DEBUG + check_block (cur_hp); +#endif + } + } + break; + case Caml_gray: case Caml_black: + Assert (Wosize_hd (cur_hd) > 0); + ++ live_blocks; + live_words += Whsize_hd (cur_hd); +#ifdef DEBUG + check_block (cur_hp); +#endif + break; + case Caml_blue: + Assert (Wosize_hd (cur_hd) > 0); + ++ free_blocks; + free_words += Whsize_hd (cur_hd); + if (Whsize_hd (cur_hd) > largest_free){ + largest_free = Whsize_hd (cur_hd); + } + /* not true any more with big heap chunks + Assert (prev_hp == NULL + || (Color_hp (prev_hp) != Caml_blue && Wosize_hp (prev_hp) > 0) + || cur_hp == gc_sweep_hp); + Assert (Next (cur_hp) == chunk_end + || (Color_hp (Next (cur_hp)) != Caml_blue + && Wosize_hp (Next (cur_hp)) > 0) + || (Whsize_hd (cur_hd) + Wosize_hp (Next (cur_hp)) > Max_wosize) + || Next (cur_hp) == gc_sweep_hp); + */ + break; + } + prev_hp = cur_hp; + cur_hp = Next (cur_hp); + } Assert (cur_hp == chunk_end); + chunk = Chunk_next (chunk); + } + + Assert (heap_chunks == stat_heap_chunks); + Assert (live_words + free_words + fragments == Wsize_bsize (stat_heap_size)); + + if (returnstats){ + CAMLlocal1 (res); + + /* get a copy of these before allocating anything... */ + double minwords = stat_minor_words + + (double) Wsize_bsize (young_end - young_ptr); + double prowords = stat_promoted_words; + double majwords = stat_major_words + (double) allocated_words; + long mincoll = stat_minor_collections; + long majcoll = stat_major_collections; + long heap_words = Wsize_bsize (stat_heap_size); + long cpct = stat_compactions; + long top_heap_words = Wsize_bsize (stat_top_heap_size); + + res = alloc_tuple (15); + Store_field (res, 0, copy_double (minwords)); + Store_field (res, 1, copy_double (prowords)); + Store_field (res, 2, copy_double (majwords)); + Store_field (res, 3, Val_long (mincoll)); + Store_field (res, 4, Val_long (majcoll)); + Store_field (res, 5, Val_long (heap_words)); + Store_field (res, 6, Val_long (heap_chunks)); + Store_field (res, 7, Val_long (live_words)); + Store_field (res, 8, Val_long (live_blocks)); + Store_field (res, 9, Val_long (free_words)); + Store_field (res, 10, Val_long (free_blocks)); + Store_field (res, 11, Val_long (largest_free)); + Store_field (res, 12, Val_long (fragments)); + Store_field (res, 13, Val_long (cpct)); + Store_field (res, 14, Val_long (top_heap_words)); + CAMLreturn (res); + }else{ + CAMLreturn (Val_unit); + } +} + +#ifdef DEBUG +void heap_check (void) +{ + heap_stats (0); +} +#endif + +CAMLprim value gc_stat(value v) +{ + Assert (v == Val_unit); + return heap_stats (1); +} + +CAMLprim value gc_counters(value v) +{ + CAMLparam0 (); /* v is ignored */ + CAMLlocal1 (res); + + /* get a copy of these before allocating anything... */ + double minwords = stat_minor_words + + (double) Wsize_bsize (young_end - young_ptr); + double prowords = stat_promoted_words; + double majwords = stat_major_words + (double) allocated_words; + + res = alloc_tuple (3); + Store_field (res, 0, copy_double (minwords)); + Store_field (res, 1, copy_double (prowords)); + Store_field (res, 2, copy_double (majwords)); + CAMLreturn (res); +} + +CAMLprim value gc_get(value v) +{ + CAMLparam0 (); /* v is ignored */ + CAMLlocal1 (res); + + res = alloc_tuple (6); + Store_field (res, 0, Val_long (Wsize_bsize (minor_heap_size))); /* s */ + Store_field (res, 1, Val_long (Wsize_bsize (major_heap_increment))); /* i */ + Store_field (res, 2, Val_long (percent_free)); /* o */ + Store_field (res, 3, Val_long (verb_gc)); /* v */ + Store_field (res, 4, Val_long (percent_max)); /* O */ +#ifndef NATIVE_CODE + Store_field (res, 5, Val_long (max_stack_size)); /* l */ +#else + Store_field (res, 5, Val_long (0)); +#endif + CAMLreturn (res); +} + +#define Max(x,y) ((x) < (y) ? (y) : (x)) + +static unsigned long norm_pfree (long unsigned int p) +{ + return Max (p, 1); +} + +static unsigned long norm_pmax (long unsigned int p) +{ + return p; +} + +static long norm_heapincr (long unsigned int i) +{ +#define Psv (Wsize_bsize (Page_size)) + i = ((i + Psv - 1) / Psv) * Psv; + if (i < Heap_chunk_min) i = Heap_chunk_min; + return i; +} + +static long norm_minsize (long int s) +{ + if (s < Minor_heap_min) s = Minor_heap_min; + if (s > Minor_heap_max) s = Minor_heap_max; + return s; +} + +CAMLprim value gc_set(value v) +{ + unsigned long newpf, newpm; + asize_t newheapincr; + asize_t newminsize; + + verb_gc = Long_val (Field (v, 3)); + +#ifndef NATIVE_CODE + change_max_stack_size (Long_val (Field (v, 5))); +#endif + + newpf = norm_pfree (Long_val (Field (v, 2))); + if (newpf != percent_free){ + percent_free = newpf; + gc_message (0x20, "New space overhead: %d%%\n", percent_free); + } + + newpm = norm_pmax (Long_val (Field (v, 4))); + if (newpm != percent_max){ + percent_max = newpm; + gc_message (0x20, "New max overhead: %d%%\n", percent_max); + } + + newheapincr = Bsize_wsize (norm_heapincr (Long_val (Field (v, 1)))); + if (newheapincr != major_heap_increment){ + major_heap_increment = newheapincr; + gc_message (0x20, "New heap increment size: %luk bytes\n", + major_heap_increment/1024); + } + + /* Minor heap size comes last because it will trigger a minor collection + (thus invalidating [v]) and it can raise [Out_of_memory]. */ + newminsize = norm_minsize (Bsize_wsize (Long_val (Field (v, 0)))); + if (newminsize != minor_heap_size){ + gc_message (0x20, "New minor heap size: %luk bytes\n", newminsize/1024); + set_minor_heap_size (newminsize); + } + return Val_unit; +} + +CAMLprim value gc_minor(value v) +{ Assert (v == Val_unit); + minor_collection (); + return Val_unit; +} + +CAMLprim value gc_major(value v) +{ Assert (v == Val_unit); + empty_minor_heap (); + finish_major_cycle (); + final_do_calls (); + return Val_unit; +} + +CAMLprim value gc_full_major(value v) +{ Assert (v == Val_unit); + empty_minor_heap (); + finish_major_cycle (); + final_do_calls (); + empty_minor_heap (); + finish_major_cycle (); + final_do_calls (); + return Val_unit; +} + +CAMLprim value gc_major_slice (value v) +{ + Assert (Is_long (v)); + empty_minor_heap (); + return Val_long (major_collection_slice (Long_val (v))); +} + +CAMLprim value gc_compaction(value v) +{ Assert (v == Val_unit); + empty_minor_heap (); + finish_major_cycle (); + finish_major_cycle (); + compact_heap (); + return Val_unit; +} + +void init_gc (unsigned long minor_size, unsigned long major_size, + unsigned long major_incr, unsigned long percent_fr, + unsigned long percent_m) +{ + unsigned long major_heap_size = Bsize_wsize (norm_heapincr (major_size)); + +#ifdef DEBUG + gc_message (-1, "### O'Caml runtime: debug mode " +#ifdef CPU_TYPE_STRING + "(" CPU_TYPE_STRING ") " +#endif + "###\n", 0); +#endif + + set_minor_heap_size (Bsize_wsize (norm_minsize (minor_size))); + major_heap_increment = Bsize_wsize (norm_heapincr (major_incr)); + percent_free = norm_pfree (percent_fr); + percent_max = norm_pmax (percent_m); + init_major_heap (major_heap_size); + gc_message (0x20, "Initial minor heap size: %luk bytes\n", + minor_heap_size / 1024); + gc_message (0x20, "Initial major heap size: %luk bytes\n", + major_heap_size / 1024); + gc_message (0x20, "Initial space overhead: %lu%%\n", percent_free); + gc_message (0x20, "Initial max overhead: %lu%%\n", percent_max); + gc_message (0x20, "Initial heap increment: %luk bytes\n", + major_heap_increment / 1024); +} diff --git a/byterun/gc_ctrl.h b/byterun/gc_ctrl.h new file mode 100644 index 00000000..3a4151c8 --- /dev/null +++ b/byterun/gc_ctrl.h @@ -0,0 +1,42 @@ +/***********************************************************************/ +/* */ +/* Objective Caml */ +/* */ +/* Damien Doligez, projet Para, 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: gc_ctrl.h,v 1.13 2002/05/28 16:57:31 doligez Exp $ */ + +#ifndef _gc_ctrl_ +#define _gc_ctrl_ + +#include "misc.h" + +extern double + stat_minor_words, + stat_promoted_words, + stat_major_words; + +extern long + stat_minor_collections, + stat_major_collections, + stat_heap_size, + stat_top_heap_size, + stat_compactions, + stat_heap_chunks; + +void init_gc (unsigned long, unsigned long, unsigned long, + unsigned long, unsigned long); + + +#ifdef DEBUG +void heap_check (void); +#endif + +#endif /* _gc_ctrl_ */ diff --git a/byterun/globroots.c b/byterun/globroots.c new file mode 100644 index 00000000..50d2446e --- /dev/null +++ b/byterun/globroots.c @@ -0,0 +1,129 @@ +/***********************************************************************/ +/* */ +/* 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: globroots.c,v 1.4 2001/12/07 13:39:28 xleroy Exp $ */ + +/* Registration of global memory roots */ + +#include "memory.h" +#include "misc.h" +#include "mlvalues.h" +#include "globroots.h" + +/* The set of global memory roots is represented as a skip list + (see William Pugh, "Skip lists: a probabilistic alternative to + balanced binary trees", Comm. ACM 33(6), 1990). */ + +/* Generate a random level for a new node: 0 with probability 3/4, + 1 with probability 3/16, 2 with probability 3/64, etc. + We use a simple linear congruential PRNG (see Knuth vol 2) instead + of random(), because we need exactly 32 bits of pseudo-random data + (i.e. 2 * (MAX_LEVEL + 1)). Moreover, the congruential PRNG + is faster and guaranteed to be deterministic (to reproduce bugs). */ + +static uint32 random_seed = 0; + +static int random_level(void) +{ + uint32 r; + int level = 0; + + /* Linear congruence with modulus = 2^32, multiplier = 69069 + (Knuth vol 2 p. 106, line 15 of table 1), additive = 25173. */ + r = random_seed = random_seed * 69069 + 25173; + /* Knuth (vol 2 p. 13) shows that the least significant bits are + "less random" than the most significant bits with a modulus of 2^m, + so consume most significant bits first */ + while ((r & 0xC0000000U) == 0xC0000000U) { level++; r = r << 2; } + Assert(level <= MAX_LEVEL); + return level; +} + +/* The initial global root list */ + +struct global_root_list caml_global_roots = { NULL, { NULL, }, 0 }; + +/* Register a global C root */ + +void register_global_root(value *r) +{ + struct global_root * update[MAX_LEVEL]; + struct global_root * e, * f; + int i, new_level; + + Assert (((long) r & 3) == 0); /* compact.c demands this (for now) */ + + /* Init "cursor" to list head */ + e = (struct global_root *) &caml_global_roots; + /* Find place to insert new node */ + for (i = caml_global_roots.level; i >= 0; i--) { + while (1) { + f = e->forward[i]; + if (f == NULL || f->root >= r) break; + e = f; + } + update[i] = e; + } + e = e->forward[0]; + /* If already present, don't do anything */ + if (e != NULL && e->root == r) return; + /* Insert additional element, updating list level if necessary */ + new_level = random_level(); + if (new_level > caml_global_roots.level) { + for (i = caml_global_roots.level + 1; i <= new_level; i++) + update[i] = (struct global_root *) &caml_global_roots; + caml_global_roots.level = new_level; + } + e = stat_alloc(sizeof(struct global_root) + + new_level * sizeof(struct global_root *)); + e->root = r; + for (i = 0; i <= new_level; i++) { + e->forward[i] = update[i]->forward[i]; + update[i]->forward[i] = e; + } +} + +/* Un-register a global C root */ + +void remove_global_root(value *r) +{ + struct global_root * update[MAX_LEVEL]; + struct global_root * e, * f; + int i; + + /* Init "cursor" to list head */ + e = (struct global_root *) &caml_global_roots; + /* Find element in list */ + for (i = caml_global_roots.level; i >= 0; i--) { + while (1) { + f = e->forward[i]; + if (f == NULL || f->root >= r) break; + e = f; + } + update[i] = e; + } + e = e->forward[0]; + /* If not found, nothing to do */ + if (e == NULL || e->root != r) return; + /* Rebuild list without node */ + for (i = 0; i <= caml_global_roots.level; i++) { + if (update[i]->forward[i] == e) + update[i]->forward[i] = e->forward[i]; + } + /* Reclaim list element */ + stat_free(e); + /* Down-correct list level */ + while (caml_global_roots.level > 0 && + caml_global_roots.forward[caml_global_roots.level] == NULL) + caml_global_roots.level--; +} diff --git a/byterun/globroots.h b/byterun/globroots.h new file mode 100644 index 00000000..081fdecb --- /dev/null +++ b/byterun/globroots.h @@ -0,0 +1,40 @@ +/***********************************************************************/ +/* */ +/* 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: globroots.h,v 1.2 2001/12/07 13:39:28 xleroy Exp $ */ + +/* Registration of global memory roots */ + +#ifndef _globroots_ +#define _globroots_ + +#include "mlvalues.h" + +/* Skip list structure */ + +struct global_root { + value * root; /* the address of the root */ + struct global_root * forward[1]; /* variable-length array */ +}; + +#define MAX_LEVEL 15 + +struct global_root_list { + value * root; /* dummy value for layout compatibility */ + struct global_root * forward[MAX_LEVEL]; /* forward chaining */ + int level; /* max used level */ +}; + +extern struct global_root_list caml_global_roots; + +#endif /* _globroots */ diff --git a/byterun/hash.c b/byterun/hash.c new file mode 100644 index 00000000..f27bd01f --- /dev/null +++ b/byterun/hash.c @@ -0,0 +1,156 @@ +/***********************************************************************/ +/* */ +/* 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: hash.c,v 1.19 2002/01/20 17:39:05 doligez Exp $ */ + +/* The generic hashing primitive */ + +#include "mlvalues.h" +#include "custom.h" +#include "memory.h" + +static unsigned long hash_accu; +static long hash_univ_limit, hash_univ_count; + +static void hash_aux(value obj); + +CAMLprim value hash_univ_param(value count, value limit, value obj) +{ + hash_univ_limit = Long_val(limit); + hash_univ_count = Long_val(count); + hash_accu = 0; + hash_aux(obj); + return Val_long(hash_accu & 0x3FFFFFFF); + /* The & has two purposes: ensure that the return value is positive + and give the same result on 32 bit and 64 bit architectures. */ +} + +#define Alpha 65599 +#define Beta 19 +#define Combine(new) (hash_accu = hash_accu * Alpha + (new)) +#define Combine_small(new) (hash_accu = hash_accu * Beta + (new)) + +static void hash_aux(value obj) +{ + unsigned char * p; + mlsize_t i, j; + tag_t tag; + + hash_univ_limit--; + if (hash_univ_count < 0 || hash_univ_limit < 0) return; + + again: + if (Is_long(obj)) { + hash_univ_count--; + Combine(Long_val(obj)); + return; + } + + /* Pointers into the heap are well-structured blocks. So are atoms. + We can inspect the block contents. */ + + Assert (Is_block (obj)); + if (Is_atom(obj) || Is_young(obj) || Is_in_heap(obj)) { + tag = Tag_val(obj); + switch (tag) { + case String_tag: + hash_univ_count--; + i = string_length(obj); + for (p = &Byte_u(obj, 0); i > 0; i--, p++) + Combine_small(*p); + break; + case Double_tag: + /* For doubles, we inspect their binary representation, LSB first. + The results are consistent among all platforms with IEEE floats. */ + hash_univ_count--; +#ifdef ARCH_BIG_ENDIAN + for (p = &Byte_u(obj, sizeof(double) - 1), i = sizeof(double); + i > 0; + p--, i--) +#else + for (p = &Byte_u(obj, 0), i = sizeof(double); + i > 0; + p++, i--) +#endif + Combine_small(*p); + break; + case Double_array_tag: + hash_univ_count--; + for (j = 0; j < Bosize_val(obj); j += sizeof(double)) { +#ifdef ARCH_BIG_ENDIAN + for (p = &Byte_u(obj, j + sizeof(double) - 1), i = sizeof(double); + i > 0; + p--, i--) +#else + for (p = &Byte_u(obj, j), i = sizeof(double); + i > 0; + p++, i--) +#endif + Combine_small(*p); + } + break; + case Abstract_tag: + /* We don't know anything about the contents of the block. + Better do nothing. */ + break; + case Infix_tag: + hash_aux(obj - Infix_offset_val(obj)); + break; + case Forward_tag: + obj = Forward_val (obj); + goto again; + case Object_tag: + hash_univ_count--; + Combine(Oid_val(obj)); + break; + case Custom_tag: + /* If no hashing function provided, do nothing */ + if (Custom_ops_val(obj)->hash != NULL) { + hash_univ_count--; + Combine(Custom_ops_val(obj)->hash(obj)); + } + break; + default: + hash_univ_count--; + Combine_small(tag); + i = Wosize_val(obj); + while (i != 0) { + i--; + hash_aux(Field(obj, i)); + } + break; + } + return; + } + + /* Otherwise, obj is a pointer outside the heap, to an object with + a priori unknown structure. Use its physical address as hash key. */ + Combine((long) obj); +} + +/* Hashing variant tags */ + +CAMLexport value hash_variant(char * tag) +{ + value accu; + /* Same hashing algorithm as in ../typing/btype.ml, function hash_variant */ + for (accu = Val_int(0); *tag != 0; tag++) + accu = Val_int(223 * Int_val(accu) + *((unsigned char *) tag)); +#ifdef ARCH_SIXTYFOUR + accu = accu & Val_long(0x7FFFFFFFL); +#endif + /* Force sign extension of bit 31 for compatibility between 32 and 64-bit + platforms */ + return (int32) accu; +} + diff --git a/byterun/instrtrace.c b/byterun/instrtrace.c new file mode 100644 index 00000000..f7baa120 --- /dev/null +++ b/byterun/instrtrace.c @@ -0,0 +1,77 @@ +/***********************************************************************/ +/* */ +/* 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: instrtrace.c,v 1.12 2003/05/26 12:41:53 xleroy Exp $ */ + +/* Trace the instructions executed */ + +#ifdef DEBUG + +#include +#include "instruct.h" +#include "misc.h" +#include "mlvalues.h" +#include "opnames.h" +#include "prims.h" + +extern code_t start_code; + +long icount = 0; + +void stop_here () {} + +int trace_flag = 0; + +void disasm_instr(pc) + code_t pc; +{ + int instr = *pc; + printf("%6ld %s", (long) (pc - start_code), + instr < 0 || instr > STOP ? "???" : names_of_instructions[instr]); + pc++; + switch(instr) { + /* Instructions with one integer operand */ + case PUSHACC: case ACC: case POP: case ASSIGN: + case PUSHENVACC: case ENVACC: case PUSH_RETADDR: case APPLY: + case APPTERM1: case APPTERM2: case APPTERM3: case RETURN: + case GRAB: case PUSHGETGLOBAL: case GETGLOBAL: case SETGLOBAL: + case PUSHATOM: case ATOM: case MAKEBLOCK1: case MAKEBLOCK2: + case MAKEBLOCK3: case MAKEFLOATBLOCK: + case GETFIELD: case SETFIELD: case GETFLOATFIELD: case SETFLOATFIELD: + case BRANCH: case BRANCHIF: case BRANCHIFNOT: case PUSHTRAP: + case CONSTINT: case PUSHCONSTINT: case OFFSETINT: case OFFSETREF: + case OFFSETCLOSURE: case PUSHOFFSETCLOSURE: + printf(" %d\n", pc[0]); break; + /* Instructions with two operands */ + case APPTERM: case CLOSURE: case CLOSUREREC: case PUSHGETGLOBALFIELD: + case GETGLOBALFIELD: case MAKEBLOCK: + case BEQ: case BNEQ: case BLTINT: case BLEINT: case BGTINT: case BGEINT: + case BULTINT: case BUGEINT: + printf(" %d, %d\n", pc[0], pc[1]); break; + /* Instructions with a C primitive as operand */ + case C_CALLN: + printf(" %d,", pc[0]); pc++; + /* fallthrough */ + case C_CALL1: case C_CALL2: case C_CALL3: case C_CALL4: case C_CALL5: + if (pc[0] < 0 || pc[0] >= prim_name_table.size) + printf(" unknown primitive %d\n", pc[0]); + else + printf(" %s\n", (char *) prim_name_table.contents[pc[0]]); + break; + default: + printf("\n"); + } + fflush (stdout); +} + +#endif diff --git a/byterun/instrtrace.h b/byterun/instrtrace.h new file mode 100644 index 00000000..67c1eb3d --- /dev/null +++ b/byterun/instrtrace.h @@ -0,0 +1,31 @@ +/***********************************************************************/ +/* */ +/* 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: instrtrace.h,v 1.6 2001/12/07 13:39:29 xleroy Exp $ */ + +/* Trace the instructions executed */ + +#ifndef _instrtrace_ +#define _instrtrace_ + + +#include "mlvalues.h" +#include "misc.h" + +extern int trace_flag; +extern long icount; +void stop_here (void); +void disasm_instr (code_t pc); + + +#endif diff --git a/byterun/instruct.h b/byterun/instruct.h new file mode 100644 index 00000000..af4a5d8d --- /dev/null +++ b/byterun/instruct.h @@ -0,0 +1,55 @@ +/***********************************************************************/ +/* */ +/* 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: instruct.h,v 1.18 2001/12/07 13:39:29 xleroy Exp $ */ + +/* The instruction set. */ + +enum instructions { + ACC0, ACC1, ACC2, ACC3, ACC4, ACC5, ACC6, ACC7, + ACC, PUSH, + PUSHACC0, PUSHACC1, PUSHACC2, PUSHACC3, + PUSHACC4, PUSHACC5, PUSHACC6, PUSHACC7, + PUSHACC, POP, ASSIGN, + ENVACC1, ENVACC2, ENVACC3, ENVACC4, ENVACC, + PUSHENVACC1, PUSHENVACC2, PUSHENVACC3, PUSHENVACC4, PUSHENVACC, + PUSH_RETADDR, APPLY, APPLY1, APPLY2, APPLY3, + APPTERM, APPTERM1, APPTERM2, APPTERM3, + RETURN, RESTART, GRAB, + CLOSURE, CLOSUREREC, + OFFSETCLOSUREM2, OFFSETCLOSURE0, OFFSETCLOSURE2, OFFSETCLOSURE, + PUSHOFFSETCLOSUREM2, PUSHOFFSETCLOSURE0, + PUSHOFFSETCLOSURE2, PUSHOFFSETCLOSURE, + GETGLOBAL, PUSHGETGLOBAL, GETGLOBALFIELD, PUSHGETGLOBALFIELD, SETGLOBAL, + ATOM0, ATOM, PUSHATOM0, PUSHATOM, + MAKEBLOCK, MAKEBLOCK1, MAKEBLOCK2, MAKEBLOCK3, MAKEFLOATBLOCK, + GETFIELD0, GETFIELD1, GETFIELD2, GETFIELD3, GETFIELD, GETFLOATFIELD, + SETFIELD0, SETFIELD1, SETFIELD2, SETFIELD3, SETFIELD, SETFLOATFIELD, + VECTLENGTH, GETVECTITEM, SETVECTITEM, + GETSTRINGCHAR, SETSTRINGCHAR, + BRANCH, BRANCHIF, BRANCHIFNOT, SWITCH, BOOLNOT, + PUSHTRAP, POPTRAP, RAISE, CHECK_SIGNALS, + C_CALL1, C_CALL2, C_CALL3, C_CALL4, C_CALL5, C_CALLN, + CONST0, CONST1, CONST2, CONST3, CONSTINT, + PUSHCONST0, PUSHCONST1, PUSHCONST2, PUSHCONST3, PUSHCONSTINT, + NEGINT, ADDINT, SUBINT, MULINT, DIVINT, MODINT, + ANDINT, ORINT, XORINT, LSLINT, LSRINT, ASRINT, + EQ, NEQ, LTINT, LEINT, GTINT, GEINT, + OFFSETINT, OFFSETREF, ISINT, + GETMETHOD, + BEQ, BNEQ, BLTINT, BLEINT, BGTINT, BGEINT, + ULTINT, UGEINT, + BULTINT, BUGEINT, + STOP, + EVENT, BREAK +}; diff --git a/byterun/int64_emul.h b/byterun/int64_emul.h new file mode 100644 index 00000000..b63dde20 --- /dev/null +++ b/byterun/int64_emul.h @@ -0,0 +1,259 @@ +/***********************************************************************/ +/* */ +/* 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: int64_emul.h,v 1.1 2002/05/25 08:32:53 xleroy Exp $ */ + +/* Software emulation of 64-bit integer arithmetic, for C compilers + that do not support it. */ + +#include + +/* Unsigned comparison */ +static int I64_ucompare(uint64 x, uint64 y) +{ + if (x.h > y.h) return 1; + if (x.h < y.h) return -1; + if (x.l > y.l) return 1; + if (x.l < y.l) return -1; + return 0; +} + +/* Signed comparison */ +static int I64_compare(int64 x, int64 y) +{ + if ((int32)x.h > (int32)y.h) return 1; + if ((int32)x.h < (int32)y.h) return -1; + if (x.l > y.l) return 1; + if (x.l < y.l) return -1; + return 0; +} + +/* Negation */ +static int64 I64_neg(int64 x) +{ + int64 res; + res.l = -x.l; + res.h = ~x.h; + if (res.l == 0) res.h++; + return res; +} + +/* Addition */ +static int64 I64_add(int64 x, int64 y) +{ + int64 res; + res.l = x.l + y.l; + res.h = x.h + y.h; + if (res.l < x.l) res.h++; + return res; +} + +/* Subtraction */ +static int64 I64_sub(int64 x, int64 y) +{ + int64 res; + res.l = x.l - y.l; + res.h = x.h - y.h; + if (x.l < y.l) res.h--; + return res; +} + +/* Multiplication */ +static int64 I64_mul(int64 x, int64 y) +{ + int64 res; + uint32 prod00 = (x.l & 0xFFFF) * (y.l & 0xFFFF); + uint32 prod10 = (x.l >> 16) * (y.l & 0xFFFF); + uint32 prod01 = (x.l & 0xFFFF) * (y.l >> 16); + uint32 prod11 = (x.l >> 16) * (y.l >> 16); + res.l = prod00; + res.h = prod11 + (prod01 >> 16) + (prod10 >> 16); + prod01 = prod01 << 16; res.l += prod01; if (res.l < prod01) res.h++; + prod10 = prod10 << 16; res.l += prod10; if (res.l < prod10) res.h++; + res.h += x.l * y.h + x.h * y.l; + return res; +} + +#define I64_is_zero(x) (((x).l | (x).h) == 0) + +#define I64_is_negative(x) ((int32) (x).h < 0) + +/* Bitwise operations */ +static int64 I64_and(int64 x, int64 y) +{ + int64 res; + res.l = x.l & y.l; + res.h = x.h & y.h; + return res; +} + +static int64 I64_or(int64 x, int64 y) +{ + int64 res; + res.l = x.l | y.l; + res.h = x.h | y.h; + return res; +} + +static int64 I64_xor(int64 x, int64 y) +{ + int64 res; + res.l = x.l ^ y.l; + res.h = x.h ^ y.h; + return res; +} + +/* Shifts */ +static int64 I64_lsl(int64 x, int s) +{ + int64 res; + s = s & 63; + if (s == 0) return x; + if (s < 32) { + res.l = x.l << s; + res.h = (x.h << s) | (x.l >> (32 - s)); + } else { + res.l = 0; + res.h = x.l << (s - 32); + } + return res; +} + +static int64 I64_lsr(int64 x, int s) +{ + int64 res; + s = s & 63; + if (s == 0) return x; + if (s < 32) { + res.l = (x.l >> s) | (x.h << (32 - s)); + res.h = x.h >> s; + } else { + res.l = x.h >> (s - 32); + res.h = 0; + } + return res; +} + +static int64 I64_asr(int64 x, int s) +{ + int64 res; + s = s & 63; + if (s == 0) return x; + if (s < 32) { + res.l = (x.l >> s) | (x.h << (32 - s)); + res.h = (int32) x.h >> s; + } else { + res.l = (int32) x.h >> (s - 32); + res.h = (int32) x.h >> 31; + } + return res; +} + +/* Division and modulus */ + +#define I64_SHL1(x) x.h = (x.h << 1) | (x.l >> 31); x.l <<= 1 +#define I64_SHR1(x) x.l = (x.l >> 1) | (x.h << 31); x.h >>= 1 + +static void I64_udivmod(uint64 modulus, uint64 divisor, + uint64 * quo, uint64 * mod) +{ + int64 quotient, mask; + int cmp; + + quotient.h = 0; quotient.l = 0; + mask.h = 0; mask.l = 1; + while ((int32) divisor.h >= 0) { + cmp = I64_ucompare(divisor, modulus); + I64_SHL1(divisor); + I64_SHL1(mask); + if (cmp >= 0) break; + } + while (mask.l | mask.h) { + if (I64_ucompare(modulus, divisor) >= 0) { + quotient.h |= mask.h; quotient.l |= mask.l; + modulus = I64_sub(modulus, divisor); + } + I64_SHR1(mask); + I64_SHR1(divisor); + } + *quo = quotient; + *mod = modulus; +} + +static int64 I64_div(int64 x, int64 y) +{ + int64 q, r; + int32 sign; + + sign = x.h ^ y.h; + if ((int32) x.h < 0) x = I64_neg(x); + if ((int32) y.h < 0) y = I64_neg(y); + I64_udivmod(x, y, &q, &r); + if (sign < 0) q = I64_neg(q); + return q; +} + +static int64 I64_mod(int64 x, int64 y) +{ + int64 q, r; + int32 sign; + + sign = x.h; + if ((int32) x.h < 0) x = I64_neg(x); + if ((int32) y.h < 0) y = I64_neg(y); + I64_udivmod(x, y, &q, &r); + if (sign < 0) r = I64_neg(r); + return r; +} + +/* Coercions */ + +static int64 I64_of_int32(int32 x) +{ + int64 res; + res.l = x; + res.h = x >> 31; + return res; +} + +#define I64_to_int32(x) ((int32) (x).l) + +/* Note: we assume sizeof(long) = 4 here, which is true otherwise + autoconfiguration would have selected native 64-bit integers */ +#define I64_of_long I64_of_int32 +#define I64_to_long I64_to_int32 + +static double I64_to_double(int64 x) +{ + double res; + int32 sign = x.h; + if (sign < 0) x = I64_neg(x); + res = ldexp((double) x.h, 32) + x.l; + if (sign < 0) res = -res; + return res; +} + +static int64 I64_of_double(double f) +{ + int64 res; + double frac, integ; + int neg; + + neg = (f < 0); + f = fabs(f); + frac = modf(ldexp(f, -32), &integ); + res.h = (uint32) integ; + res.l = (uint32) ldexp(frac, 32); + if (neg) res = I64_neg(res); + return res; +} diff --git a/byterun/int64_format.h b/byterun/int64_format.h new file mode 100644 index 00000000..faf57386 --- /dev/null +++ b/byterun/int64_format.h @@ -0,0 +1,102 @@ +/***********************************************************************/ +/* */ +/* 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: int64_format.h,v 1.1 2002/05/25 08:32:53 xleroy Exp $ */ + +/* printf-like formatting of 64-bit integers, in case the C library + printf() function does not support them. */ + +static void I64_format(char * buffer, char * fmt, int64 x) +{ + static char conv_lower[] = "0123456789abcdef"; + static char conv_upper[] = "0123456789ABCDEF"; + char rawbuffer[24]; + char justify, signstyle, filler, alternate, signedconv; + int base, width, sign, i, rawlen; + char * cvtbl; + char * p, * r; + int64 wbase, digit; + + /* Parsing of format */ + justify = '+'; + signstyle = '-'; + filler = ' '; + alternate = 0; + base = 0; + signedconv = 0; + width = 0; + cvtbl = conv_lower; + for (p = fmt; *p != 0; p++) { + switch (*p) { + case '-': + justify = '-'; break; + case '+': case ' ': + signstyle = *p; break; + case '0': + filler = '0'; break; + case '#': + alternate = 1; break; + case '1': case '2': case '3': case '4': case '5': + case '6': case '7': case '8': case '9': + width = atoi(p); + while (*p >= '0' && *p <= '9') p++; + break; + case 'd': case 'i': + signedconv = 1; /* fallthrough */ + case 'u': + base = 10; break; + case 'x': + base = 16; break; + case 'X': + base = 16; cvtbl = conv_upper; break; + case 'o': + base = 8; break; + } + } + if (base == 0) { buffer[0] = 0; return; } + /* Do the conversion */ + sign = 1; + if (signedconv && I64_is_negative(x)) { sign = -1; x = I64_neg(x); } + r = rawbuffer + sizeof(rawbuffer); + wbase = I64_of_int32(base); + do { + I64_udivmod(x, wbase, &x, &digit); + *--r = cvtbl[I64_to_int32(digit)]; + } while (! I64_is_zero(x)); + rawlen = rawbuffer + sizeof(rawbuffer) - r; + /* Adjust rawlen to reflect additional chars (sign, etc) */ + if (signedconv && (sign < 0 || signstyle != '-')) rawlen++; + if (alternate) { + if (base == 8) rawlen += 1; + if (base == 16) rawlen += 2; + } + /* Do the formatting */ + p = buffer; + if (justify == '+' && filler == ' ') { + for (i = rawlen; i < width; i++) *p++ = ' '; + } + if (signedconv) { + if (sign < 0) *p++ = '-'; + else if (signstyle != '-') *p++ = signstyle; + } + if (alternate && base == 8) *p++ = '0'; + if (alternate && base == 16) { *p++ = '0'; *p++ = 'x'; } + if (justify == '+' && filler == '0') { + for (i = rawlen; i < width; i++) *p++ = '0'; + } + while (r < rawbuffer + sizeof(rawbuffer)) *p++ = *r++; + if (justify == '-') { + for (i = rawlen; i < width; i++) *p++ = ' '; + } + *p = 0; +} diff --git a/byterun/int64_native.h b/byterun/int64_native.h new file mode 100644 index 00000000..7c75410c --- /dev/null +++ b/byterun/int64_native.h @@ -0,0 +1,44 @@ +/***********************************************************************/ +/* */ +/* 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: int64_native.h,v 1.2 2003/04/01 08:46:38 xleroy Exp $ */ + +/* Wrapper macros around native 64-bit integer arithmetic, + so that it has the same interface as the software emulation + provided in int64_emul.h */ + +#define I64_compare(x,y) (((x) > (y)) - ((x) < (y))) +#define I64_neg(x) (-(x)) +#define I64_add(x,y) ((x) + (y)) +#define I64_sub(x,y) ((x) - (y)) +#define I64_mul(x,y) ((x) * (y)) +#define I64_is_zero(x) ((x) == 0) +#define I64_is_negative(x) ((x) < 0) +#define I64_div(x,y) ((x) / (y)) +#define I64_mod(x,y) ((x) % (y)) +#define I64_udivmod(x,y,quo,rem) \ + (*(rem) = (uint64)(x) % (uint64)(y), \ + *(quo) = (uint64)(x) / (uint64)(y)) +#define I64_and(x,y) ((x) & (y)) +#define I64_or(x,y) ((x) | (y)) +#define I64_xor(x,y) ((x) ^ (y)) +#define I64_lsl(x,y) ((x) << (y)) +#define I64_asr(x,y) ((x) >> (y)) +#define I64_lsr(x,y) ((uint64)(x) >> (y)) +#define I64_to_long(x) ((long) (x)) +#define I64_of_long(x) ((int64) (x)) +#define I64_to_int32(x) ((int32) (x)) +#define I64_of_int32(x) ((int64) (x)) +#define I64_to_double(x) ((double)(x)) +#define I64_of_double(x) ((int64)(x)) + diff --git a/byterun/intern.c b/byterun/intern.c new file mode 100644 index 00000000..2e13c247 --- /dev/null +++ b/byterun/intern.c @@ -0,0 +1,706 @@ +/***********************************************************************/ +/* */ +/* 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: intern.c,v 1.50 2002/12/12 18:59:11 doligez Exp $ */ + +/* Structured input, compact format */ + +#include +#include "alloc.h" +#include "custom.h" +#include "fail.h" +#include "gc.h" +#include "intext.h" +#include "io.h" +#include "memory.h" +#include "mlvalues.h" +#include "misc.h" +#include "reverse.h" + +static unsigned char * intern_src; +/* Reading pointer in block holding input data. */ + +static unsigned char * intern_input; +/* Pointer to beginning of block holding input data. + Meaningful only if intern_input_malloced = 1. */ + +static int intern_input_malloced; +/* 1 if intern_input was allocated by stat_alloc() + and needs stat_free() on error, 0 otherwise. */ + +static header_t * intern_dest; +/* Writing pointer in destination block */ + +static char * intern_extra_block; +/* If non-NULL, point to new heap chunk allocated with alloc_for_heap. */ + +static asize_t obj_counter; +/* Count how many objects seen so far */ + +static value * intern_obj_table; +/* The pointers to objects already seen */ + +static unsigned int intern_color; +/* Color to assign to newly created headers */ + +static header_t intern_header; +/* Original header of the destination block. + Meaningful only if intern_extra_block is NULL. */ + +static value intern_block; +/* Point to the heap block allocated as destination block. + Meaningful only if intern_extra_block is NULL. */ + +#define Sign_extend_shift ((sizeof(long) - 1) * 8) +#define Sign_extend(x) (((long)(x) << Sign_extend_shift) >> Sign_extend_shift) + +#define read8u() (*intern_src++) +#define read8s() Sign_extend(*intern_src++) +#define read16u() \ + (intern_src += 2, \ + (intern_src[-2] << 8) + intern_src[-1]) +#define read16s() \ + (intern_src += 2, \ + (Sign_extend(intern_src[-2]) << 8) + intern_src[-1]) +#define read32u() \ + (intern_src += 4, \ + (intern_src[-4] << 24) + (intern_src[-3] << 16) + \ + (intern_src[-2] << 8) + intern_src[-1]) +#define read32s() \ + (intern_src += 4, \ + (Sign_extend(intern_src[-4]) << 24) + (intern_src[-3] << 16) + \ + (intern_src[-2] << 8) + intern_src[-1]) + +#ifdef ARCH_SIXTYFOUR +static long read64s(void) +{ + long res; + int i; + res = 0; + for (i = 0; i < 8; i++) res = (res << 8) + intern_src[i]; + intern_src += 8; + return res; +} +#endif + +#define readblock(dest,len) \ + (memmove((dest), intern_src, (len)), intern_src += (len)) + +static void intern_cleanup(void) +{ + if (intern_input_malloced) stat_free(intern_input); + if (intern_obj_table != NULL) stat_free(intern_obj_table); + if (intern_extra_block != NULL) { + /* free newly allocated heap chunk */ + free_for_heap(intern_extra_block); + } else if (intern_block != 0) { + /* restore original header for heap block, otherwise GC is confused */ + Hd_val(intern_block) = intern_header; + } +} + +static void intern_rec(value *dest) +{ + unsigned int code; + tag_t tag; + mlsize_t size, len, ofs_ind; + value v, clos; + asize_t ofs; + header_t header; + char cksum[16]; + struct custom_operations * ops; + + tailcall: + code = read8u(); + if (code >= PREFIX_SMALL_INT) { + if (code >= PREFIX_SMALL_BLOCK) { + /* Small block */ + tag = code & 0xF; + size = (code >> 4) & 0x7; + read_block: + if (size == 0) { + v = Atom(tag); + } else { + v = Val_hp(intern_dest); + *dest = v; + if (intern_obj_table != NULL) intern_obj_table[obj_counter++] = v; + dest = (value *) (intern_dest + 1); + *intern_dest = Make_header(size, tag, intern_color); + intern_dest += 1 + size; + for(/*nothing*/; size > 1; size--, dest++) + intern_rec(dest); + goto tailcall; + } + } else { + /* Small integer */ + v = Val_int(code & 0x3F); + } + } else { + if (code >= PREFIX_SMALL_STRING) { + /* Small string */ + len = (code & 0x1F); + read_string: + size = (len + sizeof(value)) / sizeof(value); + v = Val_hp(intern_dest); + if (intern_obj_table != NULL) intern_obj_table[obj_counter++] = v; + *intern_dest = Make_header(size, String_tag, intern_color); + intern_dest += 1 + size; + Field(v, size - 1) = 0; + ofs_ind = Bsize_wsize(size) - 1; + Byte(v, ofs_ind) = ofs_ind - len; + readblock(String_val(v), len); + } else { + switch(code) { + case CODE_INT8: + v = Val_long(read8s()); + break; + case CODE_INT16: + v = Val_long(read16s()); + break; + case CODE_INT32: + v = Val_long(read32s()); + break; + case CODE_INT64: +#ifdef ARCH_SIXTYFOUR + v = Val_long(read64s()); + break; +#else + intern_cleanup(); + failwith("input_value: integer too large"); + break; +#endif + case CODE_SHARED8: + ofs = read8u(); + read_shared: + Assert (ofs > 0); + Assert (ofs <= obj_counter); + Assert (intern_obj_table != NULL); + v = intern_obj_table[obj_counter - ofs]; + break; + case CODE_SHARED16: + ofs = read16u(); + goto read_shared; + case CODE_SHARED32: + ofs = read32u(); + goto read_shared; + case CODE_BLOCK32: + header = (header_t) read32u(); + tag = Tag_hd(header); + size = Wosize_hd(header); + goto read_block; + case CODE_BLOCK64: +#ifdef ARCH_SIXTYFOUR + header = (header_t) read64s(); + tag = Tag_hd(header); + size = Wosize_hd(header); + goto read_block; +#else + intern_cleanup(); + failwith("input_value: data block too large"); + break; +#endif + case CODE_STRING8: + len = read8u(); + goto read_string; + case CODE_STRING32: + len = read32u(); + goto read_string; + case CODE_DOUBLE_LITTLE: + case CODE_DOUBLE_BIG: + if (sizeof(double) != 8) { + intern_cleanup(); + invalid_argument("input_value: non-standard floats"); + } + v = Val_hp(intern_dest); + if (intern_obj_table != NULL) intern_obj_table[obj_counter++] = v; + *intern_dest = Make_header(Double_wosize, Double_tag, intern_color); + intern_dest += 1 + Double_wosize; + readblock((char *) v, 8); +#if ARCH_FLOAT_ENDIANNESS == 0x76543210 + if (code != CODE_DOUBLE_BIG) Reverse_64(v, v); +#elif ARCH_FLOAT_ENDIANNESS == 0x01234567 + if (code != CODE_DOUBLE_LITTLE) Reverse_64(v, v); +#else + if (code == CODE_DOUBLE_LITTLE) + Permute_64(v, ARCH_FLOAT_ENDIANNESS, v, 0x01234567) + else + Permute_64(v, ARCH_FLOAT_ENDIANNESS, v, 0x76543210); +#endif + break; + case CODE_DOUBLE_ARRAY8_LITTLE: + case CODE_DOUBLE_ARRAY8_BIG: + len = read8u(); + read_double_array: + if (sizeof(double) != 8) { + intern_cleanup(); + invalid_argument("input_value: non-standard floats"); + } + size = len * Double_wosize; + v = Val_hp(intern_dest); + if (intern_obj_table != NULL) intern_obj_table[obj_counter++] = v; + *intern_dest = Make_header(size, Double_array_tag, intern_color); + intern_dest += 1 + size; + readblock((char *) v, len * 8); +#if ARCH_FLOAT_ENDIANNESS == 0x76543210 + if (code != CODE_DOUBLE_ARRAY8_BIG && + code != CODE_DOUBLE_ARRAY32_BIG) { + mlsize_t i; + for (i = 0; i < len; i++) Reverse_64((value)((double *)v + i), + (value)((double *)v + i)); + } +#elif ARCH_FLOAT_ENDIANNESS == 0x01234567 + if (code != CODE_DOUBLE_ARRAY8_LITTLE && + code != CODE_DOUBLE_ARRAY32_LITTLE) { + mlsize_t i; + for (i = 0; i < len; i++) Reverse_64((value)((double *)v + i), + (value)((double *)v + i)); + } +#else + if (code == CODE_DOUBLE_ARRAY8_LITTLE || + code == CODE_DOUBLE_ARRAY32_LITTLE) { + mlsize_t i; + for (i = 0; i < len; i++) + Permute_64((value)((double *)v + i), ARCH_FLOAT_ENDIANNESS, + (value)((double *)v + i), 0x01234567); + } else { + mlsize_t i; + for (i = 0; i < len; i++) + Permute_64((value)((double *)v + i), ARCH_FLOAT_ENDIANNESS, + (value)((double *)v + i), 0x76543210); + } +#endif + break; + case CODE_DOUBLE_ARRAY32_LITTLE: + case CODE_DOUBLE_ARRAY32_BIG: + len = read32u(); + goto read_double_array; + case CODE_CODEPOINTER: + ofs = read32u(); + readblock(cksum, 16); + if (memcmp(cksum, code_checksum(), 16) != 0) { + intern_cleanup(); + failwith("input_value: code mismatch"); + } + v = (value) (code_area_start + ofs); + break; + case CODE_INFIXPOINTER: + ofs = read32u(); + intern_rec(&clos); + v = clos + ofs; + break; + case CODE_CUSTOM: + ops = find_custom_operations((char *) intern_src); + if (ops == NULL) { + intern_cleanup(); + failwith("input_value: unknown custom block identifier"); + } + while (*intern_src++ != 0) /*nothing*/; /*skip identifier*/ + size = ops->deserialize((void *) (intern_dest + 2)); + size = 1 + (size + sizeof(value) - 1) / sizeof(value); + v = Val_hp(intern_dest); + if (intern_obj_table != NULL) intern_obj_table[obj_counter++] = v; + *intern_dest = Make_header(size, Custom_tag, intern_color); + Custom_ops_val(v) = ops; + intern_dest += 1 + size; + break; + default: + intern_cleanup(); + failwith("input_value: ill-formed message"); + } + } + } + *dest = v; +} + +static void intern_alloc(mlsize_t whsize, mlsize_t num_objects) +{ + mlsize_t wosize; + + if (whsize == 0) { + intern_obj_table = NULL; + intern_extra_block = NULL; + intern_block = 0; + return; + } + wosize = Wosize_whsize(whsize); + if (wosize > Max_wosize) { + /* Round desired size up to next page */ + asize_t request = + ((Bsize_wsize(whsize) + Page_size - 1) >> Page_log) << Page_log; + intern_extra_block = alloc_for_heap(request); + if (intern_extra_block == NULL) raise_out_of_memory(); + intern_color = allocation_color(intern_extra_block); + intern_dest = (header_t *) intern_extra_block; + } else { + /* this is a specialised version of alloc from alloc.c */ + if (wosize == 0){ + intern_block = Atom (String_tag); + }else if (wosize <= Max_young_wosize){ + intern_block = alloc_small (wosize, String_tag); + }else{ + intern_block = alloc_shr (wosize, String_tag); + /* do not do the urgent_gc check here because it might darken + intern_block into gray and break the Assert 3 lines down */ + } + intern_header = Hd_val(intern_block); + intern_color = Color_hd(intern_header); + Assert (intern_color == Caml_white || intern_color == Caml_black); + intern_dest = (header_t *) Hp_val(intern_block); + intern_extra_block = NULL; + } + obj_counter = 0; + if (num_objects > 0) + intern_obj_table = (value *) stat_alloc(num_objects * sizeof(value)); + else + intern_obj_table = NULL; +} + +static void intern_add_to_heap(mlsize_t whsize) +{ + /* Add new heap chunk to heap if needed */ + if (intern_extra_block != NULL) { + /* If heap chunk not filled totally, build free block at end */ + asize_t request = + ((Bsize_wsize(whsize) + Page_size - 1) >> Page_log) << Page_log; + header_t * end_extra_block = + (header_t *) intern_extra_block + Wsize_bsize(request); + Assert(intern_dest <= end_extra_block); + if (intern_dest < end_extra_block){ + make_free_blocks ((value *) intern_dest, end_extra_block - intern_dest, + 0); + } + add_to_heap(intern_extra_block); + } +} + +value input_val(struct channel *chan) +{ + uint32 magic; + mlsize_t block_len, num_objects, size_32, size_64, whsize; + char * block; + value res; + + if (! channel_binary_mode(chan)) + failwith("input_value: not a binary channel"); + magic = getword(chan); + if (magic != Intext_magic_number) failwith("input_value: bad object"); + block_len = getword(chan); + num_objects = getword(chan); + size_32 = getword(chan); + size_64 = getword(chan); + /* Read block from channel */ + block = stat_alloc(block_len); + /* During really_getblock, concurrent input_val operations can take + place (via signal handlers or context switching in systhreads), + and intern_input may change. So, wait until really_getblock + is over before using intern_input and the other global vars. */ + if (really_getblock(chan, block, block_len) == 0) { + stat_free(block); + failwith("input_value: truncated object"); + } + intern_input = (unsigned char *) block; + intern_input_malloced = 1; + intern_src = intern_input; + /* Allocate result */ +#ifdef ARCH_SIXTYFOUR + whsize = size_64; +#else + whsize = size_32; +#endif + intern_alloc(whsize, num_objects); + /* Fill it in */ + intern_rec(&res); + intern_add_to_heap(whsize); + /* Free everything */ + stat_free(intern_input); + if (intern_obj_table != NULL) stat_free(intern_obj_table); + return res; +} + +CAMLprim value input_value(value vchan) +{ + CAMLparam1 (vchan); + struct channel * chan = Channel(vchan); + CAMLlocal1 (res); + + Lock(chan); + res = input_val(chan); + Unlock(chan); + CAMLreturn (res); +} + +CAMLexport value input_val_from_string(value str, long int ofs) +{ + CAMLparam1 (str); + mlsize_t num_objects, size_32, size_64, whsize; + CAMLlocal1 (obj); + + intern_src = &Byte_u(str, ofs + 2*4); + intern_input_malloced = 0; + num_objects = read32u(); + size_32 = read32u(); + size_64 = read32u(); + /* Allocate result */ +#ifdef ARCH_SIXTYFOUR + whsize = size_64; +#else + whsize = size_32; +#endif + intern_alloc(whsize, num_objects); + intern_src = &Byte_u(str, ofs + 5*4); /* If a GC occurred */ + /* Fill it in */ + intern_rec(&obj); + intern_add_to_heap(whsize); + /* Free everything */ + if (intern_obj_table != NULL) stat_free(intern_obj_table); + CAMLreturn (obj); +} + +CAMLprim value input_value_from_string(value str, value ofs) +{ + return input_val_from_string(str, Long_val(ofs)); +} + +static value input_val_from_block(void) +{ + mlsize_t num_objects, size_32, size_64, whsize; + value obj; + + num_objects = read32u(); + size_32 = read32u(); + size_64 = read32u(); + /* Allocate result */ +#ifdef ARCH_SIXTYFOUR + whsize = size_64; +#else + whsize = size_32; +#endif + intern_alloc(whsize, num_objects); + /* Fill it in */ + intern_rec(&obj); + intern_add_to_heap(whsize); + /* Free internal data structures */ + if (intern_obj_table != NULL) stat_free(intern_obj_table); + return obj; +} + +CAMLexport value input_value_from_malloc(char * data, long ofs) +{ + mlsize_t magic, block_len; + value obj; + + intern_input = (unsigned char *) data; + intern_src = intern_input + ofs; + intern_input_malloced = 1; + magic = read32u(); + if (magic != Intext_magic_number) + failwith("input_value_from_malloc: bad object"); + block_len = read32u(); + obj = input_val_from_block(); + /* Free the input */ + stat_free(intern_input); + return obj; +} + +CAMLexport value input_value_from_block(char * data, long len) +{ + mlsize_t magic, block_len; + value obj; + + intern_input = (unsigned char *) data; + intern_src = intern_input; + intern_input_malloced = 0; + magic = read32u(); + if (magic != Intext_magic_number) + failwith("input_value_from_block: bad object"); + block_len = read32u(); + if (5*4 + block_len > len) + failwith("input_value_from_block: bad block length"); + obj = input_val_from_block(); + return obj; +} + +CAMLprim value marshal_data_size(value buff, value ofs) +{ + uint32 magic; + mlsize_t block_len; + + intern_src = &Byte_u(buff, Long_val(ofs)); + intern_input_malloced = 0; + magic = read32u(); + if (magic != Intext_magic_number) failwith("Marshal.data_size: bad object"); + block_len = read32u(); + return Val_long(block_len); +} + +/* Return an MD5 checksum of the code area */ + +#ifdef NATIVE_CODE + +#include "md5.h" + +unsigned char * code_checksum() +{ + static unsigned char checksum[16]; + static int checksum_computed = 0; + + if (! checksum_computed) { + struct MD5Context ctx; + MD5Init(&ctx); + MD5Update(&ctx, + (unsigned char *) code_area_start, + code_area_end - code_area_start); + MD5Final(checksum, &ctx); + checksum_computed = 1; + } + return checksum; +} + +#else + +#include "fix_code.h" + +unsigned char * code_checksum(void) +{ + return code_md5; +} + +#endif + +/* Functions for writing user-defined marshallers */ + +CAMLexport int deserialize_uint_1(void) +{ + return read8u(); +} + +CAMLexport int deserialize_sint_1(void) +{ + return read8s(); +} + +CAMLexport int deserialize_uint_2(void) +{ + return read16u(); +} + +CAMLexport int deserialize_sint_2(void) +{ + return read16s(); +} + +CAMLexport uint32 deserialize_uint_4(void) +{ + return read32u(); +} + +CAMLexport int32 deserialize_sint_4(void) +{ + return read32s(); +} + +CAMLexport uint64 deserialize_uint_8(void) +{ + uint64 i; + deserialize_block_8(&i, 1); + return i; +} + +CAMLexport int64 deserialize_sint_8(void) +{ + int64 i; + deserialize_block_8(&i, 1); + return i; +} + +CAMLexport float deserialize_float_4(void) +{ + float f; + deserialize_block_4(&f, 1); + return f; +} + +CAMLexport double deserialize_float_8(void) +{ + double f; + deserialize_block_float_8(&f, 1); + return f; +} + +CAMLexport void deserialize_block_1(void * data, long len) +{ + memmove(data, intern_src, len); + intern_src += len; +} + +CAMLexport void deserialize_block_2(void * data, long len) +{ + unsigned char * p, * q; +#ifndef ARCH_BIG_ENDIAN + for (p = intern_src, q = data; len > 0; len--, p += 2, q += 2) + Reverse_16(q, p); + intern_src = p; +#else + memmove(data, intern_src, len * 2); + intern_src += len * 2; +#endif +} + +CAMLexport void deserialize_block_4(void * data, long len) +{ + unsigned char * p, * q; +#ifndef ARCH_BIG_ENDIAN + for (p = intern_src, q = data; len > 0; len--, p += 4, q += 4) + Reverse_32(q, p); + intern_src = p; +#else + memmove(data, intern_src, len * 4); + intern_src += len * 4; +#endif +} + +CAMLexport void deserialize_block_8(void * data, long len) +{ + unsigned char * p, * q; +#ifndef ARCH_BIG_ENDIAN + for (p = intern_src, q = data; len > 0; len--, p += 8, q += 8) + Reverse_64(q, p); + intern_src = p; +#else + memmove(data, intern_src, len * 8); + intern_src += len * 8; +#endif +} + +CAMLexport void deserialize_block_float_8(void * data, long len) +{ + unsigned char * p, * q; +#if ARCH_FLOAT_ENDIANNESS == 0x01234567 + memmove(data, intern_src, len * 8); + intern_src += len * 8; +#elif ARCH_FLOAT_ENDIANNESS == 0x76543210 + for (p = intern_src, q = data; len > 0; len--, p += 8, q += 8) + Reverse_64(q, p); + intern_src = p; +#else + for (p = intern_src, q = data; len > 0; len--, p += 8, q += 8) + Permute_64(q, ARCH_FLOAT_ENDIANNESS, p, 0x01234567); + intern_src = p; +#endif +} + +CAMLexport void deserialize_error(char * msg) +{ + intern_cleanup(); + failwith(msg); +} diff --git a/byterun/interp.c b/byterun/interp.c new file mode 100644 index 00000000..f7bb50d4 --- /dev/null +++ b/byterun/interp.c @@ -0,0 +1,1053 @@ +/***********************************************************************/ +/* */ +/* 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: interp.c,v 1.76 2003/06/30 08:28:46 xleroy Exp $ */ + +/* The bytecode interpreter */ +#include +#include "alloc.h" +#include "backtrace.h" +#include "callback.h" +#include "debugger.h" +#include "fail.h" +#include "fix_code.h" +#include "instrtrace.h" +#include "instruct.h" +#include "interp.h" +#include "major_gc.h" +#include "memory.h" +#include "misc.h" +#include "mlvalues.h" +#include "prims.h" +#include "signals.h" +#include "stacks.h" + +/* Registers for the abstract machine: + pc the code pointer + sp the stack pointer (grows downward) + accu the accumulator + env heap-allocated environment + trapsp pointer to the current trap frame + extra_args number of extra arguments provided by the caller + +sp is a local copy of the global variable extern_sp. */ + +/* Instruction decoding */ + +#ifdef THREADED_CODE +# define Instruct(name) lbl_##name +# if defined(ARCH_SIXTYFOUR) && !defined(ARCH_CODE32) +# define Jumptbl_base ((char *) &&lbl_ACC0) +# else +# define Jumptbl_base ((char *) 0) +# define jumptbl_base ((char *) 0) +# endif +# ifdef DEBUG +# define Next goto next_instr +# else +# ifdef __ia64__ +# define Next goto *(void *)(jumptbl_base + *((uint32 *) pc)++) +# else +# define Next goto *(void *)(jumptbl_base + *pc++) +# endif +# endif +#else +# define Instruct(name) case name +# define Next break +#endif + +/* GC interface */ + +#define Setup_for_gc { sp -= 2; sp[0] = accu; sp[1] = env; extern_sp = sp; } +#define Restore_after_gc { accu = sp[0]; env = sp[1]; sp += 2; } +#define Setup_for_c_call { saved_pc = pc; *--sp = env; extern_sp = sp; } +#define Restore_after_c_call { sp = extern_sp; env = *sp++; } + +/* An event frame must look like accu + a C_CALL frame + a RETURN 1 frame */ +#define Setup_for_event \ + { sp -= 6; \ + sp[0] = accu; /* accu */ \ + sp[1] = Val_unit; /* C_CALL frame: dummy environment */ \ + sp[2] = Val_unit; /* RETURN frame: dummy local 0 */ \ + sp[3] = (value) pc; /* RETURN frame: saved return address */ \ + sp[4] = env; /* RETURN frame: saved environment */ \ + sp[5] = Val_long(extra_args); /* RETURN frame: saved extra args */ \ + extern_sp = sp; } +#define Restore_after_event \ + { sp = extern_sp; accu = sp[0]; \ + pc = (code_t) sp[3]; env = sp[4]; extra_args = Long_val(sp[5]); \ + sp += 6; } + +/* Debugger interface */ + +#define Setup_for_debugger \ + { sp -= 4; \ + sp[0] = accu; sp[1] = (value)(pc - 1); \ + sp[2] = env; sp[3] = Val_long(extra_args); \ + extern_sp = sp; } +#define Restore_after_debugger { sp += 4; } + +#ifdef THREADED_CODE +#define Restart_curr_instr \ + goto *(jumptable[saved_code[pc - 1 - start_code]]) +#else +#define Restart_curr_instr \ + curr_instr = saved_code[pc - 1 - start_code]; \ + goto dispatch_instr +#endif + +/* Register optimization. + Some compilers underestimate the use of the local variables representing + the abstract machine registers, and don't put them in hardware registers, + which slows down the interpreter considerably. + For GCC, I have hand-assigned hardware registers for several architectures. +*/ + +#if defined(__GNUC__) && !defined(DEBUG) +#ifdef __mips__ +#define PC_REG asm("$16") +#define SP_REG asm("$17") +#define ACCU_REG asm("$18") +#endif +#ifdef __sparc__ +#define PC_REG asm("%l0") +#define SP_REG asm("%l1") +#define ACCU_REG asm("%l2") +#endif +#ifdef __alpha__ +#ifdef __CRAY__ +#define PC_REG asm("r9") +#define SP_REG asm("r10") +#define ACCU_REG asm("r11") +#define JUMPTBL_BASE_REG asm("r12") +#else +#define PC_REG asm("$9") +#define SP_REG asm("$10") +#define ACCU_REG asm("$11") +#define JUMPTBL_BASE_REG asm("$12") +#endif +#endif +#ifdef __i386__ +#define PC_REG asm("%esi") +#define SP_REG asm("%edi") +#define ACCU_REG +#endif +#if defined(PPC) || defined(_POWER) || defined(_IBMR2) +#define PC_REG asm("26") +#define SP_REG asm("27") +#define ACCU_REG asm("28") +#endif +#ifdef __hppa__ +#define PC_REG asm("%r18") +#define SP_REG asm("%r17") +#define ACCU_REG asm("%r16") +#endif +#ifdef __mc68000__ +#define PC_REG asm("a5") +#define SP_REG asm("a4") +#define ACCU_REG asm("d7") +#endif +#ifdef __arm__ +#define PC_REG asm("r9") +#define SP_REG asm("r8") +#define ACCU_REG asm("r7") +#endif +#ifdef __ia64__ +#define PC_REG asm("36") +#define SP_REG asm("37") +#define ACCU_REG asm("38") +#define JUMPTBL_BASE_REG asm("39") +#endif +#ifdef __x86_64__ +#define PC_REG asm("%r15") +#define SP_REG asm("%r14") +#define ACCU_REG asm("%r13") +#endif +#endif + +/* Division and modulus madness */ + +#ifdef NONSTANDARD_DIV_MOD +extern long caml_safe_div(long p, long q); +extern long caml_safe_mod(long p, long q); +#endif + +/* The interpreter itself */ + +value interprete(code_t prog, asize_t prog_size) +{ +#ifdef PC_REG + register code_t pc PC_REG; + register value * sp SP_REG; + register value accu ACCU_REG; +#else + register code_t pc; + register value * sp; + register value accu; +#endif +#if defined(THREADED_CODE) && defined(ARCH_SIXTYFOUR) && !defined(ARCH_CODE32) +#ifdef JUMPTBL_BASE_REG + register char * jumptbl_base JUMPTBL_BASE_REG; +#else + register char * jumptbl_base; +#endif +#endif + value env; + long extra_args; + struct longjmp_buffer * initial_external_raise; + int initial_sp_offset; + /* volatile prevents collapsing initial_local_roots with another + local variable, like Digital Unix 4.0 C compiler does (wrongly) */ + struct caml__roots_block * volatile initial_local_roots; + struct longjmp_buffer raise_buf; + value * modify_dest, modify_newval; +#ifndef THREADED_CODE + opcode_t curr_instr; +#endif + code_t saved_pc; + +#ifdef THREADED_CODE + static void * jumptable[] = { +# include "jumptbl.h" + }; +#endif + + if (prog == NULL) { /* Interpreter is initializing */ +#ifdef THREADED_CODE + instr_table = (char **) jumptable; + instr_base = Jumptbl_base; +#endif + return Val_unit; + } + +#if defined(THREADED_CODE) && defined(ARCH_SIXTYFOUR) && !defined(ARCH_CODE32) + jumptbl_base = Jumptbl_base; +#endif + initial_local_roots = local_roots; + initial_sp_offset = (char *) stack_high - (char *) extern_sp; + initial_external_raise = external_raise; + callback_depth++; + saved_pc = NULL; + + if (sigsetjmp(raise_buf.buf, 0)) { + local_roots = initial_local_roots; + sp = extern_sp; + accu = exn_bucket; + pc = saved_pc + 2; /* +2 adjustement for the sole purpose of backtraces */ + goto raise_exception; + } + external_raise = &raise_buf; + + sp = extern_sp; + pc = prog; + extra_args = 0; + env = Atom(0); + accu = Val_int(0); + +#ifdef THREADED_CODE +#ifdef DEBUG + next_instr: + if (icount-- == 0) stop_here (); + Assert(sp >= stack_low); + Assert(sp <= stack_high); +#endif + goto *(void *)(jumptbl_base + *pc++); /* Jump to the first instruction */ +#else + while(1) { +#ifdef DEBUG + if (icount-- == 0) stop_here (); + if (trace_flag) disasm_instr(pc); + Assert(sp >= stack_low); + Assert(sp <= stack_high); +#endif + curr_instr = *pc++; + + dispatch_instr: + switch(curr_instr) { +#endif + +/* Basic stack operations */ + + Instruct(ACC0): + accu = sp[0]; Next; + Instruct(ACC1): + accu = sp[1]; Next; + Instruct(ACC2): + accu = sp[2]; Next; + Instruct(ACC3): + accu = sp[3]; Next; + Instruct(ACC4): + accu = sp[4]; Next; + Instruct(ACC5): + accu = sp[5]; Next; + Instruct(ACC6): + accu = sp[6]; Next; + Instruct(ACC7): + accu = sp[7]; Next; + + Instruct(PUSH): Instruct(PUSHACC0): + *--sp = accu; Next; + Instruct(PUSHACC1): + *--sp = accu; accu = sp[1]; Next; + Instruct(PUSHACC2): + *--sp = accu; accu = sp[2]; Next; + Instruct(PUSHACC3): + *--sp = accu; accu = sp[3]; Next; + Instruct(PUSHACC4): + *--sp = accu; accu = sp[4]; Next; + Instruct(PUSHACC5): + *--sp = accu; accu = sp[5]; Next; + Instruct(PUSHACC6): + *--sp = accu; accu = sp[6]; Next; + Instruct(PUSHACC7): + *--sp = accu; accu = sp[7]; Next; + + Instruct(PUSHACC): + *--sp = accu; + /* Fallthrough */ + Instruct(ACC): + accu = sp[*pc++]; + Next; + + Instruct(POP): + sp += *pc++; + Next; + Instruct(ASSIGN): + sp[*pc++] = accu; + accu = Val_unit; + Next; + +/* Access in heap-allocated environment */ + + Instruct(ENVACC1): + accu = Field(env, 1); Next; + Instruct(ENVACC2): + accu = Field(env, 2); Next; + Instruct(ENVACC3): + accu = Field(env, 3); Next; + Instruct(ENVACC4): + accu = Field(env, 4); Next; + + Instruct(PUSHENVACC1): + *--sp = accu; accu = Field(env, 1); Next; + Instruct(PUSHENVACC2): + *--sp = accu; accu = Field(env, 2); Next; + Instruct(PUSHENVACC3): + *--sp = accu; accu = Field(env, 3); Next; + Instruct(PUSHENVACC4): + *--sp = accu; accu = Field(env, 4); Next; + + Instruct(PUSHENVACC): + *--sp = accu; + /* Fallthrough */ + Instruct(ENVACC): + accu = Field(env, *pc++); + Next; + +/* Function application */ + + Instruct(PUSH_RETADDR): { + sp -= 3; + sp[0] = (value) (pc + *pc); + sp[1] = env; + sp[2] = Val_long(extra_args); + pc++; + Next; + } + Instruct(APPLY): { + extra_args = *pc - 1; + pc = Code_val(accu); + env = accu; + goto check_stacks; + } + Instruct(APPLY1): { + value arg1 = sp[0]; + sp -= 3; + sp[0] = arg1; + sp[1] = (value)pc; + sp[2] = env; + sp[3] = Val_long(extra_args); + pc = Code_val(accu); + env = accu; + extra_args = 0; + goto check_stacks; + } + Instruct(APPLY2): { + value arg1 = sp[0]; + value arg2 = sp[1]; + sp -= 3; + sp[0] = arg1; + sp[1] = arg2; + sp[2] = (value)pc; + sp[3] = env; + sp[4] = Val_long(extra_args); + pc = Code_val(accu); + env = accu; + extra_args = 1; + goto check_stacks; + } + Instruct(APPLY3): { + value arg1 = sp[0]; + value arg2 = sp[1]; + value arg3 = sp[2]; + sp -= 3; + sp[0] = arg1; + sp[1] = arg2; + sp[2] = arg3; + sp[3] = (value)pc; + sp[4] = env; + sp[5] = Val_long(extra_args); + pc = Code_val(accu); + env = accu; + extra_args = 2; + goto check_stacks; + } + + Instruct(APPTERM): { + int nargs = *pc++; + int slotsize = *pc; + value * newsp; + int i; + /* Slide the nargs bottom words of the current frame to the top + of the frame, and discard the remainder of the frame */ + newsp = sp + slotsize - nargs; + for (i = nargs - 1; i >= 0; i--) newsp[i] = sp[i]; + sp = newsp; + pc = Code_val(accu); + env = accu; + extra_args += nargs - 1; + goto check_stacks; + } + Instruct(APPTERM1): { + value arg1 = sp[0]; + sp = sp + *pc - 1; + sp[0] = arg1; + pc = Code_val(accu); + env = accu; + goto check_stacks; + } + Instruct(APPTERM2): { + value arg1 = sp[0]; + value arg2 = sp[1]; + sp = sp + *pc - 2; + sp[0] = arg1; + sp[1] = arg2; + pc = Code_val(accu); + env = accu; + extra_args += 1; + goto check_stacks; + } + Instruct(APPTERM3): { + value arg1 = sp[0]; + value arg2 = sp[1]; + value arg3 = sp[2]; + sp = sp + *pc - 3; + sp[0] = arg1; + sp[1] = arg2; + sp[2] = arg3; + pc = Code_val(accu); + env = accu; + extra_args += 2; + goto check_stacks; + } + + Instruct(RETURN): { + sp += *pc++; + if (extra_args > 0) { + extra_args--; + pc = Code_val(accu); + env = accu; + } else { + pc = (code_t)(sp[0]); + env = sp[1]; + extra_args = Long_val(sp[2]); + sp += 3; + } + Next; + } + + Instruct(RESTART): { + int num_args = Wosize_val(env) - 2; + int i; + sp -= num_args; + for (i = 0; i < num_args; i++) sp[i] = Field(env, i + 2); + env = Field(env, 1); + extra_args += num_args; + Next; + } + + Instruct(GRAB): { + int required = *pc++; + if (extra_args >= required) { + extra_args -= required; + } else { + mlsize_t num_args, i; + num_args = 1 + extra_args; /* arg1 + extra args */ + Alloc_small(accu, num_args + 2, Closure_tag); + Field(accu, 1) = env; + for (i = 0; i < num_args; i++) Field(accu, i + 2) = sp[i]; + Code_val(accu) = pc - 3; /* Point to the preceding RESTART instr. */ + sp += num_args; + pc = (code_t)(sp[0]); + env = sp[1]; + extra_args = Long_val(sp[2]); + sp += 3; + } + Next; + } + + Instruct(CLOSURE): { + int nvars = *pc++; + int i; + if (nvars > 0) *--sp = accu; + Alloc_small(accu, 1 + nvars, Closure_tag); + Code_val(accu) = pc + *pc; + pc++; + for (i = 0; i < nvars; i++) Field(accu, i + 1) = sp[i]; + sp += nvars; + Next; + } + + Instruct(CLOSUREREC): { + int nfuncs = *pc++; + int nvars = *pc++; + int i; + value * p; + if (nvars > 0) *--sp = accu; + Alloc_small(accu, nfuncs * 2 - 1 + nvars, Closure_tag); + p = &Field(accu, nfuncs * 2 - 1); + for (i = 0; i < nvars; i++) { + *p++ = sp[i]; + } + sp += nvars; + p = &Field(accu, 0); + *p = (value) (pc + pc[0]); + *--sp = accu; + p++; + for (i = 1; i < nfuncs; i++) { + *p = Make_header(i * 2, Infix_tag, Caml_white); /* color irrelevant. */ + p++; + *p = (value) (pc + pc[i]); + *--sp = (value) p; + p++; + } + pc += nfuncs; + Next; + } + + Instruct(PUSHOFFSETCLOSURE): + *--sp = accu; /* fallthrough */ + Instruct(OFFSETCLOSURE): + accu = env + *pc++ * sizeof(value); Next; + + Instruct(PUSHOFFSETCLOSUREM2): + *--sp = accu; /* fallthrough */ + Instruct(OFFSETCLOSUREM2): + accu = env - 2 * sizeof(value); Next; + Instruct(PUSHOFFSETCLOSURE0): + *--sp = accu; /* fallthrough */ + Instruct(OFFSETCLOSURE0): + accu = env; Next; + Instruct(PUSHOFFSETCLOSURE2): + *--sp = accu; /* fallthrough */ + Instruct(OFFSETCLOSURE2): + accu = env + 2 * sizeof(value); Next; + + +/* Access to global variables */ + + Instruct(PUSHGETGLOBAL): + *--sp = accu; + /* Fallthrough */ + Instruct(GETGLOBAL): + accu = Field(global_data, *pc); + pc++; + Next; + + Instruct(PUSHGETGLOBALFIELD): + *--sp = accu; + /* Fallthrough */ + Instruct(GETGLOBALFIELD): { + accu = Field(global_data, *pc); + pc++; + accu = Field(accu, *pc); + pc++; + Next; + } + + Instruct(SETGLOBAL): + modify(&Field(global_data, *pc), accu); + accu = Val_unit; + pc++; + Next; + +/* Allocation of blocks */ + + Instruct(PUSHATOM0): + *--sp = accu; + /* Fallthrough */ + Instruct(ATOM0): + accu = Atom(0); Next; + + Instruct(PUSHATOM): + *--sp = accu; + /* Fallthrough */ + Instruct(ATOM): + accu = Atom(*pc++); Next; + + Instruct(MAKEBLOCK): { + mlsize_t wosize = *pc++; + tag_t tag = *pc++; + mlsize_t i; + value block; + if (wosize <= Max_young_wosize) { + Alloc_small(block, wosize, tag); + Field(block, 0) = accu; + for (i = 1; i < wosize; i++) Field(block, i) = *sp++; + } else { + block = alloc_shr(wosize, tag); + initialize(&Field(block, 0), accu); + for (i = 1; i < wosize; i++) initialize(&Field(block, i), *sp++); + } + accu = block; + Next; + } + Instruct(MAKEBLOCK1): { + tag_t tag = *pc++; + value block; + Alloc_small(block, 1, tag); + Field(block, 0) = accu; + accu = block; + Next; + } + Instruct(MAKEBLOCK2): { + tag_t tag = *pc++; + value block; + Alloc_small(block, 2, tag); + Field(block, 0) = accu; + Field(block, 1) = sp[0]; + sp += 1; + accu = block; + Next; + } + Instruct(MAKEBLOCK3): { + tag_t tag = *pc++; + value block; + Alloc_small(block, 3, tag); + Field(block, 0) = accu; + Field(block, 1) = sp[0]; + Field(block, 2) = sp[1]; + sp += 2; + accu = block; + Next; + } + Instruct(MAKEFLOATBLOCK): { + mlsize_t size = *pc++; + mlsize_t i; + value block; + if (size <= Max_young_wosize / Double_wosize) { + Alloc_small(block, size * Double_wosize, Double_array_tag); + } else { + block = alloc_shr(size * Double_wosize, Double_array_tag); + } + Store_double_field(block, 0, Double_val(accu)); + for (i = 1; i < size; i++){ + Store_double_field(block, i, Double_val(*sp)); + ++ sp; + } + accu = block; + Next; + } + +/* Access to components of blocks */ + + Instruct(GETFIELD0): + accu = Field(accu, 0); Next; + Instruct(GETFIELD1): + accu = Field(accu, 1); Next; + Instruct(GETFIELD2): + accu = Field(accu, 2); Next; + Instruct(GETFIELD3): + accu = Field(accu, 3); Next; + Instruct(GETFIELD): + accu = Field(accu, *pc); pc++; Next; + Instruct(GETFLOATFIELD): { + double d = Double_field(accu, *pc); + Alloc_small(accu, Double_wosize, Double_tag); + Store_double_val(accu, d); + pc++; + Next; + } + + Instruct(SETFIELD0): + modify_dest = &Field(accu, 0); + modify_newval = *sp++; + modify: + Modify(modify_dest, modify_newval); + accu = Val_unit; + Next; + Instruct(SETFIELD1): + modify_dest = &Field(accu, 1); + modify_newval = *sp++; + goto modify; + Instruct(SETFIELD2): + modify_dest = &Field(accu, 2); + modify_newval = *sp++; + goto modify; + Instruct(SETFIELD3): + modify_dest = &Field(accu, 3); + modify_newval = *sp++; + goto modify; + Instruct(SETFIELD): + modify_dest = &Field(accu, *pc); + pc++; + modify_newval = *sp++; + goto modify; + Instruct(SETFLOATFIELD): + Store_double_field(accu, *pc, Double_val(*sp)); + accu = Val_unit; + sp++; + pc++; + Next; + +/* Array operations */ + + Instruct(VECTLENGTH): { + mlsize_t size = Wosize_val(accu); + if (Tag_val(accu) == Double_array_tag) size = size / Double_wosize; + accu = Val_long(size); + Next; + } + Instruct(GETVECTITEM): + accu = Field(accu, Long_val(sp[0])); + sp += 1; + Next; + Instruct(SETVECTITEM): + modify_dest = &Field(accu, Long_val(sp[0])); + modify_newval = sp[1]; + sp += 2; + goto modify; + +/* String operations */ + + Instruct(GETSTRINGCHAR): + accu = Val_int(Byte_u(accu, Long_val(sp[0]))); + sp += 1; + Next; + Instruct(SETSTRINGCHAR): + Byte_u(accu, Long_val(sp[0])) = Int_val(sp[1]); + sp += 2; + accu = Val_unit; + Next; + +/* Branches and conditional branches */ + + Instruct(BRANCH): + pc += *pc; + Next; + Instruct(BRANCHIF): + if (accu != Val_false) pc += *pc; else pc++; + Next; + Instruct(BRANCHIFNOT): + if (accu == Val_false) pc += *pc; else pc++; + Next; + Instruct(SWITCH): { + uint32 sizes = *pc++; + if (Is_block(accu)) { + long index = Tag_val(accu); + Assert (index >= 0); + Assert (index < (sizes >> 16)); + pc += pc[(sizes & 0xFFFF) + index]; + } else { + long index = Long_val(accu); + Assert ((unsigned long) index < (sizes & 0xFFFF)) ; + pc += pc[index]; + } + Next; + } + Instruct(BOOLNOT): + accu = Val_not(accu); + Next; + +/* Exceptions */ + + Instruct(PUSHTRAP): + sp -= 4; + Trap_pc(sp) = pc + *pc; + Trap_link(sp) = trapsp; + sp[2] = env; + sp[3] = Val_long(extra_args); + trapsp = sp; + pc++; + Next; + + Instruct(POPTRAP): + if (something_to_do) { + /* We must check here so that if a signal is pending and its + handler triggers an exception, the exception is trapped + by the current try...with, not the enclosing one. */ + pc--; /* restart the POPTRAP after processing the signal */ + goto process_signal; + } + trapsp = Trap_link(sp); + sp += 4; + Next; + + Instruct(RAISE): + raise_exception: + if (trapsp >= trap_barrier) debugger(TRAP_BARRIER); + if (backtrace_active) stash_backtrace(accu, pc, sp); + if ((char *) trapsp >= (char *) stack_high - initial_sp_offset) { + external_raise = initial_external_raise; + extern_sp = (value *) ((char *) stack_high - initial_sp_offset); + callback_depth--; + return Make_exception_result(accu); + } + sp = trapsp; + pc = Trap_pc(sp); + trapsp = Trap_link(sp); + env = sp[2]; + extra_args = Long_val(sp[3]); + sp += 4; + Next; + +/* Stack checks */ + + check_stacks: + if (sp < stack_threshold) { + extern_sp = sp; + realloc_stack(Stack_threshold / sizeof(value)); + sp = extern_sp; + } + /* Fall through CHECK_SIGNALS */ + +/* Signal handling */ + + Instruct(CHECK_SIGNALS): /* accu not preserved */ + if (something_to_do) goto process_signal; + Next; + + process_signal: + something_to_do = 0; + Setup_for_event; + process_event(); + Restore_after_event; + Next; + +/* Calling C functions */ + + Instruct(C_CALL1): + Setup_for_c_call; + accu = Primitive(*pc)(accu); + Restore_after_c_call; + pc++; + Next; + Instruct(C_CALL2): + Setup_for_c_call; + accu = Primitive(*pc)(accu, sp[1]); + Restore_after_c_call; + sp += 1; + pc++; + Next; + Instruct(C_CALL3): + Setup_for_c_call; + accu = Primitive(*pc)(accu, sp[1], sp[2]); + Restore_after_c_call; + sp += 2; + pc++; + Next; + Instruct(C_CALL4): + Setup_for_c_call; + accu = Primitive(*pc)(accu, sp[1], sp[2], sp[3]); + Restore_after_c_call; + sp += 3; + pc++; + Next; + Instruct(C_CALL5): + Setup_for_c_call; + accu = Primitive(*pc)(accu, sp[1], sp[2], sp[3], sp[4]); + Restore_after_c_call; + sp += 4; + pc++; + Next; + Instruct(C_CALLN): { + int nargs = *pc++; + *--sp = accu; + Setup_for_c_call; + accu = Primitive(*pc)(sp + 1, nargs); + Restore_after_c_call; + sp += nargs; + pc++; + Next; + } + +/* Integer constants */ + + Instruct(CONST0): + accu = Val_int(0); Next; + Instruct(CONST1): + accu = Val_int(1); Next; + Instruct(CONST2): + accu = Val_int(2); Next; + Instruct(CONST3): + accu = Val_int(3); Next; + + Instruct(PUSHCONST0): + *--sp = accu; accu = Val_int(0); Next; + Instruct(PUSHCONST1): + *--sp = accu; accu = Val_int(1); Next; + Instruct(PUSHCONST2): + *--sp = accu; accu = Val_int(2); Next; + Instruct(PUSHCONST3): + *--sp = accu; accu = Val_int(3); Next; + + Instruct(PUSHCONSTINT): + *--sp = accu; + /* Fallthrough */ + Instruct(CONSTINT): + accu = Val_int(*pc); + pc++; + Next; + +/* Integer arithmetic */ + + Instruct(NEGINT): + accu = (value)(2 - (long)accu); Next; + Instruct(ADDINT): + accu = (value)((long) accu + (long) *sp++ - 1); Next; + Instruct(SUBINT): + accu = (value)((long) accu - (long) *sp++ + 1); Next; + Instruct(MULINT): + accu = Val_long(Long_val(accu) * Long_val(*sp++)); Next; + + Instruct(DIVINT): { + long divisor = Long_val(*sp++); + if (divisor == 0) { Setup_for_c_call; raise_zero_divide(); } +#ifdef NONSTANDARD_DIV_MOD + accu = Val_long(caml_safe_div(Long_val(accu), divisor)); +#else + accu = Val_long(Long_val(accu) / divisor); +#endif + Next; + } + Instruct(MODINT): { + long divisor = Long_val(*sp++); + if (divisor == 0) { Setup_for_c_call; raise_zero_divide(); } +#ifdef NONSTANDARD_DIV_MOD + accu = Val_long(caml_safe_mod(Long_val(accu), divisor)); +#else + accu = Val_long(Long_val(accu) % divisor); +#endif + Next; + } + Instruct(ANDINT): + accu = (value)((long) accu & (long) *sp++); Next; + Instruct(ORINT): + accu = (value)((long) accu | (long) *sp++); Next; + Instruct(XORINT): + accu = (value)(((long) accu ^ (long) *sp++) | 1); Next; + Instruct(LSLINT): + accu = (value)((((long) accu - 1) << Long_val(*sp++)) + 1); Next; + Instruct(LSRINT): + accu = (value)((((unsigned long) accu - 1) >> Long_val(*sp++)) | 1); + Next; + Instruct(ASRINT): + accu = (value)((((long) accu - 1) >> Long_val(*sp++)) | 1); Next; + +#define Integer_comparison(sign,opname,tst) \ + Instruct(opname): \ + accu = Val_int((sign long) accu tst (sign long) *sp++); Next; + + Integer_comparison(signed,EQ, ==) + Integer_comparison(signed,NEQ, !=) + Integer_comparison(signed,LTINT, <) + Integer_comparison(signed,LEINT, <=) + Integer_comparison(signed,GTINT, >) + Integer_comparison(signed,GEINT, >=) + Integer_comparison(unsigned,ULTINT, <) + Integer_comparison(unsigned,UGEINT, >=) + +#define Integer_branch_comparison(sign,opname,tst,debug) \ + Instruct(opname): \ + if ( *pc++ tst ((sign long)Long_val(accu))) { \ + pc += *pc ; \ + } else { \ + pc++ ; \ + } ; Next; + + Integer_branch_comparison(signed,BEQ, ==, "==") + Integer_branch_comparison(signed,BNEQ, !=, "!=") + Integer_branch_comparison(signed,BLTINT, <, "<") + Integer_branch_comparison(signed,BLEINT, <=, "<=") + Integer_branch_comparison(signed,BGTINT, >, ">") + Integer_branch_comparison(signed,BGEINT, >=, ">=") + Integer_branch_comparison(unsigned,BULTINT, <, "<") + Integer_branch_comparison(unsigned,BUGEINT, >=, ">=") + + Instruct(OFFSETINT): + accu += *pc << 1; + pc++; + Next; + Instruct(OFFSETREF): + Field(accu, 0) += *pc << 1; + accu = Val_unit; + pc++; + Next; + Instruct(ISINT): + accu = Val_long(accu & 1); + Next; + +/* Object-oriented operations */ + +#define Lookup(obj, lab) \ + Field (Field (Field (obj, 0), ((lab) >> 16) / sizeof (value)), \ + ((lab) / sizeof (value)) & 0xFF) + + Instruct(GETMETHOD): + accu = Lookup(sp[0], accu); + Next; + +/* Debugging and machine control */ + + Instruct(STOP): + external_raise = initial_external_raise; + extern_sp = sp; + callback_depth--; + return accu; + + Instruct(EVENT): + if (--event_count == 0) { + Setup_for_debugger; + debugger(EVENT_COUNT); + Restore_after_debugger; + } + Restart_curr_instr; + + Instruct(BREAK): + Setup_for_debugger; + debugger(BREAKPOINT); + Restore_after_debugger; + Restart_curr_instr; + +#ifndef THREADED_CODE + default: +#if _MSC_VER >= 1200 + __assume(0); +#else + fatal_error_arg("Fatal error: bad opcode (%lx)\n", + (char *)(long)(*(pc-1))); +#endif + } + } +#endif +} diff --git a/byterun/interp.h b/byterun/interp.h new file mode 100644 index 00000000..650aa8d5 --- /dev/null +++ b/byterun/interp.h @@ -0,0 +1,28 @@ +/***********************************************************************/ +/* */ +/* 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: interp.h,v 1.8 2001/12/07 13:39:30 xleroy Exp $ */ + +/* The bytecode interpreter */ + +#ifndef _interp_ +#define _interp_ + + +#include "misc.h" +#include "mlvalues.h" + +value interprete (code_t prog, asize_t prog_size); + + +#endif diff --git a/byterun/intext.h b/byterun/intext.h new file mode 100644 index 00000000..bdc38d03 --- /dev/null +++ b/byterun/intext.h @@ -0,0 +1,174 @@ +/***********************************************************************/ +/* */ +/* 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: intext.h,v 1.25 2002/11/25 14:40:32 xleroy Exp $ */ + +/* Structured input/output */ + +#ifndef __intext__ +#define __intext__ + +#include "misc.h" +#include "mlvalues.h" + +/* */ +#include "io.h" + +/* Magic number */ + +#define Intext_magic_number 0x8495A6BE + +/* Codes for the compact format */ + +#define PREFIX_SMALL_BLOCK 0x80 +#define PREFIX_SMALL_INT 0x40 +#define PREFIX_SMALL_STRING 0x20 +#define CODE_INT8 0x0 +#define CODE_INT16 0x1 +#define CODE_INT32 0x2 +#define CODE_INT64 0x3 +#define CODE_SHARED8 0x4 +#define CODE_SHARED16 0x5 +#define CODE_SHARED32 0x6 +#define CODE_BLOCK32 0x8 +#define CODE_BLOCK64 0x13 +#define CODE_STRING8 0x9 +#define CODE_STRING32 0xA +#define CODE_DOUBLE_BIG 0xB +#define CODE_DOUBLE_LITTLE 0xC +#define CODE_DOUBLE_ARRAY8_BIG 0xD +#define CODE_DOUBLE_ARRAY8_LITTLE 0xE +#define CODE_DOUBLE_ARRAY32_BIG 0xF +#define CODE_DOUBLE_ARRAY32_LITTLE 0x7 +#define CODE_CODEPOINTER 0x10 +#define CODE_INFIXPOINTER 0x11 +#define CODE_CUSTOM 0x12 + +#if ARCH_FLOAT_ENDIANNESS == 0x76543210 +#define CODE_DOUBLE_NATIVE CODE_DOUBLE_BIG +#define CODE_DOUBLE_ARRAY8_NATIVE CODE_DOUBLE_ARRAY8_BIG +#define CODE_DOUBLE_ARRAY32_NATIVE CODE_DOUBLE_ARRAY32_BIG +#else +#define CODE_DOUBLE_NATIVE CODE_DOUBLE_LITTLE +#define CODE_DOUBLE_ARRAY8_NATIVE CODE_DOUBLE_ARRAY8_LITTLE +#define CODE_DOUBLE_ARRAY32_NATIVE CODE_DOUBLE_ARRAY32_LITTLE +#endif + +/* Initial sizes of data structures for extern */ + +#ifndef INITIAL_EXTERN_BLOCK_SIZE +#define INITIAL_EXTERN_BLOCK_SIZE 8192 +#endif + +#ifndef INITIAL_EXTERN_TABLE_SIZE_LOG2 +#define INITIAL_EXTERN_TABLE_SIZE_LOG2 11 +#endif + +#define INITIAL_EXTERN_TABLE_SIZE (1UL << INITIAL_EXTERN_TABLE_SIZE_LOG2) + +/* Maximal value of initial_ofs above which we should start again with + initial_ofs = 1. Should be low enough to prevent rollover of initial_ofs + next time we extern a structure. Since a structure contains at most + 2^N / (2 * sizeof(value)) heap objects (N = 32 or 64 depending on target), + any value below 2^N - (2^N / (2 * sizeof(value))) suffices. + We just take 2^(N-1) for simplicity. */ + +#define INITIAL_OFFSET_MAX (1UL << (8 * sizeof(value) - 1)) + +/* The entry points */ + +CAMLextern void output_val (struct channel * chan, value v, value flags); + /* Output [v] with flags [flags] on the channel [chan]. */ + +/* */ + +CAMLextern void output_value_to_malloc(value v, value flags, + /*out*/ char ** buf, + /*out*/ long * len); + /* Output [v] with flags [flags] to a memory buffer allocated with + malloc. On return, [*buf] points to the buffer and [*len] + contains the number of bytes in buffer. */ +CAMLextern long output_value_to_block(value v, value flags, + char * data, long len); + /* Output [v] with flags [flags] to a user-provided memory buffer. + [data] points to the start of this buffer, and [len] is its size + in bytes. Return the number of bytes actually written in buffer. + Raise [Failure] if buffer is too short. */ + +/* */ +CAMLextern value input_val (struct channel * chan); + /* Read a structured value from the channel [chan]. */ +/* */ + +CAMLextern value input_val_from_string (value str, long ofs); + /* Read a structured value from the Caml string [str], starting + at offset [ofs]. */ +CAMLextern value input_value_from_malloc(char * data, long ofs); + /* Read a structured value from a malloced buffer. [data] points + to the beginning of the buffer, and [ofs] is the offset of the + beginning of the externed data in this buffer. The buffer is + deallocated with [free] on return, or if an exception is raised. */ +CAMLextern value input_value_from_block(char * data, long len); + /* Read a structured value from a user-provided buffer. [data] points + to the beginning of the externed data in this buffer, + and [len] is the length in bytes of valid data in this buffer. + The buffer is never deallocated by this routine. */ + +/* Functions for writing user-defined marshallers */ + +CAMLextern void serialize_int_1(int i); +CAMLextern void serialize_int_2(int i); +CAMLextern void serialize_int_4(int32 i); +CAMLextern void serialize_int_8(int64 i); +CAMLextern void serialize_float_4(float f); +CAMLextern void serialize_float_8(double f); +CAMLextern void serialize_block_1(void * data, long len); +CAMLextern void serialize_block_2(void * data, long len); +CAMLextern void serialize_block_4(void * data, long len); +CAMLextern void serialize_block_8(void * data, long len); +CAMLextern void serialize_block_float_8(void * data, long len); + +CAMLextern int deserialize_uint_1(void); +CAMLextern int deserialize_sint_1(void); +CAMLextern int deserialize_uint_2(void); +CAMLextern int deserialize_sint_2(void); +CAMLextern uint32 deserialize_uint_4(void); +CAMLextern int32 deserialize_sint_4(void); +CAMLextern uint64 deserialize_uint_8(void); +CAMLextern int64 deserialize_sint_8(void); +CAMLextern float deserialize_float_4(void); +CAMLextern double deserialize_float_8(void); +CAMLextern void deserialize_block_1(void * data, long len); +CAMLextern void deserialize_block_2(void * data, long len); +CAMLextern void deserialize_block_4(void * data, long len); +CAMLextern void deserialize_block_8(void * data, long len); +CAMLextern void deserialize_block_float_8(void * data, long len); +CAMLextern void deserialize_error(char * msg); + +/* */ + +/* Auxiliary stuff for sending code pointers */ +unsigned char * code_checksum (void); + +#ifndef NATIVE_CODE +#include "fix_code.h" +#define code_area_start ((char *) start_code) +#define code_area_end ((char *) start_code + code_size) +#else +extern char * code_area_start, * code_area_end; +#endif + +/* */ + +#endif + diff --git a/byterun/ints.c b/byterun/ints.c new file mode 100644 index 00000000..5c8f5243 --- /dev/null +++ b/byterun/ints.c @@ -0,0 +1,690 @@ +/***********************************************************************/ +/* */ +/* 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: ints.c,v 1.40 2003/06/23 11:27:05 xleroy Exp $ */ + +#include +#include +#include "alloc.h" +#include "custom.h" +#include "fail.h" +#include "intext.h" +#include "memory.h" +#include "misc.h" +#include "mlvalues.h" + +static char * parse_sign_and_base(char * p, + /*out*/ int * base, + /*out*/ int * sign) +{ + *sign = 1; + if (*p == '-') { + *sign = -1; + p++; + } + *base = 10; + if (*p == '0') { + switch (p[1]) { + case 'x': case 'X': + *base = 16; p += 2; break; + case 'o': case 'O': + *base = 8; p += 2; break; + case 'b': case 'B': + *base = 2; p += 2; break; + } + } + return p; +} + +static int parse_digit(char c) +{ + if (c >= '0' && c <= '9') + return c - '0'; + else if (c >= 'A' && c <= 'F') + return c - 'A' + 10; + else if (c >= 'a' && c <= 'f') + return c - 'a' + 10; + else + return -1; +} + +static long parse_long(value s) +{ + char * p; + unsigned long res; + int sign, base, d; + + p = parse_sign_and_base(String_val(s), &base, &sign); + d = parse_digit(*p); + if (d < 0 || d >= base) failwith("int_of_string"); + for (p++, res = d; /*nothing*/; p++) { + char c = *p; + if (c == '_') continue; + d = parse_digit(c); + if (d < 0 || d >= base) break; + res = base * res + d; + } + if (p != String_val(s) + string_length(s)) failwith("int_of_string"); + return sign < 0 ? -((long) res) : (long) res; +} + +#ifdef NONSTANDARD_DIV_MOD +long caml_safe_div(long p, long q) +{ + unsigned long ap = p >= 0 ? p : -p; + unsigned long aq = q >= 0 ? q : -q; + unsigned long ar = ap / aq; + return (p ^ q) >= 0 ? ar : -ar; +} + +long caml_safe_mod(long p, long q) +{ + unsigned long ap = p >= 0 ? p : -p; + unsigned long aq = q >= 0 ? q : -q; + unsigned long ar = ap % aq; + return p >= 0 ? ar : -ar; +} +#endif + +/* Tagged integers */ + +CAMLprim value int_compare(value v1, value v2) +{ + int res = (v1 > v2) - (v1 < v2); + return Val_int(res); +} + +CAMLprim value int_of_string(value s) +{ + return Val_long(parse_long(s)); +} + +#define FORMAT_BUFFER_SIZE 32 + +static char * parse_format(value fmt, + char * suffix, + char format_string[], + char default_format_buffer[], + char *conv) +{ + int prec; + char * p; + char lastletter; + mlsize_t len, len_suffix; + + /* Copy Caml format fmt to format_string, + adding the suffix before the last letter of the format */ + len = string_length(fmt); + len_suffix = strlen(suffix); + if (len + len_suffix + 1 >= FORMAT_BUFFER_SIZE) + invalid_argument("format_int: format too long"); + memmove(format_string, String_val(fmt), len); + p = format_string + len - 1; + lastletter = *p; + /* Compress two-letter formats, ignoring the [lnL] annotation */ + if (p[-1] == 'l' || p[-1] == 'n' || p[-1] == 'L') p--; + memmove(p, suffix, len_suffix); p += len_suffix; + *p++ = lastletter; + *p = 0; + /* Determine space needed for result and allocate it dynamically if needed */ + prec = 22 + 5; /* 22 digits for 64-bit number in octal + 5 extra */ + for (p = String_val(fmt); *p != 0; p++) { + if (*p >= '0' && *p <= '9') { + prec = atoi(p) + 5; + break; + } + } + *conv = lastletter; + if (prec < FORMAT_BUFFER_SIZE) + return default_format_buffer; + else + return stat_alloc(prec + 1); +} + +CAMLprim value format_int(value fmt, value arg) +{ + char format_string[FORMAT_BUFFER_SIZE]; + char default_format_buffer[FORMAT_BUFFER_SIZE]; + char * buffer; + char conv; + value res; + + buffer = parse_format(fmt, "l", format_string, default_format_buffer, &conv); + switch (conv) { + case 'u': case 'x': case 'X': case 'o': + sprintf(buffer, format_string, Unsigned_long_val(arg)); + break; + default: + sprintf(buffer, format_string, Long_val(arg)); + break; + } + res = copy_string(buffer); + if (buffer != default_format_buffer) stat_free(buffer); + return res; +} + +/* 32-bit integers */ + +static int int32_cmp(value v1, value v2) +{ + int32 i1 = Int32_val(v1); + int32 i2 = Int32_val(v2); + return (i1 > i2) - (i1 < i2); +} + +static long int32_hash(value v) +{ + return Int32_val(v); +} + +static void int32_serialize(value v, unsigned long * wsize_32, + unsigned long * wsize_64) +{ + serialize_int_4(Int32_val(v)); + *wsize_32 = *wsize_64 = 4; +} + +static unsigned long int32_deserialize(void * dst) +{ + *((int32 *) dst) = deserialize_sint_4(); + return 4; +} + +CAMLexport struct custom_operations int32_ops = { + "_i", + custom_finalize_default, + int32_cmp, + int32_hash, + int32_serialize, + int32_deserialize +}; + +CAMLexport value copy_int32(int32 i) +{ + value res = alloc_custom(&int32_ops, 4, 0, 1); + Int32_val(res) = i; + return res; +} + +CAMLprim value int32_neg(value v) +{ return copy_int32(- Int32_val(v)); } + +CAMLprim value int32_add(value v1, value v2) +{ return copy_int32(Int32_val(v1) + Int32_val(v2)); } + +CAMLprim value int32_sub(value v1, value v2) +{ return copy_int32(Int32_val(v1) - Int32_val(v2)); } + +CAMLprim value int32_mul(value v1, value v2) +{ return copy_int32(Int32_val(v1) * Int32_val(v2)); } + +CAMLprim value int32_div(value v1, value v2) +{ + int32 divisor = Int32_val(v2); + if (divisor == 0) raise_zero_divide(); +#ifdef NONSTANDARD_DIV_MOD + return copy_int32(caml_safe_div(Int32_val(v1), divisor)); +#else + return copy_int32(Int32_val(v1) / divisor); +#endif +} + +CAMLprim value int32_mod(value v1, value v2) +{ + int32 divisor = Int32_val(v2); + if (divisor == 0) raise_zero_divide(); +#ifdef NONSTANDARD_DIV_MOD + return copy_int32(caml_safe_mod(Int32_val(v1), divisor)); +#else + return copy_int32(Int32_val(v1) % divisor); +#endif +} + +CAMLprim value int32_and(value v1, value v2) +{ return copy_int32(Int32_val(v1) & Int32_val(v2)); } + +CAMLprim value int32_or(value v1, value v2) +{ return copy_int32(Int32_val(v1) | Int32_val(v2)); } + +CAMLprim value int32_xor(value v1, value v2) +{ return copy_int32(Int32_val(v1) ^ Int32_val(v2)); } + +CAMLprim value int32_shift_left(value v1, value v2) +{ return copy_int32(Int32_val(v1) << Int_val(v2)); } + +CAMLprim value int32_shift_right(value v1, value v2) +{ return copy_int32(Int32_val(v1) >> Int_val(v2)); } + +CAMLprim value int32_shift_right_unsigned(value v1, value v2) +{ return copy_int32((uint32)Int32_val(v1) >> Int_val(v2)); } + +CAMLprim value int32_of_int(value v) +{ return copy_int32(Long_val(v)); } + +CAMLprim value int32_to_int(value v) +{ return Val_long(Int32_val(v)); } + +CAMLprim value int32_of_float(value v) +{ return copy_int32((int32)(Double_val(v))); } + +CAMLprim value int32_to_float(value v) +{ return copy_double((double)(Int32_val(v))); } + +CAMLprim value int32_compare(value v1, value v2) +{ + int32 i1 = Int32_val(v1); + int32 i2 = Int32_val(v2); + int res = (i1 > i2) - (i1 < i2); + return Val_int(res); +} + +CAMLprim value int32_format(value fmt, value arg) +{ + char format_string[FORMAT_BUFFER_SIZE]; + char default_format_buffer[FORMAT_BUFFER_SIZE]; + char * buffer; + char conv; + value res; + + buffer = parse_format(fmt, "", format_string, default_format_buffer, &conv); + sprintf(buffer, format_string, (long) Int32_val(arg)); + res = copy_string(buffer); + if (buffer != default_format_buffer) stat_free(buffer); + return res; +} + +CAMLprim value int32_of_string(value s) +{ + return copy_int32(parse_long(s)); +} + +/* 64-bit integers */ + +#ifdef ARCH_INT64_TYPE +#include "int64_native.h" +#else +#include "int64_emul.h" +#endif + +#ifdef ARCH_ALIGN_INT64 + +CAMLexport int64 Int64_val(value v) +{ + union { int32 i[2]; int64 j; } buffer; + buffer.i[0] = ((int32 *) Data_custom_val(v))[0]; + buffer.i[1] = ((int32 *) Data_custom_val(v))[1]; + return buffer.j; +} + +#endif + +static int int64_cmp(value v1, value v2) +{ + int64 i1 = Int64_val(v1); + int64 i2 = Int64_val(v2); + return I64_compare(i1, i2); +} + +static long int64_hash(value v) +{ + return I64_to_long(Int64_val(v)); +} + +static void int64_serialize(value v, unsigned long * wsize_32, + unsigned long * wsize_64) +{ + serialize_int_8(Int64_val(v)); + *wsize_32 = *wsize_64 = 8; +} + +static unsigned long int64_deserialize(void * dst) +{ +#ifndef ARCH_ALIGN_INT64 + *((int64 *) dst) = deserialize_sint_8(); +#else + union { int32 i[2]; int64 j; } buffer; + buffer.j = deserialize_sint_8(); + ((int32 *) dst)[0] = buffer.i[0]; + ((int32 *) dst)[1] = buffer.i[1]; +#endif + return 8; +} + +CAMLexport struct custom_operations int64_ops = { + "_j", + custom_finalize_default, + int64_cmp, + int64_hash, + int64_serialize, + int64_deserialize +}; + +CAMLexport value copy_int64(int64 i) +{ + value res = alloc_custom(&int64_ops, 8, 0, 1); +#ifndef ARCH_ALIGN_INT64 + Int64_val(res) = i; +#else + union { int32 i[2]; int64 j; } buffer; + buffer.j = i; + ((int32 *) Data_custom_val(res))[0] = buffer.i[0]; + ((int32 *) Data_custom_val(res))[1] = buffer.i[1]; +#endif + return res; +} + +CAMLprim value int64_neg(value v) +{ return copy_int64(I64_neg(Int64_val(v))); } + +CAMLprim value int64_add(value v1, value v2) +{ return copy_int64(I64_add(Int64_val(v1), Int64_val(v2))); } + +CAMLprim value int64_sub(value v1, value v2) +{ return copy_int64(I64_sub(Int64_val(v1), Int64_val(v2))); } + +CAMLprim value int64_mul(value v1, value v2) +{ return copy_int64(I64_mul(Int64_val(v1), Int64_val(v2))); } + +CAMLprim value int64_div(value v1, value v2) +{ + int64 divisor = Int64_val(v2); + if (I64_is_zero(divisor)) raise_zero_divide(); + return copy_int64(I64_div(Int64_val(v1), divisor)); +} + +CAMLprim value int64_mod(value v1, value v2) +{ + int64 divisor = Int64_val(v2); + if (I64_is_zero(divisor)) raise_zero_divide(); + return copy_int64(I64_mod(Int64_val(v1), divisor)); +} + +CAMLprim value int64_and(value v1, value v2) +{ return copy_int64(I64_and(Int64_val(v1), Int64_val(v2))); } + +CAMLprim value int64_or(value v1, value v2) +{ return copy_int64(I64_or(Int64_val(v1), Int64_val(v2))); } + +CAMLprim value int64_xor(value v1, value v2) +{ return copy_int64(I64_xor(Int64_val(v1), Int64_val(v2))); } + +CAMLprim value int64_shift_left(value v1, value v2) +{ return copy_int64(I64_lsl(Int64_val(v1), Int_val(v2))); } + +CAMLprim value int64_shift_right(value v1, value v2) +{ return copy_int64(I64_asr(Int64_val(v1), Int_val(v2))); } + +CAMLprim value int64_shift_right_unsigned(value v1, value v2) +{ return copy_int64(I64_lsr(Int64_val(v1), Int_val(v2))); } + +CAMLprim value int64_of_int(value v) +{ return copy_int64(I64_of_long(Long_val(v))); } + +CAMLprim value int64_to_int(value v) +{ return Val_long(I64_to_long(Int64_val(v))); } + +CAMLprim value int64_of_float(value v) +{ return copy_int64(I64_of_double(Double_val(v))); } + +CAMLprim value int64_to_float(value v) +{ + int64 i = Int64_val(v); + return copy_double(I64_to_double(i)); +} + +CAMLprim value int64_of_int32(value v) +{ return copy_int64(I64_of_int32(Int32_val(v))); } + +CAMLprim value int64_to_int32(value v) +{ return copy_int32(I64_to_int32(Int64_val(v))); } + +CAMLprim value int64_of_nativeint(value v) +{ return copy_int64(I64_of_long(Nativeint_val(v))); } + +CAMLprim value int64_to_nativeint(value v) +{ return copy_nativeint(I64_to_long(Int64_val(v))); } + +CAMLprim value int64_compare(value v1, value v2) +{ + int64 i1 = Int64_val(v1); + int64 i2 = Int64_val(v2); + return Val_int(I64_compare(i1, i2)); +} + +#ifdef ARCH_INT64_PRINTF_FORMAT +#define I64_format(buf,fmt,x) sprintf(buf,fmt,x) +#else +#include "int64_format.h" +#define ARCH_INT64_PRINTF_FORMAT "" +#endif + +CAMLprim value int64_format(value fmt, value arg) +{ + char format_string[FORMAT_BUFFER_SIZE]; + char default_format_buffer[FORMAT_BUFFER_SIZE]; + char * buffer; + char conv; + value res; + + buffer = parse_format(fmt, ARCH_INT64_PRINTF_FORMAT, + format_string, default_format_buffer, &conv); + I64_format(buffer, format_string, Int64_val(arg)); + res = copy_string(buffer); + if (buffer != default_format_buffer) stat_free(buffer); + return res; +} + +CAMLprim value int64_of_string(value s) +{ + char * p; + int64 res; + int sign, base, d; + + p = parse_sign_and_base(String_val(s), &base, &sign); + d = parse_digit(*p); + if (d < 0 || d >= base) failwith("int_of_string"); + res = I64_of_int32(d); + for (p++; /*nothing*/; p++) { + char c = *p; + if (c == '_') continue; + d = parse_digit(c); + if (d < 0 || d >= base) break; + res = I64_add(I64_mul(I64_of_int32(base), res), I64_of_int32(d)); + } + if (p != String_val(s) + string_length(s)) failwith("int_of_string"); + if (sign < 0) res = I64_neg(res); + return copy_int64(res); +} + +CAMLprim value int64_bits_of_float(value vd) +{ + union { double d; int64 i; } u; + u.d = Double_val(vd); + return copy_int64(u.i); +} + +CAMLprim value int64_float_of_bits(value vi) +{ + union { double d; int64 i; } u; + u.i = Int64_val(vi); + return copy_double(u.d); +} + +/* Native integers */ + +static int nativeint_cmp(value v1, value v2) +{ + long i1 = Nativeint_val(v1); + long i2 = Nativeint_val(v2); + return (i1 > i2) - (i1 < i2); +} + +static long nativeint_hash(value v) +{ + return Nativeint_val(v); +} + +static void nativeint_serialize(value v, unsigned long * wsize_32, + unsigned long * wsize_64) +{ + long l = Nativeint_val(v); +#ifdef ARCH_SIXTYFOUR + if (l <= 0x7FFFFFFFL && l >= -0x80000000L) { + serialize_int_1(1); + serialize_int_4((int32) l); + } else { + serialize_int_1(2); + serialize_int_8(l); + } +#else + serialize_int_1(1); + serialize_int_4(l); +#endif + *wsize_32 = 4; + *wsize_64 = 8; +} + +static unsigned long nativeint_deserialize(void * dst) +{ + switch (deserialize_uint_1()) { + case 1: + *((long *) dst) = deserialize_sint_4(); + break; + case 2: +#ifdef ARCH_SIXTYFOUR + *((long *) dst) = deserialize_sint_8(); +#else + deserialize_error("input_value: native integer value too large"); +#endif + break; + default: + deserialize_error("input_value: ill-formed native integer"); + } + return sizeof(long); +} + +CAMLexport struct custom_operations nativeint_ops = { + "_n", + custom_finalize_default, + nativeint_cmp, + nativeint_hash, + nativeint_serialize, + nativeint_deserialize +}; + +CAMLexport value copy_nativeint(long i) +{ + value res = alloc_custom(&nativeint_ops, sizeof(long), 0, 1); + Nativeint_val(res) = i; + return res; +} + +CAMLprim value nativeint_neg(value v) +{ return copy_nativeint(- Nativeint_val(v)); } + +CAMLprim value nativeint_add(value v1, value v2) +{ return copy_nativeint(Nativeint_val(v1) + Nativeint_val(v2)); } + +CAMLprim value nativeint_sub(value v1, value v2) +{ return copy_nativeint(Nativeint_val(v1) - Nativeint_val(v2)); } + +CAMLprim value nativeint_mul(value v1, value v2) +{ return copy_nativeint(Nativeint_val(v1) * Nativeint_val(v2)); } + +CAMLprim value nativeint_div(value v1, value v2) +{ + long divisor = Nativeint_val(v2); + if (divisor == 0) raise_zero_divide(); +#ifdef NONSTANDARD_DIV_MOD + return copy_nativeint(caml_safe_div(Nativeint_val(v1), divisor)); +#else + return copy_nativeint(Nativeint_val(v1) / divisor); +#endif +} + +CAMLprim value nativeint_mod(value v1, value v2) +{ + long divisor = Nativeint_val(v2); + if (divisor == 0) raise_zero_divide(); +#ifdef NONSTANDARD_DIV_MOD + return copy_nativeint(caml_safe_mod(Nativeint_val(v1), divisor)); +#else + return copy_nativeint(Nativeint_val(v1) % divisor); +#endif +} + +CAMLprim value nativeint_and(value v1, value v2) +{ return copy_nativeint(Nativeint_val(v1) & Nativeint_val(v2)); } + +CAMLprim value nativeint_or(value v1, value v2) +{ return copy_nativeint(Nativeint_val(v1) | Nativeint_val(v2)); } + +CAMLprim value nativeint_xor(value v1, value v2) +{ return copy_nativeint(Nativeint_val(v1) ^ Nativeint_val(v2)); } + +CAMLprim value nativeint_shift_left(value v1, value v2) +{ return copy_nativeint(Nativeint_val(v1) << Int_val(v2)); } + +CAMLprim value nativeint_shift_right(value v1, value v2) +{ return copy_nativeint(Nativeint_val(v1) >> Int_val(v2)); } + +CAMLprim value nativeint_shift_right_unsigned(value v1, value v2) +{ return copy_nativeint((unsigned long)Nativeint_val(v1) >> Int_val(v2)); } + +CAMLprim value nativeint_of_int(value v) +{ return copy_nativeint(Long_val(v)); } + +CAMLprim value nativeint_to_int(value v) +{ return Val_long(Nativeint_val(v)); } + +CAMLprim value nativeint_of_float(value v) +{ return copy_nativeint((long)(Double_val(v))); } + +CAMLprim value nativeint_to_float(value v) +{ return copy_double((double)(Nativeint_val(v))); } + +CAMLprim value nativeint_of_int32(value v) +{ return copy_nativeint(Int32_val(v)); } + +CAMLprim value nativeint_to_int32(value v) +{ return copy_int32(Nativeint_val(v)); } + +CAMLprim value nativeint_compare(value v1, value v2) +{ + long i1 = Nativeint_val(v1); + long i2 = Nativeint_val(v2); + int res = (i1 > i2) - (i1 < i2); + return Val_int(res); +} + +CAMLprim value nativeint_format(value fmt, value arg) +{ + char format_string[FORMAT_BUFFER_SIZE]; + char default_format_buffer[FORMAT_BUFFER_SIZE]; + char * buffer; + char conv; + value res; + + buffer = parse_format(fmt, "l", format_string, default_format_buffer, &conv); + sprintf(buffer, format_string, (long) Nativeint_val(arg)); + res = copy_string(buffer); + if (buffer != default_format_buffer) stat_free(buffer); + return res; +} + +CAMLprim value nativeint_of_string(value s) +{ + return copy_nativeint(parse_long(s)); +} + + diff --git a/byterun/io.c b/byterun/io.c new file mode 100644 index 00000000..4edead2b --- /dev/null +++ b/byterun/io.c @@ -0,0 +1,753 @@ +/***********************************************************************/ +/* */ +/* 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: io.c,v 1.62 2003/01/06 10:59:07 xleroy Exp $ */ + +/* Buffered input/output. */ + +#include +#include +#include +#include +#if !macintosh +#include +#endif +#include "config.h" +#ifdef HAS_UNISTD +#include +#endif +#include "alloc.h" +#include "custom.h" +#include "fail.h" +#include "io.h" +#include "memory.h" +#include "misc.h" +#include "mlvalues.h" +#include "signals.h" +#include "sys.h" +#ifdef HAS_UI +#include "ui.h" +#endif + +#ifndef SEEK_SET +#define SEEK_SET 0 +#define SEEK_CUR 1 +#define SEEK_END 2 +#endif + +/* Hooks for locking channels */ + +CAMLexport void (*channel_mutex_free) (struct channel *) = NULL; +CAMLexport void (*channel_mutex_lock) (struct channel *) = NULL; +CAMLexport void (*channel_mutex_unlock) (struct channel *) = NULL; +CAMLexport void (*channel_mutex_unlock_exn) (void) = NULL; + +/* List of opened channels */ +CAMLexport struct channel * all_opened_channels = NULL; + +/* Basic functions over type struct channel *. + These functions can be called directly from C. + No locking is performed. */ + +/* Functions shared between input and output */ + +CAMLexport struct channel * open_descriptor_in(int fd) +{ + struct channel * channel; + + channel = (struct channel *) stat_alloc(sizeof(struct channel)); + channel->fd = fd; + channel->offset = lseek (fd, 0, SEEK_CUR); + channel->curr = channel->max = channel->buff; + channel->end = channel->buff + IO_BUFFER_SIZE; + channel->mutex = NULL; + channel->revealed = 0; + channel->old_revealed = 0; + channel->refcount = 0; + channel->next = all_opened_channels; + all_opened_channels = channel; + return channel; +} + +CAMLexport struct channel * open_descriptor_out(int fd) +{ + struct channel * channel; + + channel = open_descriptor_in(fd); + channel->max = NULL; + return channel; +} + +static void unlink_channel(struct channel *channel) +{ + struct channel ** cp = &all_opened_channels; + + while (*cp != channel && *cp != NULL) + cp = &(*cp)->next; + if (*cp != NULL) + *cp = (*cp)->next; +} + +CAMLexport void close_channel(struct channel *channel) +{ + close(channel->fd); + if (channel->refcount > 0) return; + if (channel_mutex_free != NULL) (*channel_mutex_free)(channel); + unlink_channel(channel); + stat_free(channel); +} + +CAMLexport file_offset channel_size(struct channel *channel) +{ + file_offset end; + + end = lseek(channel->fd, 0, SEEK_END); + if (end == -1 || + lseek(channel->fd, channel->offset, SEEK_SET) != channel->offset) { + sys_error(NO_ARG); + } + return end; +} + +CAMLexport int channel_binary_mode(struct channel *channel) +{ +#ifdef _WIN32 + int oldmode = setmode(channel->fd, O_BINARY); + if (oldmode == O_TEXT) setmode(channel->fd, O_TEXT); + return oldmode == O_BINARY; +#else + return 1; +#endif +} + +/* Output */ + +#ifndef EINTR +#define EINTR (-1) +#endif +#ifndef EAGAIN +#define EAGAIN (-1) +#endif +#ifndef EWOULDBLOCK +#define EWOULDBLOCK (-1) +#endif + +static int do_write(int fd, char *p, int n) +{ + int retcode; + + Assert(!Is_young((value) p)); +#ifdef HAS_UI + retcode = ui_write(fd, p, n); +#else +again: + enter_blocking_section(); + retcode = write(fd, p, n); + leave_blocking_section(); + if (retcode == -1) { + if (errno == EINTR) goto again; + if ((errno == EAGAIN || errno == EWOULDBLOCK) && n > 1) { + /* We couldn't do a partial write here, probably because + n <= PIPE_BUF and POSIX says that writes of less than + PIPE_BUF characters must be atomic. + We first try again with a partial write of 1 character. + If that fails too, we'll raise Sys_blocked_io below. */ + n = 1; goto again; + } + } +#endif + if (retcode == -1) sys_error(NO_ARG); + return retcode; +} + +/* Attempt to flush the buffer. This will make room in the buffer for + at least one character. Returns true if the buffer is empty at the + end of the flush, or false if some data remains in the buffer. + */ + +CAMLexport int flush_partial(struct channel *channel) +{ + int towrite, written; + + towrite = channel->curr - channel->buff; + if (towrite > 0) { + written = do_write(channel->fd, channel->buff, towrite); + channel->offset += written; + if (written < towrite) + memmove(channel->buff, channel->buff + written, towrite - written); + channel->curr -= written; + } + return (channel->curr == channel->buff); +} + +/* Flush completely the buffer. */ + +CAMLexport void flush(struct channel *channel) +{ + while (! flush_partial(channel)) /*nothing*/; +} + +/* Output data */ + +CAMLexport void putword(struct channel *channel, uint32 w) +{ + if (! channel_binary_mode(channel)) + failwith("output_binary_int: not a binary channel"); + putch(channel, w >> 24); + putch(channel, w >> 16); + putch(channel, w >> 8); + putch(channel, w); +} + +CAMLexport int putblock(struct channel *channel, char *p, long int len) +{ + int n, free, towrite, written; + + n = len >= INT_MAX ? INT_MAX : (int) len; + free = channel->end - channel->curr; + if (n < free) { + /* Write request small enough to fit in buffer: transfer to buffer. */ + memmove(channel->curr, p, n); + channel->curr += n; + return n; + } else { + /* Write request overflows buffer (or just fills it up): transfer whatever + fits to buffer and write the buffer */ + memmove(channel->curr, p, free); + towrite = channel->end - channel->buff; + written = do_write(channel->fd, channel->buff, towrite); + if (written < towrite) + memmove(channel->buff, channel->buff + written, towrite - written); + channel->offset += written; + channel->curr = channel->end - written; + return free; + } +} + +CAMLexport void really_putblock(struct channel *channel, char *p, long int len) +{ + int written; + while (len > 0) { + written = putblock(channel, p, len); + p += written; + len -= written; + } +} + +CAMLexport void seek_out(struct channel *channel, file_offset dest) +{ + flush(channel); + if (lseek(channel->fd, dest, SEEK_SET) != dest) sys_error(NO_ARG); + channel->offset = dest; +} + +CAMLexport file_offset pos_out(struct channel *channel) +{ + return channel->offset + (file_offset)(channel->curr - channel->buff); +} + +/* Input */ + +/* do_read is exported for Cash */ +CAMLexport int do_read(int fd, char *p, unsigned int n) +{ + int retcode; + + /*Assert(!Is_young((value) p)); ** Is_young only applies to a true value */ + enter_blocking_section(); +#ifdef HAS_UI + retcode = ui_read(fd, p, n); +#else +#ifdef EINTR + do { retcode = read(fd, p, n); } while (retcode == -1 && errno == EINTR); +#else + retcode = read(fd, p, n); +#endif +#endif + leave_blocking_section(); + if (retcode == -1) sys_error(NO_ARG); + return retcode; +} + +CAMLexport unsigned char refill(struct channel *channel) +{ + int n; + + n = do_read(channel->fd, channel->buff, channel->end - channel->buff); + if (n == 0) raise_end_of_file(); + channel->offset += n; + channel->max = channel->buff + n; + channel->curr = channel->buff + 1; + return (unsigned char)(channel->buff[0]); +} + +CAMLexport uint32 getword(struct channel *channel) +{ + int i; + uint32 res; + + if (! channel_binary_mode(channel)) + failwith("input_binary_int: not a binary channel"); + res = 0; + for(i = 0; i < 4; i++) { + res = (res << 8) + getch(channel); + } + return res; +} + +CAMLexport int getblock(struct channel *channel, char *p, long int len) +{ + int n, avail, nread; + + n = len >= INT_MAX ? INT_MAX : (int) len; + avail = channel->max - channel->curr; + if (n <= avail) { + memmove(p, channel->curr, n); + channel->curr += n; + return n; + } else if (avail > 0) { + memmove(p, channel->curr, avail); + channel->curr += avail; + return avail; + } else { + nread = do_read(channel->fd, channel->buff, channel->end - channel->buff); + channel->offset += nread; + channel->max = channel->buff + nread; + if (n > nread) n = nread; + memmove(p, channel->buff, n); + channel->curr = channel->buff + n; + return n; + } +} + +CAMLexport int really_getblock(struct channel *chan, char *p, long int n) +{ + int r; + while (n > 0) { + r = getblock(chan, p, n); + if (r == 0) break; + p += r; + n -= r; + } + return (n == 0); +} + +CAMLexport void seek_in(struct channel *channel, file_offset dest) +{ + if (dest >= channel->offset - (channel->max - channel->buff) && + dest <= channel->offset) { + channel->curr = channel->max - (channel->offset - dest); + } else { + if (lseek(channel->fd, dest, SEEK_SET) != dest) sys_error(NO_ARG); + channel->offset = dest; + channel->curr = channel->max = channel->buff; + } +} + +CAMLexport file_offset pos_in(struct channel *channel) +{ + return channel->offset - (file_offset)(channel->max - channel->curr); +} + +CAMLexport long input_scan_line(struct channel *channel) +{ + char * p; + int n; + + p = channel->curr; + do { + if (p >= channel->max) { + /* No more characters available in the buffer */ + if (channel->curr > channel->buff) { + /* Try to make some room in the buffer by shifting the unread + portion at the beginning */ + memmove(channel->buff, channel->curr, channel->max - channel->curr); + n = channel->curr - channel->buff; + channel->curr -= n; + channel->max -= n; + p -= n; + } + if (channel->max >= channel->end) { + /* Buffer is full, no room to read more characters from the input. + Return the number of characters in the buffer, with negative + sign to indicate that no newline was encountered. */ + return -(channel->max - channel->curr); + } + /* Fill the buffer as much as possible */ + n = do_read(channel->fd, channel->max, channel->end - channel->max); + if (n == 0) { + /* End-of-file encountered. Return the number of characters in the + buffer, with negative sign since we haven't encountered + a newline. */ + return -(channel->max - channel->curr); + } + channel->offset += n; + channel->max += n; + } + } while (*p++ != '\n'); + /* Found a newline. Return the length of the line, newline included. */ + return (p - channel->curr); +} + +/* Caml entry points for the I/O functions. Wrap struct channel * + objects into a heap-allocated object. Perform locking + and unlocking around the I/O operations. */ + +CAMLexport void finalize_channel(value vchan) +{ + struct channel * chan = Channel(vchan); + if (--chan->refcount > 0) return; + if (channel_mutex_free != NULL) (*channel_mutex_free)(chan); + unlink_channel(chan); + stat_free(chan); +} + +static int compare_channel(value vchan1, value vchan2) +{ + struct channel * chan1 = Channel(vchan1); + struct channel * chan2 = Channel(vchan2); + return (chan1 == chan2) ? 0 : (chan1 < chan2) ? -1 : 1; +} + +static struct custom_operations channel_operations = { + "_chan", + finalize_channel, + compare_channel, + custom_hash_default, + custom_serialize_default, + custom_deserialize_default +}; + +CAMLexport value alloc_channel(struct channel *chan) +{ + value res = alloc_custom(&channel_operations, sizeof(struct channel *), + 1, 1000); + Channel(res) = chan; + chan->refcount++; + return res; +} + +CAMLprim value caml_open_descriptor_in(value fd) +{ + return alloc_channel(open_descriptor_in(Int_val(fd))); +} + +CAMLprim value caml_open_descriptor_out(value fd) +{ + return alloc_channel(open_descriptor_out(Int_val(fd))); +} + +#define Pair_tag 0 + +CAMLprim value caml_out_channels_list (value unit) +{ + CAMLparam0 (); + CAMLlocal3 (res, tail, chan); + struct channel * channel; + + res = Val_emptylist; + for (channel = all_opened_channels; + channel != NULL; + channel = channel->next) + /* Testing channel->fd >= 0 looks unnecessary, as + caml_close_channel changes max when setting fd to -1. */ + if (channel->max == NULL) { + chan = alloc_channel (channel); + tail = res; + res = alloc_small (2, Pair_tag); + Field (res, 0) = chan; + Field (res, 1) = tail; + } + CAMLreturn (res); +} + +CAMLprim value channel_descriptor(value vchannel) +{ + int fd = Channel(vchannel)->fd; + if (fd == -1) { errno = EBADF; sys_error(NO_ARG); } + return Val_int(fd); +} + +CAMLprim value caml_close_channel(value vchannel) +{ + int result; + + /* For output channels, must have flushed before */ + struct channel * channel = Channel(vchannel); + if (channel->fd != -1){ + result = close(channel->fd); + channel->fd = -1; + }else{ + result = 0; + } + /* Ensure that every read or write on the channel will cause an + immediate flush_partial or refill, thus raising a Sys_error + exception */ + channel->curr = channel->max = channel->end; + if (result == -1) sys_error (NO_ARG); + return Val_unit; +} + +/* EOVERFLOW is the Unix98 error indicating that a file position or file + size is not representable. + ERANGE is the ANSI C error indicating that some argument to some + function is out of range. This is less precise than EOVERFLOW, + but guaranteed to be defined on all ANSI C environments. */ +#ifndef EOVERFLOW +#define EOVERFLOW ERANGE +#endif + +CAMLprim value caml_channel_size(value vchannel) +{ + file_offset size = channel_size(Channel(vchannel)); + if (size > Max_long) { errno = EOVERFLOW; sys_error(NO_ARG); } + return Val_long(size); +} + +CAMLprim value caml_channel_size_64(value vchannel) +{ + return Val_file_offset(channel_size(Channel(vchannel))); +} + +CAMLprim value caml_set_binary_mode(value vchannel, value mode) +{ +#ifdef _WIN32 + struct channel * channel = Channel(vchannel); + if (setmode(channel->fd, Bool_val(mode) ? O_BINARY : O_TEXT) == -1) + sys_error(NO_ARG); +#endif + return Val_unit; +} + +/* + If the channel is closed, DO NOT raise a "bad file descriptor" + exception, but do nothing (the buffer is already empty). + This is because some libraries will flush at exit, even on + file descriptors that may be closed. +*/ + +CAMLprim value caml_flush_partial(value vchannel) +{ + struct channel * channel = Channel(vchannel); + int res; + + if (channel->fd == -1) return Val_true; + Lock(channel); + res = flush_partial(channel); + Unlock(channel); + return Val_bool(res); +} + +CAMLprim value caml_flush(value vchannel) +{ + struct channel * channel = Channel(vchannel); + + if (channel->fd == -1) return Val_unit; + Lock(channel); + flush(channel); + Unlock(channel); + return Val_unit; +} + +CAMLprim value caml_output_char(value vchannel, value ch) +{ + struct channel * channel = Channel(vchannel); + Lock(channel); + putch(channel, Long_val(ch)); + Unlock(channel); + return Val_unit; +} + +CAMLprim value caml_output_int(value vchannel, value w) +{ + struct channel * channel = Channel(vchannel); + Lock(channel); + putword(channel, Long_val(w)); + Unlock(channel); + return Val_unit; +} + +CAMLprim value caml_output_partial(value vchannel, value buff, value start, value length) +{ + CAMLparam4 (vchannel, buff, start, length); + struct channel * channel = Channel(vchannel); + int res; + + Lock(channel); + res = putblock(channel, &Byte(buff, Long_val(start)), Long_val(length)); + Unlock(channel); + CAMLreturn (Val_int(res)); +} + +CAMLprim value caml_output(value vchannel, value buff, value start, value length) +{ + CAMLparam4 (vchannel, buff, start, length); + struct channel * channel = Channel(vchannel); + long pos = Long_val(start); + long len = Long_val(length); + + Lock(channel); + while (len > 0) { + int written = putblock(channel, &Byte(buff, pos), len); + pos += written; + len -= written; + } + Unlock(channel); + CAMLreturn (Val_unit); +} + +CAMLprim value caml_seek_out(value vchannel, value pos) +{ + struct channel * channel = Channel(vchannel); + Lock(channel); + seek_out(channel, Long_val(pos)); + Unlock(channel); + return Val_unit; +} + +CAMLprim value caml_seek_out_64(value vchannel, value pos) +{ + struct channel * channel = Channel(vchannel); + Lock(channel); + seek_out(channel, File_offset_val(pos)); + Unlock(channel); + return Val_unit; +} + +CAMLprim value caml_pos_out(value vchannel) +{ + file_offset pos = pos_out(Channel(vchannel)); + if (pos > Max_long) { errno = EOVERFLOW; sys_error(NO_ARG); } + return Val_long(pos); +} + +CAMLprim value caml_pos_out_64(value vchannel) +{ + return Val_file_offset(pos_out(Channel(vchannel))); +} + +CAMLprim value caml_input_char(value vchannel) +{ + struct channel * channel = Channel(vchannel); + unsigned char c; + + Lock(channel); + c = getch(channel); + Unlock(channel); + return Val_long(c); +} + +CAMLprim value caml_input_int(value vchannel) +{ + struct channel * channel = Channel(vchannel); + long i; + + Lock(channel); + i = getword(channel); + Unlock(channel); +#ifdef ARCH_SIXTYFOUR + i = (i << 32) >> 32; /* Force sign extension */ +#endif + return Val_long(i); +} + +CAMLprim value caml_input(value vchannel,value buff,value vstart,value vlength) +{ + CAMLparam4 (vchannel, buff, vstart, vlength); + struct channel * channel = Channel(vchannel); + long start, len; + int n, avail, nread; + + Lock(channel); + /* We cannot call getblock here because buff may move during do_read */ + start = Long_val(vstart); + len = Long_val(vlength); + n = len >= INT_MAX ? INT_MAX : (int) len; + avail = channel->max - channel->curr; + if (n <= avail) { + memmove(&Byte(buff, start), channel->curr, n); + channel->curr += n; + } else if (avail > 0) { + memmove(&Byte(buff, start), channel->curr, avail); + channel->curr += avail; + n = avail; + } else { + nread = do_read(channel->fd, channel->buff, channel->end - channel->buff); + channel->offset += nread; + channel->max = channel->buff + nread; + if (n > nread) n = nread; + memmove(&Byte(buff, start), channel->buff, n); + channel->curr = channel->buff + n; + } + Unlock(channel); + CAMLreturn (Val_long(n)); +} + +CAMLprim value caml_seek_in(value vchannel, value pos) +{ + struct channel * channel = Channel(vchannel); + Lock(channel); + seek_in(channel, Long_val(pos)); + Unlock(channel); + return Val_unit; +} + +CAMLprim value caml_seek_in_64(value vchannel, value pos) +{ + struct channel * channel = Channel(vchannel); + Lock(channel); + seek_in(channel, File_offset_val(pos)); + Unlock(channel); + return Val_unit; +} + +CAMLprim value caml_pos_in(value vchannel) +{ + file_offset pos = pos_in(Channel(vchannel)); + if (pos > Max_long) { errno = EOVERFLOW; sys_error(NO_ARG); } + return Val_long(pos); +} + +CAMLprim value caml_pos_in_64(value vchannel) +{ + return Val_file_offset(pos_in(Channel(vchannel))); +} + +CAMLprim value caml_input_scan_line(value vchannel) +{ + struct channel * channel = Channel(vchannel); + long res; + + Lock(channel); + res = input_scan_line(channel); + Unlock(channel); + return Val_long(res); +} + +/* Conversion between file_offset and int64 */ + +#ifndef ARCH_INT64_TYPE +CAMLexport value Val_file_offset(file_offset fofs) +{ + int64 ofs; + ofs.l = fofs; + ofs.h = 0; + return copy_int64(ofs); +} + +CAMLexport file_offset File_offset_val(value v) +{ + int64 ofs = Int64_val(v); + return (file_offset) ofs.l; +} +#endif diff --git a/byterun/io.h b/byterun/io.h new file mode 100644 index 00000000..f8b843dc --- /dev/null +++ b/byterun/io.h @@ -0,0 +1,112 @@ +/***********************************************************************/ +/* */ +/* 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: io.h,v 1.22 2002/10/22 13:02:46 doligez Exp $ */ + +/* Buffered input/output */ + +#ifndef _io_ +#define _io_ + +#include "misc.h" +#include "mlvalues.h" + +#ifndef IO_BUFFER_SIZE +#define IO_BUFFER_SIZE 4096 +#endif + +#ifdef HAS_OFF_T +#include +typedef off_t file_offset; +#else +typedef long file_offset; +#endif + +struct channel { + int fd; /* Unix file descriptor */ + file_offset offset; /* Absolute position of fd in the file */ + char * end; /* Physical end of the buffer */ + char * curr; /* Current position in the buffer */ + char * max; /* Logical end of the buffer (for input) */ + void * mutex; /* Placeholder for mutex (for systhreads) */ + struct channel * next; /* Linear chaining of channels (flush_all) */ + int revealed; /* For Cash only */ + int old_revealed; /* For Cash only */ + int refcount; /* For flush_all and for Cash */ + char buff[IO_BUFFER_SIZE]; /* The buffer itself */ +}; + +/* For an output channel: + [offset] is the absolute position of the beginning of the buffer [buff]. + For an input channel: + [offset] is the absolute position of the logical end of the buffer, [max]. +*/ + +/* Functions and macros that can be called from C. Take arguments of + type struct channel *. No locking is performed. */ + +#define putch(channel, ch) do{ \ + if ((channel)->curr >= (channel)->end) flush_partial(channel); \ + *((channel)->curr)++ = (ch); \ +}while(0) + +#define getch(channel) \ + ((channel)->curr >= (channel)->max \ + ? refill(channel) \ + : (unsigned char) *((channel)->curr)++) + +CAMLextern struct channel * open_descriptor_in (int); +CAMLextern struct channel * open_descriptor_out (int); +CAMLextern void close_channel (struct channel *); +CAMLextern int channel_binary_mode (struct channel *); + +CAMLextern int flush_partial (struct channel *); +CAMLextern void flush (struct channel *); +CAMLextern void putword (struct channel *, uint32); +CAMLextern int putblock (struct channel *, char *, long); +CAMLextern void really_putblock (struct channel *, char *, long); + +CAMLextern unsigned char refill (struct channel *); +CAMLextern uint32 getword (struct channel *); +CAMLextern int getblock (struct channel *, char *, long); +CAMLextern int really_getblock (struct channel *, char *, long); + +/* Extract a struct channel * from the heap object representing it */ + +#define Channel(v) (*((struct channel **) (Data_custom_val(v)))) + +/* The locking machinery */ + +CAMLextern void (*channel_mutex_free) (struct channel *); +CAMLextern void (*channel_mutex_lock) (struct channel *); +CAMLextern void (*channel_mutex_unlock) (struct channel *); +CAMLextern void (*channel_mutex_unlock_exn) (void); + +#define Lock(channel) \ + if (channel_mutex_lock != NULL) (*channel_mutex_lock)(channel) +#define Unlock(channel) \ + if (channel_mutex_unlock != NULL) (*channel_mutex_unlock)(channel) +#define Unlock_exn() \ + if (channel_mutex_unlock_exn != NULL) (*channel_mutex_unlock_exn)() + +/* Conversion between file_offset and int64 */ + +#ifdef ARCH_INT64_TYPE +#define Val_file_offset(fofs) copy_int64(fofs) +#define File_offset_val(v) ((file_offset) Int64_val(v)) +#else +CAMLextern value Val_file_offset(file_offset fofs); +CAMLextern file_offset File_offset_val(value v); +#endif + +#endif /* _io_ */ diff --git a/byterun/lexing.c b/byterun/lexing.c new file mode 100644 index 00000000..26eea10b --- /dev/null +++ b/byterun/lexing.c @@ -0,0 +1,231 @@ +/***********************************************************************/ +/* */ +/* 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: lexing.c,v 1.25 2002/12/16 16:42:13 doligez Exp $ */ + +/* The table-driven automaton for lexers generated by camllex. */ + +#include "fail.h" +#include "mlvalues.h" +#include "stacks.h" + +struct lexer_buffer { + value refill_buff; + value lex_buffer; + value lex_buffer_len; + value lex_abs_pos; + value lex_start_pos; + value lex_curr_pos; + value lex_last_pos; + value lex_last_action; + value lex_eof_reached; + value lex_mem; + value lex_start_p; + value lex_curr_p; +}; + +struct lexing_table { + value lex_base; + value lex_backtrk; + value lex_default; + value lex_trans; + value lex_check; + value lex_base_code; + value lex_backtrk_code; + value lex_default_code; + value lex_trans_code; + value lex_check_code; + value lex_code; +}; + +#if defined(ARCH_BIG_ENDIAN) || SIZEOF_SHORT != 2 +#define Short(tbl,n) \ + (*((unsigned char *)((tbl) + (n) * 2)) + \ + (*((schar *)((tbl) + (n) * 2 + 1)) << 8)) +#else +#define Short(tbl,n) (((short *)(tbl))[(n)]) +#endif + +CAMLprim value lex_engine(struct lexing_table *tbl, value start_state, + struct lexer_buffer *lexbuf) +{ + int state, base, backtrk, c; + + state = Int_val(start_state); + if (state >= 0) { + /* First entry */ + lexbuf->lex_last_pos = lexbuf->lex_start_pos = lexbuf->lex_curr_pos; + lexbuf->lex_last_action = Val_int(-1); + } else { + /* Reentry after refill */ + state = -state - 1; + } + while(1) { + /* Lookup base address or action number for current state */ + base = Short(tbl->lex_base, state); + if (base < 0) return Val_int(-base-1); + /* See if it's a backtrack point */ + backtrk = Short(tbl->lex_backtrk, state); + if (backtrk >= 0) { + lexbuf->lex_last_pos = lexbuf->lex_curr_pos; + lexbuf->lex_last_action = Val_int(backtrk); + } + /* See if we need a refill */ + if (lexbuf->lex_curr_pos >= lexbuf->lex_buffer_len){ + if (lexbuf->lex_eof_reached == Val_bool (0)){ + return Val_int(-state - 1); + }else{ + c = 256; + } + }else{ + /* Read next input char */ + c = Byte_u(lexbuf->lex_buffer, Long_val(lexbuf->lex_curr_pos)); + lexbuf->lex_curr_pos += 2; + } + /* Determine next state */ + if (Short(tbl->lex_check, base + c) == state) + state = Short(tbl->lex_trans, base + c); + else + state = Short(tbl->lex_default, state); + /* If no transition on this char, return to last backtrack point */ + if (state < 0) { + lexbuf->lex_curr_pos = lexbuf->lex_last_pos; + if (lexbuf->lex_last_action == Val_int(-1)) { + failwith("lexing: empty token"); + } else { + return lexbuf->lex_last_action; + } + }else{ + /* Erase the EOF condition only if the EOF pseudo-character was + consumed by the automaton (i.e. there was no backtrack above) + */ + if (c == 256) lexbuf->lex_eof_reached = Val_bool (0); + } + } +} + +/***********************************************/ +/* New lexer engine, with memory of positions */ +/***********************************************/ + +static void run_mem(char *pc, value mem, value curr_pos) { + for (;;) { + unsigned char dst, src ; + + dst = *pc++ ; + if (dst == 0xff) + return ; + src = *pc++ ; + if (src == 0xff) { + /* fprintf(stderr,"[%hhu] <- %d\n",dst,Int_val(curr_pos)) ;*/ + Field(mem,dst) = curr_pos ; + } else { + /* fprintf(stderr,"[%hhu] <- [%hhu]\n",dst,src) ; */ + Field(mem,dst) = Field(mem,src) ; + } + } +} + +static void run_tag(char *pc, value mem) { + for (;;) { + unsigned char dst, src ; + + dst = *pc++ ; + if (dst == 0xff) + return ; + src = *pc++ ; + if (src == 0xff) { + /* fprintf(stderr,"[%hhu] <- -1\n",dst) ; */ + Field(mem,dst) = Val_int(-1) ; + } else { + /* fprintf(stderr,"[%hhu] <- [%hhu]\n",dst,src) ; */ + Field(mem,dst) = Field(mem,src) ; + } + } +} + +CAMLprim value new_lex_engine(struct lexing_table *tbl, value start_state, + struct lexer_buffer *lexbuf) +{ + int state, base, backtrk, c, pstate ; + state = Int_val(start_state); + if (state >= 0) { + /* First entry */ + lexbuf->lex_last_pos = lexbuf->lex_start_pos = lexbuf->lex_curr_pos; + lexbuf->lex_last_action = Val_int(-1); + } else { + /* Reentry after refill */ + state = -state - 1; + } + while(1) { + /* Lookup base address or action number for current state */ + base = Short(tbl->lex_base, state); + if (base < 0) { + int pc_off = Short(tbl->lex_base_code, state) ; + run_tag(Bp_val(tbl->lex_code) + pc_off, lexbuf->lex_mem); + /* fprintf(stderr,"Perform: %d\n",-base-1) ; */ + return Val_int(-base-1); + } + /* See if it's a backtrack point */ + backtrk = Short(tbl->lex_backtrk, state); + if (backtrk >= 0) { + int pc_off = Short(tbl->lex_backtrk_code, state); + run_tag(Bp_val(tbl->lex_code) + pc_off, lexbuf->lex_mem); + lexbuf->lex_last_pos = lexbuf->lex_curr_pos; + lexbuf->lex_last_action = Val_int(backtrk); + + } + /* See if we need a refill */ + if (lexbuf->lex_curr_pos >= lexbuf->lex_buffer_len){ + if (lexbuf->lex_eof_reached == Val_bool (0)){ + return Val_int(-state - 1); + }else{ + c = 256; + } + }else{ + /* Read next input char */ + c = Byte_u(lexbuf->lex_buffer, Long_val(lexbuf->lex_curr_pos)); + lexbuf->lex_curr_pos += 2; + } + /* Determine next state */ + pstate=state ; + if (Short(tbl->lex_check, base + c) == state) + state = Short(tbl->lex_trans, base + c); + else + state = Short(tbl->lex_default, state); + /* If no transition on this char, return to last backtrack point */ + if (state < 0) { + lexbuf->lex_curr_pos = lexbuf->lex_last_pos; + if (lexbuf->lex_last_action == Val_int(-1)) { + failwith("lexing: empty token"); + } else { + return lexbuf->lex_last_action; + } + }else{ + /* If some transition, get and perform memory moves */ + int base_code = Short(tbl->lex_base_code, pstate) ; + int pc_off ; + if (Short(tbl->lex_check_code, base_code + c) == pstate) + pc_off = Short(tbl->lex_trans_code, base_code + c) ; + else + pc_off = Short(tbl->lex_default_code, pstate) ; + if (pc_off > 0) + run_mem(Bp_val(tbl->lex_code) + pc_off, lexbuf->lex_mem, lexbuf->lex_curr_pos) ; + /* Erase the EOF condition only if the EOF pseudo-character was + consumed by the automaton (i.e. there was no backtrack above) + */ + if (c == 256) lexbuf->lex_eof_reached = Val_bool (0); + } + } +} + diff --git a/byterun/macintosh.c b/byterun/macintosh.c new file mode 100644 index 00000000..6c2da406 --- /dev/null +++ b/byterun/macintosh.c @@ -0,0 +1,319 @@ +/***********************************************************************/ +/* */ +/* Objective Caml */ +/* */ +/* Damien Doligez, projet Para, 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: macintosh.c,v 1.12 2001/12/13 13:59:22 doligez Exp $ */ + +/* MacOS-specific stuff */ + +#include +#include + +#include +#include +#include +#include +#include +#include +#include +#include + +#include "misc.h" +#include "rotatecursor.h" + +/* Unix emulation stuff */ + +static short prevdir = 0; + +int chdir (char *dir) +{ + WDPBRec pb; + int result; + short curdir; + + pb.ioCompletion = NULL; + pb.ioNamePtr = c2pstr (dir); + pb.ioVRefNum = 0; + pb.ioWDProcID = 'Caml'; + pb.ioWDDirID = 0; + result = PBOpenWDSync (&pb); + p2cstr ((unsigned char *) dir); + if (result != noErr) return -1; + curdir = pb.ioVRefNum; + result = SetVol (NULL, curdir); + if (result != noErr) return -1; + if (prevdir != 0){ + pb.ioVRefNum = prevdir; + PBCloseWDSync (&pb); + } + prevdir = curdir; + return 0; +} + +Handle macos_getfullpathname (short vrefnum, long dirid) +{ + Handle result = NewHandle (0); + CInfoPBRec mypb; + Str255 dirname; + OSErr err; + + if (result == NULL) goto failed; + + mypb.dirInfo.ioNamePtr = dirname; + mypb.dirInfo.ioVRefNum = vrefnum; + mypb.dirInfo.ioDrParID = dirid; + mypb.dirInfo.ioFDirIndex = -1; + + do{ + mypb.dirInfo.ioDrDirID = mypb.dirInfo.ioDrParID; + err = PBGetCatInfo (&mypb, false); + if (err) goto failed; + Munger (result, 0, NULL, 0, ":", 1); + Munger (result, 0, NULL, 0, dirname+1, dirname[0]); + /* XXX out of memory ?! */ + }while (mypb.dirInfo.ioDrDirID != fsRtDirID); + return result; + + failed: + if (result != NULL) DisposeHandle (result); + return NULL; +} + +char *getcwd (char *buf, size_t size) +{ + size_t len; + + Handle path = macos_getfullpathname (0, 0); + if (path == NULL) return NULL; + + len = GetHandleSize (path); + + if (len+1 >= size){ + DisposeHandle (path); + return NULL; + } + if (buf == NULL){ + buf = malloc (len+1); + if (buf == NULL) return NULL; + } + memcpy (buf, *path, len); + buf [len] = '\000'; + DisposeHandle (path); + return buf; +} + +pascal Boolean system_idleproc (const EventRecord *event, long *sleepTime, + RgnHandle *mouseRgn) +{ + static RgnHandle myregion = NULL; + EventRecord evt; + + if (myregion == NULL){ + myregion = NewRgn (); + SetRectRgn (myregion, -32000, -32000, 32000, 32000); + } + + /* XXX standalone appli: process event */ + *mouseRgn = myregion; + *sleepTime = 3; + if (EventAvail (keyDownMask, &evt) + && (evt.modifiers & cmdKey) + && ((evt.message & charCodeMask) == '.')){ + return true; + }else{ + return false; + } +} + +void quote (char *buf, long buflen) +{ + long i, j; + + j = 2; + for (i = 0; buf[i] != '\0'; i++){ + if (buf[i] == '\'') j += 3; + ++ j; + } + if (j >= buflen) return; + + buf[j--] = '\0'; + buf[j--] = '\''; + while (i > 0){ + -- i; + buf[j--] = buf[i]; + if (buf[i] == '\''){ + buf[j--] = '\''; + buf[j--] = '\266'; + buf[j--] = '\''; + } + } + buf[j] = '\''; Assert (j == 0); +} + +int system (char const *cmd) +{ + char *fmt = "directory %s; %s"; + char *cmdline; + char *buf; + #define buf_size 66000 + + static AEIdleUPP myIdleProcUPP = NULL; + AEAddressDesc serveraddr; + AppleEvent myevent, reply; + OSType toolserver_sig = 'MPSX'; + DescType ret_type; + OSErr err = noErr; + long event_status = 0, ret_size; + int result; + + /* once only */ + if (myIdleProcUPP == NULL) myIdleProcUPP = NewAEIdleProc (system_idleproc); + + SetCursor (*GetCursor (watchCursor)); + + buf = malloc (buf_size); + if (buf == NULL) goto failed_malloc_buf; + + /* Create the command line */ + getcwd (buf, buf_size); + quote (buf, buf_size); + cmdline = malloc (strlen (fmt) + strlen (cmd) + strlen (buf) + 1); + if (cmdline == NULL) goto failed_malloc_cmdline; + sprintf (cmdline, fmt, buf, cmd); + + /* Send the event and get the reply */ + err = AECreateDesc (typeApplSignature, &toolserver_sig, + sizeof (toolserver_sig), &serveraddr); + if (err != noErr) goto failed_AECreateDesc; + err = AECreateAppleEvent ('misc', 'dosc', &serveraddr, kAutoGenerateReturnID, + kAnyTransactionID, &myevent); + if (err != noErr) goto failed_AECreateAppleEvent; + err = AEPutParamPtr (&myevent, '----', 'TEXT', cmdline, strlen (cmdline)); + if (err != noErr) goto failed_AEPutParamPtr; + err = AESend (&myevent, &reply, kAEWaitReply + kAENeverInteract, + kAENormalPriority, kNoTimeOut, myIdleProcUPP, NULL); + if (err != noErr) goto failed_AESend; + err = AEGetParamPtr (&reply, 'errn', typeLongInteger, &ret_type, + &event_status, sizeof (event_status), &ret_size); + if (err != noErr || event_status != noErr) goto failed_script; + err = AEGetParamPtr (&reply, 'stat', typeLongInteger, &ret_type, + &event_status, sizeof (event_status), &ret_size); + if (err != noErr || event_status != noErr) goto failed_script; + + /* forward stdout and stderr */ + err = AEGetParamPtr (&reply, 'diag', typeChar, &ret_type, + buf, buf_size, &ret_size); + if (err == noErr) write (2, buf, ret_size); + err = AEGetParamPtr (&reply, '----', typeChar, &ret_type, + buf, buf_size, &ret_size); + if (err == noErr) write (1, buf, ret_size); + + AEDisposeDesc (&reply); + AEDisposeDesc (&myevent); + AEDisposeDesc (&serveraddr); + free (cmdline); + free (buf); + RotateCursor (32); + return 0; + + failed_script: + AEDisposeDesc (&reply); + failed_AESend: + failed_AEPutParamPtr: + AEDisposeDesc (&myevent); + failed_AECreateAppleEvent: + AEDisposeDesc (&serveraddr); + failed_AECreateDesc: + free (cmdline); + failed_malloc_cmdline: + free (buf); + failed_malloc_buf: + if (err != noErr) result = err; + else if (event_status != 0) result = event_status; + else result = 1; + if (result == 0 || result == -1) result = 1; + RotateCursor (32); + return result; +} + +/* We don't need search_exe_in_path on MacOS 9 because there + are no #! scripts */ + +char *search_exe_in_path (char * name) +{ + return name; +} + + +/* O'Caml's use use of dynamic linking is Unix-specific, these are functions + from dynlink.c without the dynamic linking stuff. +*/ + +#include "misc.h" +#include "mlvalues.h" +#include "prims.h" + +struct ext_table shared_libs_path; +struct ext_table prim_table; + +static c_primitive lookup_primitive(char * name) +{ + int i; + void * res; + + for (i = 0; names_of_builtin_cprim[i] != NULL; i++) { + if (strcmp(name, names_of_builtin_cprim[i]) == 0) + return builtin_cprim[i]; + } + return NULL; +} + +void build_primitive_table(char * lib_path, + char * libs, + char * req_prims) +{ + char * p; + + ext_table_init(&prim_table, 0x180); + for (p = req_prims; *p != 0; p += strlen(p) + 1) { + c_primitive prim = lookup_primitive(p); + if (prim == NULL) + fatal_error_arg("Fatal error: unknown C primitive `%s'\n", p); + ext_table_add(&prim_table, (void *) prim); + } +} + +value dynlink_open_lib (value filename) +{ + return Val_unit; +} + +value dynlink_close_lib(value handle) +{ + return Val_unit; +} + +value dynlink_lookup_symbol(value handle, value symbolname) +{ + return Val_unit; +} + +value dynlink_add_primitive(value handle) +{ + invalid_argument("dynlink_add_primitive"); + return Val_unit; /* not reached */ +} + +value dynlink_get_current_libs(value unit) +{ + return Atom (0); +} diff --git a/byterun/macintosh.h b/byterun/macintosh.h new file mode 100644 index 00000000..5266f688 --- /dev/null +++ b/byterun/macintosh.h @@ -0,0 +1,19 @@ +/***********************************************************************/ +/* */ +/* 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: macintosh.h,v 1.2 2001/12/07 13:39:31 xleroy Exp $ */ + +/* MacOS-specific stuff */ + +#define WIFEXITED(x) 1 +#define WEXITSTATUS(x) (x) diff --git a/byterun/main.c b/byterun/main.c new file mode 100644 index 00000000..2ca175f9 --- /dev/null +++ b/byterun/main.c @@ -0,0 +1,46 @@ +/***********************************************************************/ +/* */ +/* 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: main.c,v 1.33 2002/06/07 09:49:37 xleroy Exp $ */ + +/* Main entry point (can be overridden by a user-provided main() + function that calls caml_main() later). */ + +#include "misc.h" +#include "mlvalues.h" +#include "sys.h" + +CAMLextern void caml_main (char **); + +#ifdef _WIN32 +CAMLextern void expand_command_line (int *, char ***); +#endif + +#if macintosh +#include "rotatecursor.h" +#include "signals.h" +#endif + +int main(int argc, char **argv) +{ +#ifdef _WIN32 + /* Expand wildcards and diversions in command line */ + expand_command_line(&argc, &argv); +#endif +#if macintosh + rotatecursor_options (&something_to_do, 0, NULL); +#endif /* macintosh */ + caml_main(argv); + sys_exit(Val_int(0)); + return 0; /* not reached */ +} diff --git a/byterun/major_gc.c b/byterun/major_gc.c new file mode 100644 index 00000000..715f4497 --- /dev/null +++ b/byterun/major_gc.c @@ -0,0 +1,458 @@ +/***********************************************************************/ +/* */ +/* Objective Caml */ +/* */ +/* Damien Doligez, projet Para, 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: major_gc.c,v 1.45 2002/12/15 23:27:06 doligez Exp $ */ + +#include + +#include "compact.h" +#include "custom.h" +#include "config.h" +#include "fail.h" +#include "finalise.h" +#include "freelist.h" +#include "gc.h" +#include "gc_ctrl.h" +#include "major_gc.h" +#include "misc.h" +#include "mlvalues.h" +#include "roots.h" +#include "weak.h" + +unsigned long percent_free; +long major_heap_increment; +char *heap_start, *heap_end; +page_table_entry *page_table; +asize_t page_low, page_high; +char *gc_sweep_hp; +int gc_phase; /* always Phase_mark, Phase_sweep, or Phase_idle */ +static value *gray_vals; +value *gray_vals_cur, *gray_vals_end; +static asize_t gray_vals_size; +static int heap_is_pure; /* The heap is pure if the only gray objects + below [markhp] are also in [gray_vals]. */ +unsigned long allocated_words; +double extra_heap_memory; +unsigned long fl_size_at_phase_change = 0; + +extern char *fl_merge; /* Defined in freelist.c. */ + +static char *markhp, *chunk, *limit; + +static int gc_subphase; /* Subphase_main, Subphase_weak, Subphase_final */ +#define Subphase_main 10 +#define Subphase_weak 11 +#define Subphase_final 12 +static value *weak_prev; + +static void realloc_gray_vals (void) +{ + value *new; + + Assert (gray_vals_cur == gray_vals_end); + if (gray_vals_size < stat_heap_size / 128){ + gc_message (0x08, "Growing gray_vals to %luk bytes\n", + (long) gray_vals_size * sizeof (value) / 512); + new = (value *) realloc ((char *) gray_vals, + 2 * gray_vals_size * sizeof (value)); + if (new == NULL){ + gc_message (0x08, "No room for growing gray_vals\n", 0); + gray_vals_cur = gray_vals; + heap_is_pure = 0; + }else{ + gray_vals = new; + gray_vals_cur = gray_vals + gray_vals_size; + gray_vals_size *= 2; + gray_vals_end = gray_vals + gray_vals_size; + } + }else{ + gray_vals_cur = gray_vals + gray_vals_size / 2; + heap_is_pure = 0; + } +} + +void darken (value v, value *p /* not used */) +{ + if (Is_block (v) && Is_in_heap (v)) { + if (Tag_val(v) == Infix_tag) v -= Infix_offset_val(v); + if (Is_white_val (v)){ + Hd_val (v) = Grayhd_hd (Hd_val (v)); + *gray_vals_cur++ = v; + if (gray_vals_cur >= gray_vals_end) realloc_gray_vals (); + } + } +} + +static void start_cycle (void) +{ + Assert (gc_phase == Phase_idle); + Assert (gray_vals_cur == gray_vals); + gc_message (0x01, "Starting new major GC cycle\n", 0); + darken_all_roots(); + gc_phase = Phase_mark; + gc_subphase = Subphase_main; + markhp = NULL; +#ifdef DEBUG + heap_check (); +#endif +} + +static void mark_slice (long work) +{ + value *gray_vals_ptr; /* Local copy of gray_vals_cur */ + value v, child; + header_t hd; + mlsize_t size, i; + + gc_message (0x40, "Marking %ld words\n", work); + gray_vals_ptr = gray_vals_cur; + while (work > 0){ + if (gray_vals_ptr > gray_vals){ + v = *--gray_vals_ptr; + hd = Hd_val(v); + Assert (Is_gray_hd (hd)); + Hd_val (v) = Blackhd_hd (hd); + size = Wosize_hd (hd); + if (Tag_hd (hd) < No_scan_tag){ + for (i = 0; i < size; i++){ + child = Field (v, i); + if (Is_block (child) && Is_in_heap (child)) { + hd = Hd_val (child); + if (Tag_hd (hd) == Forward_tag){ + value f = Forward_val (child); + if (Is_block (f) && (Is_young (f) || Is_in_heap (f)) + && (Tag_val (f) == Forward_tag || Tag_val (f) == Lazy_tag)){ + /* Do not short-circuit the pointer. */ + }else{ + Field (v, i) = f; + } + } + else if (Tag_hd(hd) == Infix_tag) { + child -= Infix_offset_val(child); + hd = Hd_val(child); + } + if (Is_white_hd (hd)){ + Hd_val (child) = Grayhd_hd (hd); + *gray_vals_ptr++ = child; + if (gray_vals_ptr >= gray_vals_end) { + gray_vals_cur = gray_vals_ptr; + realloc_gray_vals (); + gray_vals_ptr = gray_vals_cur; + } + } + } + } + } + work -= Whsize_wosize(size); + }else if (markhp != NULL){ + if (markhp == limit){ + chunk = Chunk_next (chunk); + if (chunk == NULL){ + markhp = NULL; + }else{ + markhp = chunk; + limit = chunk + Chunk_size (chunk); + } + }else{ + if (Is_gray_val (Val_hp (markhp))){ + Assert (gray_vals_ptr == gray_vals); + *gray_vals_ptr++ = Val_hp (markhp); + } + markhp += Bhsize_hp (markhp); + } + }else if (!heap_is_pure){ + heap_is_pure = 1; + chunk = heap_start; + markhp = chunk; + limit = chunk + Chunk_size (chunk); + }else if (gc_subphase == Subphase_main){ + /* The main marking phase is over. Start removing weak pointers to + dead values. */ + gc_subphase = Subphase_weak; + weak_prev = &weak_list_head; + }else if (gc_subphase == Subphase_weak){ + value cur, curfield; + mlsize_t sz, i; + header_t hd; + + cur = *weak_prev; + if (cur != (value) NULL){ + hd = Hd_val (cur); + if (Color_hd (hd) == Caml_white){ + /* The whole array is dead, remove it from the list. */ + *weak_prev = Field (cur, 0); + }else{ + sz = Wosize_hd (hd); + for (i = 1; i < sz; i++){ + curfield = Field (cur, i); + weak_again: + if (curfield != 0 && Is_block (curfield) && Is_in_heap (curfield)){ + if (Tag_val (curfield) == Forward_tag){ + value f = Forward_val (curfield); + if (Is_block (f) && (Is_young (f) || Is_in_heap (f))){ + if (Tag_val (f) == Forward_tag || Tag_val (f) == Lazy_tag){ + /* Do not short-circuit the pointer. */ + }else{ + Field (cur, i) = curfield = f; + goto weak_again; + } + } + } + if (Is_white_val (curfield)){ + Field (cur, i) = 0; + } + } + } + weak_prev = &Field (cur, 0); + } + work -= Whsize_hd (hd); + }else{ + /* Subphase_weak is done. Handle finalised values. */ + gray_vals_cur = gray_vals_ptr; + final_update (); + gray_vals_ptr = gray_vals_cur; + gc_subphase = Subphase_final; + } + }else{ + Assert (gc_subphase == Subphase_final); + /* Initialise the sweep phase. */ + gray_vals_cur = gray_vals_ptr; + gc_sweep_hp = heap_start; + fl_init_merge (); + gc_phase = Phase_sweep; + chunk = heap_start; + gc_sweep_hp = chunk; + limit = chunk + Chunk_size (chunk); + work = 0; + fl_size_at_phase_change = fl_cur_size; + } + } + gray_vals_cur = gray_vals_ptr; +} + +static void sweep_slice (long work) +{ + char *hp; + header_t hd; + + gc_message (0x40, "Sweeping %ld words\n", work); + while (work > 0){ + if (gc_sweep_hp < limit){ + hp = gc_sweep_hp; + hd = Hd_hp (hp); + work -= Whsize_hd (hd); + gc_sweep_hp += Bhsize_hd (hd); + switch (Color_hd (hd)){ + case Caml_white: + if (Tag_hd (hd) == Custom_tag){ + void (*final_fun)(value) = Custom_ops_val(Val_hp(hp))->finalize; + if (final_fun != NULL) final_fun(Val_hp(hp)); + } + gc_sweep_hp = fl_merge_block (Bp_hp (hp)); + break; + case Caml_blue: + /* Only the blocks of the free-list are blue. See [freelist.c]. */ + fl_merge = Bp_hp (hp); + break; + default: /* gray or black */ + Assert (Color_hd (hd) == Caml_black); + Hd_hp (hp) = Whitehd_hd (hd); + break; + } + Assert (gc_sweep_hp <= limit); + }else{ + chunk = Chunk_next (chunk); + if (chunk == NULL){ + /* Sweeping is done. */ + ++ stat_major_collections; + work = 0; + gc_phase = Phase_idle; + }else{ + gc_sweep_hp = chunk; + limit = chunk + Chunk_size (chunk); + } + } + } +} + +/* The main entry point for the GC. Called after each minor GC. + [howmuch] is the amount of work to do, 0 to let the GC compute it. + Return the computed amount of work to do. + */ +long major_collection_slice (long howmuch) +{ + double p; + long computed_work; + /* + Free memory at the start of the GC cycle (garbage + free list) (assumed): + FM = stat_heap_size * percent_free / (100 + percent_free) + + Assuming steady state and enforcing a constant allocation rate, then + FM is divided in 2/3 for garbage and 1/3 for free list. + G = 2 * FM / 3 + G is also the amount of memory that will be used during this slice + (still assuming steady state). + + Proportion of G consumed since the previous slice: + PH = allocated_words / G + = allocated_words * 3 * (100 + percent_free) + / (2 * stat_heap_size * percent_free) + Proportion of extra-heap memory consumed since the previous slice: + PE = extra_heap_memory + Proportion of total work to do in this slice: + P = max (PH, PE) + Amount of marking work for the GC cycle: + MW = stat_heap_size * 100 / (100 + percent_free) + Amount of sweeping work for the GC cycle: + SW = stat_heap_size + Amount of marking work for this slice: + MS = P * MW + MS = P * stat_heap_size * 100 / (100 + percent_free) + Amount of sweeping work for this slice: + SS = P * SW + SS = P * stat_heap_size + This slice will either mark 2*MS words or sweep 2*SS words. + */ + + if (gc_phase == Phase_idle) start_cycle (); + + p = (double) allocated_words * 3.0 * (100 + percent_free) + / Wsize_bsize (stat_heap_size) / percent_free / 2.0; + if (p < extra_heap_memory) p = extra_heap_memory; + + gc_message (0x40, "allocated_words = %lu\n", allocated_words); + gc_message (0x40, "extra_heap_memory = %luu\n", + (unsigned long) (extra_heap_memory * 1000000)); + gc_message (0x40, "amount of work to do = %luu\n", + (unsigned long) (p * 1000000)); + + if (gc_phase == Phase_mark){ + computed_work = 2 * (long) (p * Wsize_bsize (stat_heap_size) * 100 + / (100+percent_free)); + }else{ + computed_work = 2 * (long) (p * Wsize_bsize (stat_heap_size)); + } + gc_message (0x40, "ordered work = %ld words\n", howmuch); + gc_message (0x40, "computed work = %ld words\n", computed_work); + if (howmuch == 0) howmuch = computed_work; + if (gc_phase == Phase_mark){ + mark_slice (howmuch); + gc_message (0x02, "!", 0); + }else{ + Assert (gc_phase == Phase_sweep); + sweep_slice (howmuch); + gc_message (0x02, "$", 0); + } + + if (gc_phase == Phase_idle) compact_heap_maybe (); + + stat_major_words += allocated_words; + allocated_words = 0; + extra_heap_memory = 0.0; + return computed_work; +} + +/* The minor heap must be empty when this function is called; + the minor heap is empty when this function returns. +*/ +/* This does not call compact_heap_maybe because the estimations of + free and live memory are only valid for a cycle done incrementally. + Besides, this function is called by compact_heap_maybe. +*/ +void finish_major_cycle (void) +{ + if (gc_phase == Phase_idle) start_cycle (); + while (gc_phase == Phase_mark) mark_slice (LONG_MAX); + Assert (gc_phase == Phase_sweep); + while (gc_phase == Phase_sweep) sweep_slice (LONG_MAX); + Assert (gc_phase == Phase_idle); + stat_major_words += allocated_words; + allocated_words = 0; +} + +/* Make sure the request is at least Heap_chunk_min and round it up + to a multiple of the page size. +*/ +static asize_t clip_heap_chunk_size (asize_t request) +{ + if (request < Bsize_wsize (Heap_chunk_min)){ + request = Bsize_wsize (Heap_chunk_min); + } + return ((request + Page_size - 1) >> Page_log) << Page_log; +} + +/* Make sure the request is >= major_heap_increment, then call + clip_heap_chunk_size, then make sure the result is >= request. +*/ +asize_t round_heap_chunk_size (asize_t request) +{ + asize_t result = request; + + if (result < major_heap_increment){ + result = major_heap_increment; + } + result = clip_heap_chunk_size (result); + + if (result < request){ + raise_out_of_memory (); + return 0; /* not reached */ + } + return result; +} + +void init_major_heap (asize_t heap_size) +{ + asize_t i; + void *block; + asize_t page_table_size; + page_table_entry *page_table_block; + + stat_heap_size = clip_heap_chunk_size (heap_size); + stat_top_heap_size = stat_heap_size; + Assert (stat_heap_size % Page_size == 0); + heap_start = (char *) alloc_for_heap (stat_heap_size); + if (heap_start == NULL) + fatal_error ("Fatal error: not enough memory for the initial heap.\n"); + Chunk_next (heap_start) = NULL; + heap_end = heap_start + stat_heap_size; + Assert ((unsigned long) heap_end % Page_size == 0); + + stat_heap_chunks = 1; + + page_low = Page (heap_start); + page_high = Page (heap_end); + + page_table_size = page_high - page_low; + page_table_block = + (page_table_entry *) malloc (page_table_size * sizeof (page_table_entry)); + if (page_table_block == NULL){ + fatal_error ("Fatal error: not enough memory for the initial heap.\n"); + } + page_table = page_table_block - page_low; + for (i = Page (heap_start); i < Page (heap_end); i++){ + page_table [i] = In_heap; + } + + fl_init_merge (); + make_free_blocks ((value *) heap_start, Wsize_bsize (stat_heap_size), 1); + gc_phase = Phase_idle; + gray_vals_size = 2048; + gray_vals = (value *) malloc (gray_vals_size * sizeof (value)); + if (gray_vals == NULL) + fatal_error ("Fatal error: not enough memory for the initial heap.\n"); + gray_vals_cur = gray_vals; + gray_vals_end = gray_vals + gray_vals_size; + heap_is_pure = 1; + allocated_words = 0; + extra_heap_memory = 0.0; +} diff --git a/byterun/major_gc.h b/byterun/major_gc.h new file mode 100644 index 00000000..7d433b13 --- /dev/null +++ b/byterun/major_gc.h @@ -0,0 +1,73 @@ +/***********************************************************************/ +/* */ +/* Objective Caml */ +/* */ +/* Damien Doligez, projet Para, 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: major_gc.h,v 1.17 2002/11/15 16:15:19 doligez Exp $ */ + +#ifndef _major_gc_ +#define _major_gc_ + + +#include "freelist.h" +#include "misc.h" + +typedef struct { + void *block; /* address of the malloced block this chunk live in */ + asize_t alloc; /* in bytes, used for compaction */ + asize_t size; /* in bytes */ + char *next; +} heap_chunk_head; + +#define Chunk_size(c) (((heap_chunk_head *) (c)) [-1]).size +#define Chunk_alloc(c) (((heap_chunk_head *) (c)) [-1]).alloc +#define Chunk_next(c) (((heap_chunk_head *) (c)) [-1]).next +#define Chunk_block(c) (((heap_chunk_head *) (c)) [-1]).block + +extern int gc_phase; +extern unsigned long allocated_words; +extern double extra_heap_memory; +extern unsigned long fl_size_at_phase_change; + +#define Phase_mark 0 +#define Phase_sweep 1 +#define Phase_idle 2 + +#ifdef __alpha +typedef int page_table_entry; +#else +typedef char page_table_entry; +#endif + +CAMLextern char *heap_start; +CAMLextern char *heap_end; +extern unsigned long total_heap_size; +CAMLextern page_table_entry *page_table; +extern asize_t page_low, page_high; +extern char *gc_sweep_hp; + +#define In_heap 1 +#define Not_in_heap 0 +#define Page(p) ((unsigned long) (p) >> Page_log) +#define Is_in_heap(p) \ + (Assert (Is_block ((value) (p))), \ + (addr)(p) >= (addr)heap_start && (addr)(p) < (addr)heap_end \ + && page_table [Page (p)]) + +void init_major_heap (asize_t); /* size in bytes */ +asize_t round_heap_chunk_size (asize_t); /* size in bytes */ +void darken (value, value *); +long major_collection_slice (long); +void major_collection (void); +void finish_major_cycle (void); + + +#endif /* _major_gc_ */ diff --git a/byterun/md5.c b/byterun/md5.c new file mode 100644 index 00000000..b3d58e5f --- /dev/null +++ b/byterun/md5.c @@ -0,0 +1,309 @@ +/***********************************************************************/ +/* */ +/* 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: md5.c,v 1.15 2002/04/18 07:27:38 garrigue Exp $ */ + +#include +#include "alloc.h" +#include "fail.h" +#include "md5.h" +#include "mlvalues.h" +#include "io.h" +#include "reverse.h" + +/* MD5 message digest */ + +CAMLprim value md5_string(value str, value ofs, value len) +{ + struct MD5Context ctx; + value res; + MD5Init(&ctx); + MD5Update(&ctx, &Byte_u(str, Long_val(ofs)), Long_val(len)); + res = alloc_string(16); + MD5Final(&Byte_u(res, 0), &ctx); + return res; +} + +CAMLprim value md5_chan(value vchan, value len) +{ + struct channel * chan = Channel(vchan); + struct MD5Context ctx; + value res; + long toread, read; + char buffer[4096]; + + Lock(chan); + MD5Init(&ctx); + toread = Long_val(len); + if (toread < 0){ + while (1){ + read = getblock (chan, buffer, sizeof(buffer)); + if (read == 0) break; + MD5Update (&ctx, (unsigned char *) buffer, read); + } + }else{ + while (toread > 0) { + read = getblock(chan, buffer, + toread > sizeof(buffer) ? sizeof(buffer) : toread); + if (read == 0) raise_end_of_file(); + MD5Update(&ctx, (unsigned char *) buffer, read); + toread -= read; + } + } + res = alloc_string(16); + MD5Final(&Byte_u(res, 0), &ctx); + Unlock(chan); + return res; +} + +/* + * This code implements the MD5 message-digest algorithm. + * The algorithm is due to Ron Rivest. This code was + * written by Colin Plumb in 1993, no copyright is claimed. + * This code is in the public domain; do with it what you wish. + * + * Equivalent code is available from RSA Data Security, Inc. + * This code has been tested against that, and is equivalent, + * except that you don't need to include two pages of legalese + * with every copy. + * + * To compute the message digest of a chunk of bytes, declare an + * MD5Context structure, pass it to MD5Init, call MD5Update as + * needed on buffers full of bytes, and then call MD5Final, which + * will fill a supplied 16-byte array with the digest. + */ + +#ifndef ARCH_BIG_ENDIAN +#define byteReverse(buf, len) /* Nothing */ +#else +static void byteReverse(unsigned char * buf, unsigned longs) +{ + uint32 t; + do { + t = (uint32) ((unsigned) buf[3] << 8 | buf[2]) << 16 | + ((unsigned) buf[1] << 8 | buf[0]); + *(uint32 *) buf = t; + buf += 4; + } while (--longs); +} +#endif + +/* + * Start MD5 accumulation. Set bit count to 0 and buffer to mysterious + * initialization constants. + */ +CAMLexport void MD5Init(struct MD5Context *ctx) +{ + ctx->buf[0] = 0x67452301; + ctx->buf[1] = 0xefcdab89; + ctx->buf[2] = 0x98badcfe; + ctx->buf[3] = 0x10325476; + + ctx->bits[0] = 0; + ctx->bits[1] = 0; +} + +/* + * Update context to reflect the concatenation of another buffer full + * of bytes. + */ +CAMLexport void MD5Update(struct MD5Context *ctx, unsigned char *buf, + unsigned long len) +{ + uint32 t; + + /* Update bitcount */ + + t = ctx->bits[0]; + if ((ctx->bits[0] = t + ((uint32) len << 3)) < t) + ctx->bits[1]++; /* Carry from low to high */ + ctx->bits[1] += len >> 29; + + t = (t >> 3) & 0x3f; /* Bytes already in shsInfo->data */ + + /* Handle any leading odd-sized chunks */ + + if (t) { + unsigned char *p = (unsigned char *) ctx->in + t; + + t = 64 - t; + if (len < t) { + memcpy(p, buf, len); + return; + } + memcpy(p, buf, t); + byteReverse(ctx->in, 16); + MD5Transform(ctx->buf, (uint32 *) ctx->in); + buf += t; + len -= t; + } + /* Process data in 64-byte chunks */ + + while (len >= 64) { + memcpy(ctx->in, buf, 64); + byteReverse(ctx->in, 16); + MD5Transform(ctx->buf, (uint32 *) ctx->in); + buf += 64; + len -= 64; + } + + /* Handle any remaining bytes of data. */ + + memcpy(ctx->in, buf, len); +} + +/* + * Final wrapup - pad to 64-byte boundary with the bit pattern + * 1 0* (64-bit count of bits processed, MSB-first) + */ +CAMLexport void MD5Final(unsigned char *digest, struct MD5Context *ctx) +{ + unsigned count; + unsigned char *p; + + /* Compute number of bytes mod 64 */ + count = (ctx->bits[0] >> 3) & 0x3F; + + /* Set the first char of padding to 0x80. This is safe since there is + always at least one byte free */ + p = ctx->in + count; + *p++ = 0x80; + + /* Bytes of padding needed to make 64 bytes */ + count = 64 - 1 - count; + + /* Pad out to 56 mod 64 */ + if (count < 8) { + /* Two lots of padding: Pad the first block to 64 bytes */ + memset(p, 0, count); + byteReverse(ctx->in, 16); + MD5Transform(ctx->buf, (uint32 *) ctx->in); + + /* Now fill the next block with 56 bytes */ + memset(ctx->in, 0, 56); + } else { + /* Pad block to 56 bytes */ + memset(p, 0, count - 8); + } + byteReverse(ctx->in, 14); + + /* Append length in bits and transform */ + ((uint32 *) ctx->in)[14] = ctx->bits[0]; + ((uint32 *) ctx->in)[15] = ctx->bits[1]; + + MD5Transform(ctx->buf, (uint32 *) ctx->in); + byteReverse((unsigned char *) ctx->buf, 4); + memcpy(digest, ctx->buf, 16); + memset(ctx, 0, sizeof(ctx)); /* In case it's sensitive */ +} + +/* The four core functions - F1 is optimized somewhat */ + +/* #define F1(x, y, z) (x & y | ~x & z) */ +#define F1(x, y, z) (z ^ (x & (y ^ z))) +#define F2(x, y, z) F1(z, x, y) +#define F3(x, y, z) (x ^ y ^ z) +#define F4(x, y, z) (y ^ (x | ~z)) + +/* This is the central step in the MD5 algorithm. */ +#define MD5STEP(f, w, x, y, z, data, s) \ + ( w += f(x, y, z) + data, w = w<>(32-s), w += x ) + +/* + * The core of the MD5 algorithm, this alters an existing MD5 hash to + * reflect the addition of 16 longwords of new data. MD5Update blocks + * the data and converts bytes into longwords for this routine. + */ +CAMLexport void MD5Transform(uint32 *buf, uint32 *in) +{ + register uint32 a, b, c, d; + + a = buf[0]; + b = buf[1]; + c = buf[2]; + d = buf[3]; + + MD5STEP(F1, a, b, c, d, in[0] + 0xd76aa478, 7); + MD5STEP(F1, d, a, b, c, in[1] + 0xe8c7b756, 12); + MD5STEP(F1, c, d, a, b, in[2] + 0x242070db, 17); + MD5STEP(F1, b, c, d, a, in[3] + 0xc1bdceee, 22); + MD5STEP(F1, a, b, c, d, in[4] + 0xf57c0faf, 7); + MD5STEP(F1, d, a, b, c, in[5] + 0x4787c62a, 12); + MD5STEP(F1, c, d, a, b, in[6] + 0xa8304613, 17); + MD5STEP(F1, b, c, d, a, in[7] + 0xfd469501, 22); + MD5STEP(F1, a, b, c, d, in[8] + 0x698098d8, 7); + MD5STEP(F1, d, a, b, c, in[9] + 0x8b44f7af, 12); + MD5STEP(F1, c, d, a, b, in[10] + 0xffff5bb1, 17); + MD5STEP(F1, b, c, d, a, in[11] + 0x895cd7be, 22); + MD5STEP(F1, a, b, c, d, in[12] + 0x6b901122, 7); + MD5STEP(F1, d, a, b, c, in[13] + 0xfd987193, 12); + MD5STEP(F1, c, d, a, b, in[14] + 0xa679438e, 17); + MD5STEP(F1, b, c, d, a, in[15] + 0x49b40821, 22); + + MD5STEP(F2, a, b, c, d, in[1] + 0xf61e2562, 5); + MD5STEP(F2, d, a, b, c, in[6] + 0xc040b340, 9); + MD5STEP(F2, c, d, a, b, in[11] + 0x265e5a51, 14); + MD5STEP(F2, b, c, d, a, in[0] + 0xe9b6c7aa, 20); + MD5STEP(F2, a, b, c, d, in[5] + 0xd62f105d, 5); + MD5STEP(F2, d, a, b, c, in[10] + 0x02441453, 9); + MD5STEP(F2, c, d, a, b, in[15] + 0xd8a1e681, 14); + MD5STEP(F2, b, c, d, a, in[4] + 0xe7d3fbc8, 20); + MD5STEP(F2, a, b, c, d, in[9] + 0x21e1cde6, 5); + MD5STEP(F2, d, a, b, c, in[14] + 0xc33707d6, 9); + MD5STEP(F2, c, d, a, b, in[3] + 0xf4d50d87, 14); + MD5STEP(F2, b, c, d, a, in[8] + 0x455a14ed, 20); + MD5STEP(F2, a, b, c, d, in[13] + 0xa9e3e905, 5); + MD5STEP(F2, d, a, b, c, in[2] + 0xfcefa3f8, 9); + MD5STEP(F2, c, d, a, b, in[7] + 0x676f02d9, 14); + MD5STEP(F2, b, c, d, a, in[12] + 0x8d2a4c8a, 20); + + MD5STEP(F3, a, b, c, d, in[5] + 0xfffa3942, 4); + MD5STEP(F3, d, a, b, c, in[8] + 0x8771f681, 11); + MD5STEP(F3, c, d, a, b, in[11] + 0x6d9d6122, 16); + MD5STEP(F3, b, c, d, a, in[14] + 0xfde5380c, 23); + MD5STEP(F3, a, b, c, d, in[1] + 0xa4beea44, 4); + MD5STEP(F3, d, a, b, c, in[4] + 0x4bdecfa9, 11); + MD5STEP(F3, c, d, a, b, in[7] + 0xf6bb4b60, 16); + MD5STEP(F3, b, c, d, a, in[10] + 0xbebfbc70, 23); + MD5STEP(F3, a, b, c, d, in[13] + 0x289b7ec6, 4); + MD5STEP(F3, d, a, b, c, in[0] + 0xeaa127fa, 11); + MD5STEP(F3, c, d, a, b, in[3] + 0xd4ef3085, 16); + MD5STEP(F3, b, c, d, a, in[6] + 0x04881d05, 23); + MD5STEP(F3, a, b, c, d, in[9] + 0xd9d4d039, 4); + MD5STEP(F3, d, a, b, c, in[12] + 0xe6db99e5, 11); + MD5STEP(F3, c, d, a, b, in[15] + 0x1fa27cf8, 16); + MD5STEP(F3, b, c, d, a, in[2] + 0xc4ac5665, 23); + + MD5STEP(F4, a, b, c, d, in[0] + 0xf4292244, 6); + MD5STEP(F4, d, a, b, c, in[7] + 0x432aff97, 10); + MD5STEP(F4, c, d, a, b, in[14] + 0xab9423a7, 15); + MD5STEP(F4, b, c, d, a, in[5] + 0xfc93a039, 21); + MD5STEP(F4, a, b, c, d, in[12] + 0x655b59c3, 6); + MD5STEP(F4, d, a, b, c, in[3] + 0x8f0ccc92, 10); + MD5STEP(F4, c, d, a, b, in[10] + 0xffeff47d, 15); + MD5STEP(F4, b, c, d, a, in[1] + 0x85845dd1, 21); + MD5STEP(F4, a, b, c, d, in[8] + 0x6fa87e4f, 6); + MD5STEP(F4, d, a, b, c, in[15] + 0xfe2ce6e0, 10); + MD5STEP(F4, c, d, a, b, in[6] + 0xa3014314, 15); + MD5STEP(F4, b, c, d, a, in[13] + 0x4e0811a1, 21); + MD5STEP(F4, a, b, c, d, in[4] + 0xf7537e82, 6); + MD5STEP(F4, d, a, b, c, in[11] + 0xbd3af235, 10); + MD5STEP(F4, c, d, a, b, in[2] + 0x2ad7d2bb, 15); + MD5STEP(F4, b, c, d, a, in[9] + 0xeb86d391, 21); + + buf[0] += a; + buf[1] += b; + buf[2] += c; + buf[3] += d; +} + diff --git a/byterun/md5.h b/byterun/md5.h new file mode 100644 index 00000000..1cb9ecf3 --- /dev/null +++ b/byterun/md5.h @@ -0,0 +1,41 @@ +/***********************************************************************/ +/* */ +/* 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: md5.h,v 1.10 2002/04/18 07:27:38 garrigue Exp $ */ + +/* MD5 message digest */ + +#ifndef _md5 +#define _md5 + + +#include "mlvalues.h" +#include "io.h" + +CAMLextern value md5_string (value str, value ofs, value len); +CAMLextern value md5_chan (value vchan, value len); + +struct MD5Context { + uint32 buf[4]; + uint32 bits[2]; + unsigned char in[64]; +}; + +CAMLextern void MD5Init (struct MD5Context *context); +CAMLextern void MD5Update (struct MD5Context *context, unsigned char *buf, + unsigned long len); +CAMLextern void MD5Final (unsigned char *digest, struct MD5Context *ctx); +CAMLextern void MD5Transform (uint32 *buf, uint32 *in); + + +#endif diff --git a/byterun/memory.c b/byterun/memory.c new file mode 100644 index 00000000..0befbb98 --- /dev/null +++ b/byterun/memory.c @@ -0,0 +1,360 @@ +/***********************************************************************/ +/* */ +/* Objective Caml */ +/* */ +/* Damien Doligez, projet Para, 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: memory.c,v 1.33 2002/12/12 18:59:11 doligez Exp $ */ + +#include +#include +#include "fail.h" +#include "freelist.h" +#include "gc.h" +#include "gc_ctrl.h" +#include "major_gc.h" +#include "memory.h" +#include "minor_gc.h" +#include "misc.h" +#include "mlvalues.h" +#include "signals.h" + +#ifdef USE_MMAP_INSTEAD_OF_MALLOC +extern char * aligned_mmap (asize_t size, int modulo, void ** block); +extern void aligned_munmap (char * addr, asize_t size); +#endif + +/* Allocate a block of the requested size, to be passed to + [add_to_heap] later. + [request] must be a multiple of [Page_size]. + [alloc_for_heap] returns NULL if the request cannot be satisfied. + The returned pointer is a hp, but the header must be initialized by + the caller. +*/ +char *alloc_for_heap (asize_t request) +{ + char *mem; + void *block; + Assert (request % Page_size == 0); +#ifdef USE_MMAP_INSTEAD_OF_MALLOC + mem = aligned_mmap (request + sizeof (heap_chunk_head), + sizeof (heap_chunk_head), &block); +#else + mem = aligned_malloc (request + sizeof (heap_chunk_head), + sizeof (heap_chunk_head), &block); +#endif + if (mem == NULL) return NULL; + mem += sizeof (heap_chunk_head); + Chunk_size (mem) = request; + Chunk_block (mem) = block; + return mem; +} + +/* Use this function to free a block allocated with [alloc_for_heap] + if you don't add it with [add_to_heap]. +*/ +void free_for_heap (char *mem) +{ +#ifdef USE_MMAP_INSTEAD_OF_MALLOC + aligned_munmap (Chunk_block (mem), + Chunk_size (mem) + sizeof (heap_chunk_head)); +#else + free (Chunk_block (mem)); +#endif +} + +/* Take a chunk of memory as argument, which must be the result of a + call to [alloc_for_heap], and insert it into the heap chaining. + The contents of the chunk must be a sequence of valid blocks and + fragments: no space between blocks and no trailing garbage. If + some blocks are blue, they must be added to the free list by the + caller. All other blocks must have the color [allocation_color(mem)]. + The caller must update [allocated_words] if applicable. + Return value: 0 if no error; -1 in case of error. +*/ +int add_to_heap (char *m) +{ + asize_t i; + Assert (Chunk_size (m) % Page_size == 0); +#ifdef DEBUG + /* Should check the contents of the block. */ +#endif /* debug */ + + /* Extend the page table as needed. */ + if (Page (m) < page_low){ + page_table_entry *block, *new_page_table; + asize_t new_page_low = Page (m); + asize_t new_size = page_high - new_page_low; + + gc_message (0x08, "Growing page table to %lu entries\n", new_size); + block = malloc (new_size * sizeof (page_table_entry)); + if (block == NULL){ + gc_message (0x08, "No room for growing page table\n", 0); + return -1; + } + new_page_table = block - new_page_low; + for (i = new_page_low; i < page_low; i++) new_page_table [i] = Not_in_heap; + for (i = page_low; i < page_high; i++) new_page_table [i] = page_table [i]; + free (page_table + page_low); + page_table = new_page_table; + page_low = new_page_low; + } + if (Page (m + Chunk_size (m)) > page_high){ + page_table_entry *block, *new_page_table; + asize_t new_page_high = Page (m + Chunk_size (m)); + asize_t new_size = new_page_high - page_low; + + gc_message (0x08, "Growing page table to %lu entries\n", new_size); + block = malloc (new_size * sizeof (page_table_entry)); + if (block == NULL){ + gc_message (0x08, "No room for growing page table\n", 0); + return -1; + } + new_page_table = block - page_low; + for (i = page_low; i < page_high; i++) new_page_table [i] = page_table [i]; + for (i = page_high; i < new_page_high; i++){ + new_page_table [i] = Not_in_heap; + } + free (page_table + page_low); + page_table = new_page_table; + page_high = new_page_high; + } + + /* Mark the pages as being in the heap. */ + for (i = Page (m); i < Page (m + Chunk_size (m)); i++){ + page_table [i] = In_heap; + } + + /* Chain this heap chunk. */ + { + char **last = &heap_start; + char *cur = *last; + + while (cur != NULL && cur < m){ + last = &(Chunk_next (cur)); + cur = *last; + } + Chunk_next (m) = cur; + *last = m; + + ++ stat_heap_chunks; + } + + /* Update the heap bounds as needed. */ + /* already done: if (m < heap_start) heap_start = m; */ + if (m + Chunk_size (m) > heap_end) heap_end = m + Chunk_size (m); + + stat_heap_size += Chunk_size (m); + if (stat_heap_size > stat_top_heap_size) stat_top_heap_size = stat_heap_size; + return 0; +} + +/* Allocate more memory from malloc for the heap. + Return a blue block of at least the requested size (in words). + The caller must insert the block into the free list. + The request must be less than or equal to Max_wosize. + Return NULL when out of memory. +*/ +static char *expand_heap (mlsize_t request) +{ + char *mem; + asize_t malloc_request; + + malloc_request = round_heap_chunk_size (Bhsize_wosize (request)); + gc_message (0x04, "Growing heap to %luk bytes\n", + (stat_heap_size + malloc_request) / 1024); + mem = alloc_for_heap (malloc_request); + if (mem == NULL){ + gc_message (0x04, "No room for growing heap\n", 0); + return NULL; + } + Assert (Wosize_bhsize (malloc_request) >= request); + Hd_hp (mem) = Make_header (Wosize_bhsize (malloc_request), 0, Caml_blue); + + if (add_to_heap (mem) != 0){ + free_for_heap (mem); + return NULL; + } + return Bp_hp (mem); +} + +/* Remove the heap chunk [chunk] from the heap and give the memory back + to [free]. +*/ +void shrink_heap (char *chunk) +{ + char **cp; + asize_t i; + + /* Never deallocate the first block, because heap_start is both the + first block and the base address for page numbers, and we don't + want to shift the page table, it's too messy (see above). + It will never happen anyway, because of the way compaction works. + (see compact.c) + */ + if (chunk == heap_start) return; + + stat_heap_size -= Chunk_size (chunk); + gc_message (0x04, "Shrinking heap to %luk bytes\n", stat_heap_size / 1024); + +#ifdef DEBUG + { + mlsize_t i; + for (i = 0; i < Wsize_bsize (Chunk_size (chunk)); i++){ + ((value *) chunk) [i] = Debug_free_shrink; + } + } +#endif + + -- stat_heap_chunks; + + /* Remove [chunk] from the list of chunks. */ + cp = &heap_start; + while (*cp != chunk) cp = &(Chunk_next (*cp)); + *cp = Chunk_next (chunk); + + /* Remove the pages of [chunk] from the page table. */ + for (i = Page (chunk); i < Page (chunk + Chunk_size (chunk)); i++){ + page_table [i] = Not_in_heap; + } + + /* Free the [malloc] block that contains [chunk]. */ + free_for_heap (chunk); +} + +color_t allocation_color (void *hp) +{ + if (gc_phase == Phase_mark + || (gc_phase == Phase_sweep && (addr)hp >= (addr)gc_sweep_hp)){ + return Caml_black; + }else{ + Assert (gc_phase == Phase_idle + || (gc_phase == Phase_sweep && (addr)hp < (addr)gc_sweep_hp)); + return Caml_white; + } +} + +value alloc_shr (mlsize_t wosize, tag_t tag) +{ + char *hp, *new_block; + + if (wosize > Max_wosize) raise_out_of_memory (); + hp = fl_allocate (wosize); + if (hp == NULL){ + new_block = expand_heap (wosize); + if (new_block == NULL) { + if (in_minor_collection) + fatal_error ("Fatal error: out of memory.\n"); + else + raise_out_of_memory (); + } + fl_add_block (new_block); + hp = fl_allocate (wosize); + } + + Assert (Is_in_heap (Val_hp (hp))); + + /* Inline expansion of allocation_color. */ + if (gc_phase == Phase_mark + || (gc_phase == Phase_sweep && (addr)hp >= (addr)gc_sweep_hp)){ + Hd_hp (hp) = Make_header (wosize, tag, Caml_black); + }else{ + Assert (gc_phase == Phase_idle + || (gc_phase == Phase_sweep && (addr)hp < (addr)gc_sweep_hp)); + Hd_hp (hp) = Make_header (wosize, tag, Caml_white); + } + Assert (Hd_hp (hp) == Make_header (wosize, tag, allocation_color (hp))); + allocated_words += Whsize_wosize (wosize); + if (allocated_words > Wsize_bsize (minor_heap_size)) urge_major_slice (); +#ifdef DEBUG + { + unsigned long i; + for (i = 0; i < wosize; i++){ + Field (Val_hp (hp), i) = Debug_uninit_major; + } + } +#endif + return Val_hp (hp); +} + +/* Use this function to tell the major GC to speed up when you use + finalized blocks to automatically deallocate extra-heap stuff. + The GC will do at least one cycle every [max] allocated words; + [mem] is the number of words allocated this time. + Note that only [mem/max] is relevant. You can use numbers of bytes + (or kilobytes, ...) instead of words. You can change units between + calls to [adjust_gc_speed]. +*/ +void adjust_gc_speed (mlsize_t mem, mlsize_t max) +{ + if (max == 0) max = 1; + if (mem > max) mem = max; + extra_heap_memory += (double) mem / (double) max; + if (extra_heap_memory > 1.0){ + extra_heap_memory = 1.0; + urge_major_slice (); + } + if (extra_heap_memory > (double) Wsize_bsize (minor_heap_size) + / 2.0 / (double) Wsize_bsize (stat_heap_size)) { + urge_major_slice (); + } +} + +/* You must use [initialize] to store the initial value in a field of + a shared block, unless you are sure the value is not a young block. + A block value [v] is a shared block if and only if [Is_in_heap (v)] + is true. +*/ +/* [initialize] never calls the GC, so you may call it while an block is + unfinished (i.e. just after a call to [alloc_shr].) */ +void initialize (value *fp, value val) +{ + *fp = val; + if (Is_block (val) && Is_young (val) && Is_in_heap (fp)){ + *ref_table_ptr++ = fp; + if (ref_table_ptr >= ref_table_limit){ + realloc_ref_table (); + } + } +} + +/* You must use [modify] to change a field of an existing shared block, + unless you are sure the value being overwritten is not a shared block and + the value being written is not a young block. */ +/* [modify] never calls the GC. */ +void modify (value *fp, value val) +{ + Modify (fp, val); +} + +void * stat_alloc (asize_t sz) +{ + void * result = malloc (sz); + + /* malloc() may return NULL if size is 0 */ + if (result == NULL && sz != 0) raise_out_of_memory (); +#ifdef DEBUG + memset (result, Debug_uninit_stat, sz); +#endif + return result; +} + +void stat_free (void * blk) +{ + free (blk); +} + +void * stat_resize (void * blk, asize_t sz) +{ + void * result = realloc (blk, sz); + + if (result == NULL) raise_out_of_memory (); + return result; +} diff --git a/byterun/memory.h b/byterun/memory.h new file mode 100644 index 00000000..a36de8aa --- /dev/null +++ b/byterun/memory.h @@ -0,0 +1,377 @@ +/***********************************************************************/ +/* */ +/* Objective Caml */ +/* */ +/* Damien Doligez, projet Para, 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: memory.h,v 1.41 2002/12/12 18:59:11 doligez Exp $ */ + +/* Allocation macros and functions */ + +#ifndef _memory_ +#define _memory_ + + +#include "config.h" +/* */ +#include "gc.h" +#include "major_gc.h" +#include "minor_gc.h" +/* */ +#include "misc.h" +#include "mlvalues.h" + +CAMLextern value alloc_shr (mlsize_t, tag_t); +void adjust_gc_speed (mlsize_t, mlsize_t); +CAMLextern void modify (value *, value); +CAMLextern void initialize (value *, value); +CAMLextern value check_urgent_gc (value); +CAMLextern void * stat_alloc (asize_t); /* Size in bytes. */ +CAMLextern void stat_free (void *); +CAMLextern void * stat_resize (void *, asize_t); /* Size in bytes. */ +char *alloc_for_heap (asize_t request); /* Size in bytes. */ +void free_for_heap (char *mem); +int add_to_heap (char *mem); +color_t allocation_color (void *hp); + +/* void shrink_heap (char *); Only used in compact.c */ + +/* */ + +#ifdef DEBUG +#define DEBUG_clear(result, wosize) do{ \ + unsigned long caml__DEBUG_i; \ + for (caml__DEBUG_i = 0; caml__DEBUG_i < (wosize); ++ caml__DEBUG_i){ \ + Field ((result), caml__DEBUG_i) = Debug_uninit_minor; \ + } \ +}while(0) +#else +#define DEBUG_clear(result, wosize) +#endif + +#define Alloc_small(result, wosize, tag) do{ CAMLassert (wosize >= 1); \ + CAMLassert ((tag_t) tag < 256); \ + CAMLassert ((wosize) <= Max_young_wosize); \ + young_ptr -= Bhsize_wosize (wosize); \ + if (young_ptr < young_limit){ \ + young_ptr += Bhsize_wosize (wosize); \ + Setup_for_gc; \ + minor_collection (); \ + Restore_after_gc; \ + young_ptr -= Bhsize_wosize (wosize); \ + } \ + Hd_hp (young_ptr) = Make_header ((wosize), (tag), Caml_black); \ + (result) = Val_hp (young_ptr); \ + DEBUG_clear ((result), (wosize)); \ +}while(0) + +/* You must use [Modify] to change a field of an existing shared block, + unless you are sure the value being overwritten is not a shared block and + the value being written is not a young block. */ +/* [Modify] never calls the GC. */ +/* [Modify] can also be used to do assignment on data structures that are + not in the (major) heap. In this case, it is a bit slower than + simple assignment. + In particular, you can use [Modify] when you don't know whether the + block being changed is in the minor heap or the major heap. +*/ + +#define Modify(fp, val) do{ \ + value _old_ = *(fp); \ + *(fp) = (val); \ + if (Is_in_heap (fp)){ \ + if (gc_phase == Phase_mark) darken (_old_, NULL); \ + if (Is_block (val) && Is_young (val) \ + && ! (Is_block (_old_) && Is_young (_old_))){ \ + *ref_table_ptr++ = (fp); \ + if (ref_table_ptr >= ref_table_limit){ \ + CAMLassert (ref_table_ptr == ref_table_limit); \ + realloc_ref_table (); \ + } \ + } \ + } \ +}while(0) + +/* */ + +struct caml__roots_block { + struct caml__roots_block *next; + long ntables; + long nitems; + value *tables [5]; +}; + +CAMLextern struct caml__roots_block *local_roots; /* defined in roots.c */ + +/* The following macros are used to declare C local variables and + function parameters of type [value]. + + The function body must start with one of the [CAMLparam] macros. + If the function has no parameter of type [value], use [CAMLparam0]. + If the function has 1 to 5 [value] parameters, use the corresponding + [CAMLparam] with the parameters as arguments. + If the function has more than 5 [value] parameters, use [CAMLparam5] + for the first 5 parameters, and one or more calls to the [CAMLxparam] + macros for the others. + If the function takes an array of [value]s as argument, use + [CAMLparamN] to declare it (or [CAMLxparamN] if you already have a + call to [CAMLparam] for some other arguments). + + If you need local variables of type [value], declare them with one + or more calls to the [CAMLlocal] macros. + Use [CAMLlocalN] to declare an array of [value]s. + + Your function may raise and exception or return a [value] with the + [CAMLreturn] macro. Its argument is simply the [value] returned by + your function. Do NOT directly return a [value] with the [return] + keyword. If your function returns void, use [CAMLreturn0]. + + All the identifiers beginning with "caml__" are reserved by Caml. + Do not use them for anything (local or global variables, struct or + union tags, macros, etc.) +*/ + +#define CAMLparam0() \ + struct caml__roots_block *caml__frame = local_roots + +#define CAMLparam1(x) \ + CAMLparam0 (); \ + CAMLxparam1 (x) + +#define CAMLparam2(x, y) \ + CAMLparam0 (); \ + CAMLxparam2 (x, y) + +#define CAMLparam3(x, y, z) \ + CAMLparam0 (); \ + CAMLxparam3 (x, y, z) + +#define CAMLparam4(x, y, z, t) \ + CAMLparam0 (); \ + CAMLxparam4 (x, y, z, t) + +#define CAMLparam5(x, y, z, t, u) \ + CAMLparam0 (); \ + CAMLxparam5 (x, y, z, t, u) + +#define CAMLparamN(x, size) \ + CAMLparam0 (); \ + CAMLxparamN (x, (size)) + + +#define CAMLxparam1(x) \ + struct caml__roots_block caml__roots_##x; \ + int caml__dummy_##x = ( \ + (caml__roots_##x.next = local_roots), \ + (local_roots = &caml__roots_##x), \ + (caml__roots_##x.nitems = 1), \ + (caml__roots_##x.ntables = 1), \ + (caml__roots_##x.tables [0] = &x), \ + 0) + +#define CAMLxparam2(x, y) \ + struct caml__roots_block caml__roots_##x; \ + int caml__dummy_##x = ( \ + (caml__roots_##x.next = local_roots), \ + (local_roots = &caml__roots_##x), \ + (caml__roots_##x.nitems = 1), \ + (caml__roots_##x.ntables = 2), \ + (caml__roots_##x.tables [0] = &x), \ + (caml__roots_##x.tables [1] = &y), \ + 0) + +#define CAMLxparam3(x, y, z) \ + struct caml__roots_block caml__roots_##x; \ + int caml__dummy_##x = ( \ + (caml__roots_##x.next = local_roots), \ + (local_roots = &caml__roots_##x), \ + (caml__roots_##x.nitems = 1), \ + (caml__roots_##x.ntables = 3), \ + (caml__roots_##x.tables [0] = &x), \ + (caml__roots_##x.tables [1] = &y), \ + (caml__roots_##x.tables [2] = &z), \ + 0) + +#define CAMLxparam4(x, y, z, t) \ + struct caml__roots_block caml__roots_##x; \ + int caml__dummy_##x = ( \ + (caml__roots_##x.next = local_roots), \ + (local_roots = &caml__roots_##x), \ + (caml__roots_##x.nitems = 1), \ + (caml__roots_##x.ntables = 4), \ + (caml__roots_##x.tables [0] = &x), \ + (caml__roots_##x.tables [1] = &y), \ + (caml__roots_##x.tables [2] = &z), \ + (caml__roots_##x.tables [3] = &t), \ + 0) + +#define CAMLxparam5(x, y, z, t, u) \ + struct caml__roots_block caml__roots_##x; \ + int caml__dummy_##x = ( \ + (caml__roots_##x.next = local_roots), \ + (local_roots = &caml__roots_##x), \ + (caml__roots_##x.nitems = 1), \ + (caml__roots_##x.ntables = 5), \ + (caml__roots_##x.tables [0] = &x), \ + (caml__roots_##x.tables [1] = &y), \ + (caml__roots_##x.tables [2] = &z), \ + (caml__roots_##x.tables [3] = &t), \ + (caml__roots_##x.tables [4] = &u), \ + 0) + +#define CAMLxparamN(x, size) \ + struct caml__roots_block caml__roots_##x; \ + int caml__dummy_##x = ( \ + (caml__roots_##x.next = local_roots), \ + (local_roots = &caml__roots_##x), \ + (caml__roots_##x.nitems = (size)), \ + (caml__roots_##x.ntables = 1), \ + (caml__roots_##x.tables[0] = &(x[0])), \ + 0) + +#define CAMLlocal1(x) \ + value x = 0; \ + CAMLxparam1 (x) + +#define CAMLlocal2(x, y) \ + value x = 0, y = 0; \ + CAMLxparam2 (x, y) + +#define CAMLlocal3(x, y, z) \ + value x = 0, y = 0, z = 0; \ + CAMLxparam3 (x, y, z) + +#define CAMLlocal4(x, y, z, t) \ + value x = 0, y = 0, z = 0, t = 0; \ + CAMLxparam4 (x, y, z, t) + +#define CAMLlocal5(x, y, z, t, u) \ + value x = 0, y = 0, z = 0, t = 0, u = 0; \ + CAMLxparam5 (x, y, z, t, u) + +#define CAMLlocalN(x, size) \ + value x [(size)] = { 0, /* 0, 0, ... */ }; \ + CAMLxparamN (x, (size)) + + +#define CAMLreturn0 do{ \ + local_roots = caml__frame; \ + return; \ +}while (0) + +#define CAMLreturn(result) do{ \ + local_roots = caml__frame; \ + return (result); \ +}while(0) + +/* convenience macro */ +#define Store_field(block, offset, val) do{ \ + mlsize_t caml__temp_offset = (offset); \ + value caml__temp_val = (val); \ + modify (&Field ((block), caml__temp_offset), caml__temp_val); \ +}while(0) + +/* + NOTE: [Begin_roots] and [End_roots] are superseded by [CAMLparam]*, + [CAMLxparam]*, [CAMLlocal]*, [CAMLreturn]. + + [Begin_roots] and [End_roots] are used for C variables that are GC roots. + It must contain all values in C local variables and function parameters + at the time the minor GC is called. + Usage: + After initialising your local variables to legal Caml values, but before + calling allocation functions, insert [Begin_roots_n(v1, ... vn)], where + v1 ... vn are your variables of type [value] that you want to be updated + across allocations. + At the end, insert [End_roots()]. + + Note that [Begin_roots] opens a new block, and [End_roots] closes it. + Thus they must occur in matching pairs at the same brace nesting level. + + You can use [Val_unit] as a dummy initial value for your variables. +*/ + +#define Begin_root Begin_roots1 + +#define Begin_roots1(r0) { \ + struct caml__roots_block caml__roots_block; \ + caml__roots_block.next = local_roots; \ + local_roots = &caml__roots_block; \ + caml__roots_block.nitems = 1; \ + caml__roots_block.ntables = 1; \ + caml__roots_block.tables[0] = &(r0); + +#define Begin_roots2(r0, r1) { \ + struct caml__roots_block caml__roots_block; \ + caml__roots_block.next = local_roots; \ + local_roots = &caml__roots_block; \ + caml__roots_block.nitems = 1; \ + caml__roots_block.ntables = 2; \ + caml__roots_block.tables[0] = &(r0); \ + caml__roots_block.tables[1] = &(r1); + +#define Begin_roots3(r0, r1, r2) { \ + struct caml__roots_block caml__roots_block; \ + caml__roots_block.next = local_roots; \ + local_roots = &caml__roots_block; \ + caml__roots_block.nitems = 1; \ + caml__roots_block.ntables = 3; \ + caml__roots_block.tables[0] = &(r0); \ + caml__roots_block.tables[1] = &(r1); \ + caml__roots_block.tables[2] = &(r2); + +#define Begin_roots4(r0, r1, r2, r3) { \ + struct caml__roots_block caml__roots_block; \ + caml__roots_block.next = local_roots; \ + local_roots = &caml__roots_block; \ + caml__roots_block.nitems = 1; \ + caml__roots_block.ntables = 4; \ + caml__roots_block.tables[0] = &(r0); \ + caml__roots_block.tables[1] = &(r1); \ + caml__roots_block.tables[2] = &(r2); \ + caml__roots_block.tables[3] = &(r3); + +#define Begin_roots5(r0, r1, r2, r3, r4) { \ + struct caml__roots_block caml__roots_block; \ + caml__roots_block.next = local_roots; \ + local_roots = &caml__roots_block; \ + caml__roots_block.nitems = 1; \ + caml__roots_block.ntables = 5; \ + caml__roots_block.tables[0] = &(r0); \ + caml__roots_block.tables[1] = &(r1); \ + caml__roots_block.tables[2] = &(r2); \ + caml__roots_block.tables[3] = &(r3); \ + caml__roots_block.tables[4] = &(r4); + +#define Begin_roots_block(table, size) { \ + struct caml__roots_block caml__roots_block; \ + caml__roots_block.next = local_roots; \ + local_roots = &caml__roots_block; \ + caml__roots_block.nitems = (size); \ + caml__roots_block.ntables = 1; \ + caml__roots_block.tables[0] = (table); + +#define End_roots() local_roots = caml__roots_block.next; } + + +/* [register_global_root] registers a global C variable as a memory root + for the duration of the program, or until [remove_global_root] is + called. */ + +CAMLextern void register_global_root (value *); + +/* [remove_global_root] removes a memory root registered on a global C + variable with [register_global_root]. */ + +CAMLextern void remove_global_root (value *); + + +#endif /* _memory_ */ + diff --git a/byterun/meta.c b/byterun/meta.c new file mode 100644 index 00000000..edbc278f --- /dev/null +++ b/byterun/meta.c @@ -0,0 +1,160 @@ +/***********************************************************************/ +/* */ +/* 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: meta.c,v 1.24 2002/05/07 13:17:12 xleroy Exp $ */ + +/* Primitives for the toplevel */ + +#include "alloc.h" +#include "config.h" +#include "fail.h" +#include "fix_code.h" +#include "interp.h" +#include "major_gc.h" +#include "memory.h" +#include "minor_gc.h" +#include "misc.h" +#include "mlvalues.h" +#include "prims.h" +#include "stacks.h" + +#ifndef NATIVE_CODE + +CAMLprim value get_global_data(value unit) +{ + return global_data; +} + +CAMLprim value reify_bytecode(value prog, value len) +{ + value clos; +#ifdef ARCH_BIG_ENDIAN + fixup_endianness((code_t) prog, (asize_t) Long_val(len)); +#endif +#ifdef THREADED_CODE + thread_code((code_t) prog, (asize_t) Long_val(len)); +#endif + clos = alloc_small (1, Closure_tag); + Code_val(clos) = (code_t) prog; + return clos; +} + +CAMLprim value realloc_global(value size) +{ + mlsize_t requested_size, actual_size, i; + value new_global_data; + + requested_size = Long_val(size); + actual_size = Wosize_val(global_data); + if (requested_size >= actual_size) { + requested_size = (requested_size + 0x100) & 0xFFFFFF00; + gc_message (0x08, "Growing global data to %lu entries\n", requested_size); + new_global_data = alloc_shr(requested_size, 0); + for (i = 0; i < actual_size; i++) + initialize(&Field(new_global_data, i), Field(global_data, i)); + for (i = actual_size; i < requested_size; i++){ + Field (new_global_data, i) = Val_long (0); + } + global_data = new_global_data; + } + return Val_unit; +} + +CAMLprim value get_current_environment(value unit) +{ + return *extern_sp; +} + +CAMLprim value invoke_traced_function(value codeptr, value env, value arg) +{ + /* Stack layout on entry: + return frame into instrument_closure function + arg3 to call_original_code (arg) + arg2 to call_original_code (env) + arg1 to call_original_code (codeptr) + arg3 to call_original_code (arg) + arg2 to call_original_code (env) + saved env */ + + /* Stack layout on exit: + return frame into instrument_closure function + actual arg to code (arg) + pseudo return frame into codeptr: + extra_args = 0 + environment = env + PC = codeptr + arg3 to call_original_code (arg) same 6 bottom words as + arg2 to call_original_code (env) on entrance, but + arg1 to call_original_code (codeptr) shifted down 4 words + arg3 to call_original_code (arg) + arg2 to call_original_code (env) + saved env */ + + value * osp, * nsp; + int i; + + osp = extern_sp; + extern_sp -= 4; + nsp = extern_sp; + for (i = 0; i < 6; i++) nsp[i] = osp[i]; + nsp[6] = codeptr; + nsp[7] = env; + nsp[8] = Val_int(0); + nsp[9] = arg; + return Val_unit; +} + +#else + +/* Dummy definitions to support compilation of ocamlc.opt */ + +value get_global_data(value unit) +{ + invalid_argument("Meta.get_global_data"); + return Val_unit; /* not reached */ +} + +value realloc_global(value size) +{ + invalid_argument("Meta.realloc_global"); + return Val_unit; /* not reached */ +} + +value available_primitives(value unit) +{ + invalid_argument("Meta.available_primitives"); + return Val_unit; /* not reached */ +} + +value invoke_traced_function(value codeptr, value env, value arg) +{ + invalid_argument("Meta.invoke_traced_function"); + return Val_unit; /* not reached */ +} + +value * stack_low; +value * stack_high; +value * stack_threshold; +value * extern_sp; +value * trapsp; +int backtrace_active; +int backtrace_pos; +code_t * backtrace_buffer; +value backtrace_last_exn; +int callback_depth; +int volatile something_to_do; +void (* volatile async_action_hook)(void); +void print_exception_backtrace(void) { } +struct longjmp_buffer * external_raise; + +#endif diff --git a/byterun/minor_gc.c b/byterun/minor_gc.c new file mode 100644 index 00000000..ecb09efe --- /dev/null +++ b/byterun/minor_gc.c @@ -0,0 +1,266 @@ +/***********************************************************************/ +/* */ +/* Objective Caml */ +/* */ +/* Damien Doligez, projet Para, 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: minor_gc.c,v 1.36 2002/09/18 13:59:27 doligez Exp $ */ + +#include +#include "config.h" +#include "fail.h" +#include "finalise.h" +#include "gc.h" +#include "gc_ctrl.h" +#include "major_gc.h" +#include "memory.h" +#include "minor_gc.h" +#include "misc.h" +#include "mlvalues.h" +#include "roots.h" +#include "signals.h" + +asize_t minor_heap_size; +char *young_start = NULL, *young_end = NULL; +char *young_ptr = NULL, *young_limit = NULL; +static value **ref_table = NULL, **ref_table_end, **ref_table_threshold; +value **ref_table_ptr = NULL, **ref_table_limit; +static asize_t ref_table_size, ref_table_reserve; +int in_minor_collection = 0; + +void set_minor_heap_size (asize_t size) +{ + char *new_heap; + value **new_table; + + Assert (size >= Minor_heap_min); + Assert (size <= Minor_heap_max); + Assert (size % sizeof (value) == 0); + if (young_ptr != young_end) minor_collection (); + Assert (young_ptr == young_end); + new_heap = (char *) stat_alloc (size); + if (young_start != NULL){ + stat_free (young_start); + } + young_start = new_heap; + young_end = new_heap + size; + young_limit = young_start; + young_ptr = young_end; + minor_heap_size = size; + + ref_table_size = minor_heap_size / sizeof (value) / 8; + ref_table_reserve = 256; + new_table = (value **) stat_alloc ((ref_table_size + ref_table_reserve) + * sizeof (value *)); + if (ref_table != NULL) stat_free (ref_table); + ref_table = new_table; + ref_table_ptr = ref_table; + ref_table_threshold = ref_table + ref_table_size; + ref_table_limit = ref_table_threshold; + ref_table_end = ref_table + ref_table_size + ref_table_reserve; +} + +static value oldify_todo_list = 0; + +/* Note that the tests on the tag depend on the fact that Infix_tag, + Forward_tag, and No_scan_tag are contiguous. */ + +void oldify_one (value v, value *p) +{ + value result; + header_t hd; + mlsize_t sz, i; + tag_t tag; + + tail_call: + if (Is_block (v) && Is_young (v)){ + Assert (Hp_val (v) >= young_ptr); + hd = Hd_val (v); + if (hd == 0){ /* If already forwarded */ + *p = Field (v, 0); /* then forward pointer is first field. */ + }else{ + tag = Tag_hd (hd); + if (tag < Infix_tag){ + value field0; + + sz = Wosize_hd (hd); + result = alloc_shr (sz, tag); + *p = result; + field0 = Field (v, 0); + Hd_val (v) = 0; /* Set forward flag */ + Field (v, 0) = result; /* and forward pointer. */ + if (sz > 1){ + Field (result, 0) = field0; + Field (result, 1) = oldify_todo_list; /* Add this block */ + oldify_todo_list = v; /* to the "to do" list. */ + }else{ + Assert (sz == 1); + p = &Field (result, 0); + v = field0; + goto tail_call; + } + }else if (tag >= No_scan_tag){ + sz = Wosize_hd (hd); + result = alloc_shr (sz, tag); + for (i = 0; i < sz; i++) Field (result, i) = Field (v, i); + Hd_val (v) = 0; /* Set forward flag */ + Field (v, 0) = result; /* and forward pointer. */ + *p = result; + }else if (tag == Infix_tag){ + mlsize_t offset = Infix_offset_hd (hd); + oldify_one (v - offset, p); /* This cannot recurse deeper than 1. */ + *p += offset; + }else{ + value f = Forward_val (v); + tag_t ft = 0; + + Assert (tag == Forward_tag); + if (Is_block (f) && (Is_young (f) || Is_in_heap (f))){ + ft = Tag_val (Hd_val (f) == 0 ? Field (f, 0) : f); + } + if (ft == Forward_tag || ft == Lazy_tag){ + /* Keep the forward block; copy it as a normal block + (no short-circuit). */ + Assert (Wosize_hd (hd) == 1); + result = alloc_shr (1, Forward_tag); + *p = result; + Hd_val (v) = 0; /* Set (GC) forward flag */ + Field (v, 0) = result; /* and forward pointer. */ + p = &Field (result, 0); + v = f; + goto tail_call; + }else{ + v = f; /* Follow the forwarding */ + goto tail_call; /* then oldify. */ + } + } + } + }else{ + *p = v; + } +} + +/* Finish the work that was put off by oldify_one. + Note that oldify_one itself is called by oldify_mopup, so we + have to be careful to remove the first entry from the list before + oldifying its fields. */ +void oldify_mopup (void) +{ + value v, new_v, f; + mlsize_t i; + + while (oldify_todo_list != 0){ + v = oldify_todo_list; /* Get the head. */ + Assert (Hd_val (v) == 0); /* It must be forwarded. */ + new_v = Field (v, 0); /* Follow forward pointer. */ + oldify_todo_list = Field (new_v, 1); /* Remove from list. */ + + f = Field (new_v, 0); + if (Is_block (f) && Is_young (f)){ + oldify_one (f, &Field (new_v, 0)); + } + for (i = 1; i < Wosize_val (new_v); i++){ + f = Field (v, i); + if (Is_block (f) && Is_young (f)){ + oldify_one (f, &Field (new_v, i)); + }else{ + Field (new_v, i) = f; + } + } + } +} + +/* Make sure the minor heap is empty by performing a minor collection + if needed. +*/ +void empty_minor_heap (void) +{ + value **r; + + if (young_ptr != young_end){ + in_minor_collection = 1; + gc_message (0x02, "<", 0); + oldify_local_roots(); + for (r = ref_table; r < ref_table_ptr; r++){ + oldify_one (**r, *r); + } + oldify_mopup (); + if (young_ptr < young_start) young_ptr = young_start; + stat_minor_words += Wsize_bsize (young_end - young_ptr); + young_ptr = young_end; + young_limit = young_start; + ref_table_ptr = ref_table; + ref_table_limit = ref_table_threshold; + gc_message (0x02, ">", 0); + in_minor_collection = 0; + } + final_empty_young (); +#ifdef DEBUG + { + value *p; + for (p = (value *) young_start; p < (value *) young_end; ++p){ + *p = Debug_free_minor; + } + } +#endif +} + +/* Do a minor collection and a slice of major collection, call finalisation + functions, etc. + Leave the minor heap empty. +*/ +void minor_collection (void) +{ + long prev_alloc_words = allocated_words; + + empty_minor_heap (); + + stat_promoted_words += allocated_words - prev_alloc_words; + ++ stat_minor_collections; + major_collection_slice (0); + force_major_slice = 0; + + final_do_calls (); + + empty_minor_heap (); +} + +value check_urgent_gc (value extra_root) +{ + CAMLparam1 (extra_root); + if (force_major_slice) minor_collection(); + CAMLreturn (extra_root); +} + +void realloc_ref_table (void) +{ Assert (ref_table_ptr == ref_table_limit); + Assert (ref_table_limit <= ref_table_end); + Assert (ref_table_limit >= ref_table_threshold); + + if (ref_table_limit == ref_table_threshold){ + gc_message (0x08, "ref_table threshold crossed\n", 0); + ref_table_limit = ref_table_end; + urge_major_slice (); + }else{ /* This will almost never happen with the bytecode interpreter. */ + asize_t sz; + asize_t cur_ptr = ref_table_ptr - ref_table; + Assert (force_major_slice); + + ref_table_size *= 2; + sz = (ref_table_size + ref_table_reserve) * sizeof (value *); + gc_message (0x08, "Growing ref_table to %ldk bytes\n", (long) sz / 1024); + ref_table = (value **) realloc ((char *) ref_table, sz); + if (ref_table == NULL) fatal_error ("Fatal error: ref_table overflow\n"); + ref_table_end = ref_table + ref_table_size + ref_table_reserve; + ref_table_threshold = ref_table + ref_table_size; + ref_table_ptr = ref_table + cur_ptr; + ref_table_limit = ref_table_end; + } +} diff --git a/byterun/minor_gc.h b/byterun/minor_gc.h new file mode 100644 index 00000000..414bb1f3 --- /dev/null +++ b/byterun/minor_gc.h @@ -0,0 +1,46 @@ +/***********************************************************************/ +/* */ +/* Objective Caml */ +/* */ +/* Damien Doligez, projet Para, 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: minor_gc.h,v 1.15 2002/01/20 17:39:06 doligez Exp $ */ + +#ifndef _minor_gc_ +#define _minor_gc_ + + +#include "misc.h" + +CAMLextern char *young_start, *young_ptr, *young_end, *young_limit; +CAMLextern value **ref_table_ptr, **ref_table_limit; +extern asize_t minor_heap_size; +extern int in_minor_collection; + +#define Is_young(val) \ + (Assert (Is_block (val)), \ + (addr)(val) < (addr)young_end && (addr)(val) > (addr)young_start) + +extern void set_minor_heap_size (asize_t); +extern void empty_minor_heap (void); +CAMLextern void minor_collection (void); +CAMLextern void garbage_collection (void); /* for the native-code system */ +extern void realloc_ref_table (void); +extern void oldify_one (value, value *); +extern void oldify_mopup (void); + +#define Oldify(p) do{ \ + value __oldify__v__ = *p; \ + if (Is_block (__oldify__v__) && Is_young (__oldify__v__)){ \ + oldify_one (__oldify__v__, (p)); \ + } \ + }while(0) + +#endif /* _minor_gc_ */ diff --git a/byterun/misc.c b/byterun/misc.c new file mode 100644 index 00000000..e3f1990f --- /dev/null +++ b/byterun/misc.c @@ -0,0 +1,139 @@ +/***********************************************************************/ +/* */ +/* 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: misc.c,v 1.22 2002/01/20 17:39:06 doligez Exp $ */ + +#include +#include "config.h" +#include "misc.h" +#include "memory.h" +#ifdef HAS_UI +#include "ui.h" +#endif + +#ifdef DEBUG + +int caml_failed_assert (char * expr, char * file, int line) +{ + fprintf (stderr, "file %s; line %d ### Assertion failed: %s\n", + file, line, expr); + fflush (stderr); + exit (100); + return 1; /* not reached */ +} + +#endif + +unsigned long verb_gc = 0; + +void gc_message (int level, char *msg, unsigned long arg) +{ + if (level < 0 || (verb_gc & level) != 0){ +#ifdef HAS_UI + ui_print_stderr(msg, (void *) arg); +#else + fprintf (stderr, msg, arg); + fflush (stderr); +#endif + } +} + +void fatal_error (char *msg) +{ +#ifdef HAS_UI + ui_print_stderr("%s", msg); + ui_exit (2); +#else + fprintf (stderr, "%s", msg); + exit(2); +#endif +} + +void fatal_error_arg (char *fmt, char *arg) +{ +#ifdef HAS_UI + ui_print_stderr(fmt, arg); + ui_exit (2); +#else + fprintf (stderr, fmt, arg); + exit(2); +#endif +} + +void fatal_error_arg2 (char *fmt1, char *arg1, char *fmt2, char *arg2) +{ +#ifdef HAS_UI + ui_print_stderr(fmt1, arg1); + ui_print_stderr(fmt2, arg2); + ui_exit (2); +#else + fprintf (stderr, fmt1, arg1); + fprintf (stderr, fmt2, arg2); + exit(2); +#endif +} + +char *aligned_malloc (asize_t size, int modulo, void **block) +{ + char *raw_mem; + unsigned long aligned_mem; + Assert (modulo < Page_size); + raw_mem = (char *) malloc (size + Page_size); + if (raw_mem == NULL) return NULL; + *block = raw_mem; + raw_mem += modulo; /* Address to be aligned */ + aligned_mem = (((unsigned long) raw_mem / Page_size + 1) * Page_size); +#ifdef DEBUG + { + unsigned long *p; + unsigned long *p0 = (void *) *block, + *p1 = (void *) (aligned_mem - modulo), + *p2 = (void *) (aligned_mem - modulo + size), + *p3 = (void *) ((char *) *block + size + Page_size); + + for (p = p0; p < p1; p++) *p = Debug_filler_align; + for (p = p1; p < p2; p++) *p = Debug_uninit_align; + for (p = p2; p < p3; p++) *p = Debug_filler_align; + } +#endif + return (char *) (aligned_mem - modulo); +} + +void ext_table_init(struct ext_table * tbl, int init_capa) +{ + tbl->size = 0; + tbl->capacity = init_capa; + tbl->contents = stat_alloc(sizeof(void *) * init_capa); +} + +int ext_table_add(struct ext_table * tbl, void * data) +{ + int res; + if (tbl->size >= tbl->capacity) { + tbl->capacity *= 2; + tbl->contents = + stat_resize(tbl->contents, sizeof(void *) * tbl->capacity); + } + res = tbl->size; + tbl->contents[res] = data; + tbl->size++; + return res; +} + +void ext_table_free(struct ext_table * tbl, int free_entries) +{ + int i; + if (free_entries) + for (i = 0; i < tbl->size; i++) stat_free(tbl->contents[i]); + stat_free(tbl->contents); +} diff --git a/byterun/misc.h b/byterun/misc.h new file mode 100644 index 00000000..6323367c --- /dev/null +++ b/byterun/misc.h @@ -0,0 +1,142 @@ +/***********************************************************************/ +/* */ +/* 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: misc.h,v 1.24 2003/05/12 14:21:52 xleroy Exp $ */ + +/* Miscellaneous macros and variables. */ + +#ifndef _misc_ +#define _misc_ + + +#include "config.h" + +/* Standard definitions */ + +#include +#include + +/* Basic types and constants */ + +typedef size_t asize_t; + +#ifndef NULL +#define NULL 0 +#endif + +/* */ +typedef char * addr; +/* */ + +#ifdef __GNUC__ +/* Works only in GCC 2.5 and later */ +#define Noreturn __attribute ((noreturn)) +#else +#define Noreturn +#endif + +/* Export control (to mark primitives and to handle Windows DLL) */ + +#if defined(_WIN32) && defined(CAML_DLL) +# define CAMLexport __declspec(dllexport) +# define CAMLprim __declspec(dllexport) +# if defined(IN_OCAMLRUN) +# define CAMLextern __declspec(dllexport) extern +# else +# define CAMLextern __declspec(dllimport) extern +# endif +#else +# define CAMLexport +# define CAMLprim +# define CAMLextern extern +#endif + +/* Assertions */ + +/* */ + +#ifdef DEBUG +#define CAMLassert(x) ((x) ? 0 : caml_failed_assert ( #x , __FILE__, __LINE__)) +int caml_failed_assert (char *, char *, int); +#else +#define CAMLassert(x) 0 +#endif + +void fatal_error (char *msg) Noreturn; +void fatal_error_arg (char *fmt, char *arg) Noreturn; +void fatal_error_arg2 (char *fmt1, char *arg1, + char *fmt2, char *arg2) Noreturn; + +/* Data structures */ + +struct ext_table { + int size; + int capacity; + void ** contents; +}; + +extern void ext_table_init(struct ext_table * tbl, int init_capa); +extern int ext_table_add(struct ext_table * tbl, void * data); +extern void ext_table_free(struct ext_table * tbl, int free_entries); + +/* GC flags and messages */ + +extern unsigned long verb_gc; +void gc_message (int, char *, unsigned long); + +/* Memory routines */ + +char *aligned_malloc (asize_t, int, void **); + +#ifdef DEBUG +#ifdef ARCH_SIXTYFOUR +#define Debug_tag(x) (0xD700D7D7D700D6D7ul \ + | ((unsigned long) (x) << 16) \ + | ((unsigned long) (x) << 48)) +#else +#define Debug_tag(x) (0xD700D6D7ul | ((unsigned long) (x) << 16)) +#endif /* ARCH_SIXTYFOUR */ + +/* + 00 -> free words in minor heap + 01 -> fields of free list blocks in major heap + 03 -> heap chunks deallocated by heap shrinking + 04 -> fields deallocated by obj_truncate + 10 -> uninitialised fields of minor objects + 11 -> uninitialised fields of major objects + 15 -> uninitialised words of aligned_malloc blocks + 85 -> filler bytes of aligned_malloc + + special case (byte by byte): + D7 -> uninitialised words of stat_alloc blocks +*/ +#define Debug_free_minor Debug_tag (0x00) +#define Debug_free_major Debug_tag (0x01) +#define Debug_free_shrink Debug_tag (0x03) +#define Debug_free_truncate Debug_tag (0x04) +#define Debug_uninit_minor Debug_tag (0x10) +#define Debug_uninit_major Debug_tag (0x11) +#define Debug_uninit_align Debug_tag (0x15) +#define Debug_filler_align Debug_tag (0x85) + +#define Debug_uninit_stat 0xD7 +#endif /* DEBUG */ + + +#ifndef CAML_AVOID_CONFLICTS +#define Assert CAMLassert +#endif + +/* */ + +#endif /* _misc_ */ diff --git a/byterun/mlvalues.h b/byterun/mlvalues.h new file mode 100644 index 00000000..f589b0b8 --- /dev/null +++ b/byterun/mlvalues.h @@ -0,0 +1,299 @@ +/***********************************************************************/ +/* */ +/* 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: mlvalues.h,v 1.40 2003/03/31 08:41:12 xleroy Exp $ */ + +#ifndef _mlvalues_ +#define _mlvalues_ + + +#include "config.h" +#include "misc.h" + +/* Definitions + + word: Four bytes on 32 and 16 bit architectures, + eight bytes on 64 bit architectures. + long: A C long integer. + val: The ML representation of something. A long or a block or a pointer + outside the heap. If it is a block, it is the (encoded) address + of an object. If it is a long, it is encoded as well. + block: Something allocated. It always has a header and some + fields or some number of bytes (a multiple of the word size). + field: A word-sized val which is part of a block. + bp: Pointer to the first byte of a block. (a char *) + op: Pointer to the first field of a block. (a value *) + hp: Pointer to the header of a block. (a char *) + int32: Four bytes on all architectures. + int64: Eight bytes on all architectures. + + Remark: A block size is always a multiple of the word size, and at least + one word plus the header. + + bosize: Size (in bytes) of the "bytes" part. + wosize: Size (in words) of the "fields" part. + bhsize: Size (in bytes) of the block with its header. + whsize: Size (in words) of the block with its header. + + hd: A header. + tag: The value of the tag field of the header. + color: The value of the color field of the header. + This is for use only by the GC. +*/ + +typedef long value; +typedef unsigned long header_t; +typedef unsigned long mlsize_t; +typedef unsigned int tag_t; /* Actually, an unsigned char */ +typedef unsigned long color_t; +typedef unsigned long mark_t; + +/* Longs vs blocks. */ +#define Is_long(x) (((x) & 1) != 0) +#define Is_block(x) (((x) & 1) == 0) + +/* Conversion macro names are always of the form "to_from". */ +/* Example: Val_long as in "Val from long" or "Val of long". */ +#define Val_long(x) (((long)(x) << 1) + 1) +#define Long_val(x) ((x) >> 1) +#define Max_long ((1L << (8 * sizeof(value) - 2)) - 1) +#define Min_long (-(1L << (8 * sizeof(value) - 2))) +#define Val_int(x) Val_long(x) +#define Int_val(x) ((int) Long_val(x)) +#define Unsigned_long_val(x) ((unsigned long)(x) >> 1) +#define Unsigned_int_val(x) ((int) Unsigned_long_val(x)) + +/* Structure of the header: + +For 16-bit and 32-bit architectures: + +--------+-------+-----+ + | wosize | color | tag | + +--------+-------+-----+ +bits 31 10 9 8 7 0 + +For 64-bit architectures: + + +--------+-------+-----+ + | wosize | color | tag | + +--------+-------+-----+ +bits 63 10 9 8 7 0 + +*/ + +#define Tag_hd(hd) ((tag_t) ((hd) & 0xFF)) +#define Wosize_hd(hd) ((mlsize_t) ((hd) >> 10)) + +#define Hd_val(val) (((header_t *) (val)) [-1]) /* Also an l-value. */ +#define Hd_op(op) (Hd_val (op)) /* Also an l-value. */ +#define Hd_bp(bp) (Hd_val (bp)) /* Also an l-value. */ +#define Hd_hp(hp) (* ((header_t *) (hp))) /* Also an l-value. */ +#define Hp_val(val) ((char *) (((header_t *) (val)) - 1)) +#define Hp_op(op) (Hp_val (op)) +#define Hp_bp(bp) (Hp_val (bp)) +#define Val_op(op) ((value) (op)) +#define Val_hp(hp) ((value) (((header_t *) (hp)) + 1)) +#define Op_hp(hp) ((value *) Val_hp (hp)) +#define Bp_hp(hp) ((char *) Val_hp (hp)) + +#define Num_tags (1 << 8) +#ifdef ARCH_SIXTYFOUR +#define Max_wosize ((1L << 54) - 1) +#else +#define Max_wosize ((1 << 22) - 1) +#endif + +#define Wosize_val(val) (Wosize_hd (Hd_val (val))) +#define Wosize_op(op) (Wosize_val (op)) +#define Wosize_bp(bp) (Wosize_val (bp)) +#define Wosize_hp(hp) (Wosize_hd (Hd_hp (hp))) +#define Whsize_wosize(sz) ((sz) + 1) +#define Wosize_whsize(sz) ((sz) - 1) +#define Wosize_bhsize(sz) ((sz) / sizeof (value) - 1) +#define Bsize_wsize(sz) ((sz) * sizeof (value)) +#define Wsize_bsize(sz) ((sz) / sizeof (value)) +#define Bhsize_wosize(sz) (Bsize_wsize (Whsize_wosize (sz))) +#define Bhsize_bosize(sz) ((sz) + sizeof (header_t)) +#define Bosize_val(val) (Bsize_wsize (Wosize_val (val))) +#define Bosize_op(op) (Bosize_val (Val_op (op))) +#define Bosize_bp(bp) (Bosize_val (Val_bp (bp))) +#define Bosize_hd(hd) (Bsize_wsize (Wosize_hd (hd))) +#define Whsize_hp(hp) (Whsize_wosize (Wosize_hp (hp))) +#define Whsize_val(val) (Whsize_hp (Hp_val (val))) +#define Whsize_bp(bp) (Whsize_val (Val_bp (bp))) +#define Whsize_hd(hd) (Whsize_wosize (Wosize_hd (hd))) +#define Bhsize_hp(hp) (Bsize_wsize (Whsize_hp (hp))) +#define Bhsize_hd(hd) (Bsize_wsize (Whsize_hd (hd))) + +#ifdef ARCH_BIG_ENDIAN +#define Tag_val(val) (((unsigned char *) (val)) [-1]) + /* Also an l-value. */ +#define Tag_hp(hp) (((unsigned char *) (hp)) [sizeof(value)-1]) + /* Also an l-value. */ +#else +#define Tag_val(val) (((unsigned char *) (val)) [-sizeof(value)]) + /* Also an l-value. */ +#define Tag_hp(hp) (((unsigned char *) (hp)) [0]) + /* Also an l-value. */ +#endif + +/* The lowest tag for blocks containing no value. */ +#define No_scan_tag 251 + + +/* 1- If tag < No_scan_tag : a tuple of fields. */ + +/* Pointer to the first field. */ +#define Op_val(x) ((value *) (x)) +/* Fields are numbered from 0. */ +#define Field(x, i) (((value *)(x)) [i]) /* Also an l-value. */ + +typedef int32 opcode_t; +typedef opcode_t * code_t; + +/* NOTE: [Forward_tag] and [Infix_tag] must be just under + [No_scan_tag], with [Infix_tag] the lower one. + See [oldify_one] in minor_gc.c for more details. + + NOTE: Update stdlib/obj.ml whenever you change the tags. + */ + +/* Forward_tag: forwarding pointer that the GC may silently shortcut. + See stdlib/lazy.ml. */ +#define Forward_tag 250 +#define Forward_val(v) Field(v, 0) + +/* If tag == Infix_tag : an infix header inside a closure */ +/* Infix_tag must be odd so that the infix header is scanned as an integer */ +/* Infix_tag must be 1 modulo 4 and infix headers can only occur in blocks + with tag Closure_tag (see compact.c). */ + +#define Infix_tag 249 +#define Infix_offset_hd(hd) (Bosize_hd(hd)) +#define Infix_offset_val(v) Infix_offset_hd(Hd_val(v)) + +/* Another special case: objects */ +#define Object_tag 248 +#define Class_val(val) Field((val), 0) +#define Oid_val(val) Long_val(Field((val), 1)) + +/* Special case of tuples of fields: closures */ +#define Closure_tag 247 +#define Code_val(val) (((code_t *) (val)) [0]) /* Also an l-value. */ + +/* This tag is used (with Forward_tag) to implement lazy values. + See major_gc.c and stdlib/lazy.ml. */ +#define Lazy_tag 246 + +/* Another special case: variants */ +CAMLextern value hash_variant(char * tag); + +/* 2- If tag >= No_scan_tag : a sequence of bytes. */ + +/* Pointer to the first byte */ +#define Bp_val(v) ((char *) (v)) +#define Val_bp(p) ((value) (p)) +/* Bytes are numbered from 0. */ +#define Byte(x, i) (((char *) (x)) [i]) /* Also an l-value. */ +#define Byte_u(x, i) (((unsigned char *) (x)) [i]) /* Also an l-value. */ + +/* Abstract things. Their contents is not traced by the GC; therefore they + must not contain any [value]. +*/ +#define Abstract_tag 251 + +/* Strings. */ +#define String_tag 252 +#define String_val(x) ((char *) Bp_val(x)) +CAMLextern mlsize_t string_length (value); /* size in bytes */ + +/* Floating-point numbers. */ +#define Double_tag 253 +#define Double_wosize ((sizeof(double) / sizeof(value))) +#ifndef ARCH_ALIGN_DOUBLE +#define Double_val(v) (* (double *)(v)) +#define Store_double_val(v,d) (* (double *)(v) = (d)) +#else +CAMLextern double Double_val (value); +CAMLextern void Store_double_val (value,double); +#endif + +/* Arrays of floating-point numbers. */ +#define Double_array_tag 254 +#define Double_field(v,i) Double_val((value)((double *)(v) + (i))) +#define Store_double_field(v,i,d) do{ \ + mlsize_t caml__temp_i = (i); \ + double caml__temp_d = (d); \ + Store_double_val((value)((double *) v + caml__temp_i), caml__temp_d); \ +}while(0) + +/* Custom blocks. They contain a pointer to a "method suite" + of functions (for finalization, comparison, hashing, etc) + followed by raw data. The contents of custom blocks is not traced by + the GC; therefore, they must not contain any [value]. + See [custom.h] for operations on method suites. */ +#define Custom_tag 255 +#define Data_custom_val(v) ((void *) &Field((v), 1)) +struct custom_operations; /* defined in [custom.h] */ + +/* Int32.t, Int64.t and Nativeint.t are represented as custom blocks. */ + +#define Int32_val(v) (*((int32 *) Data_custom_val(v))) +#define Nativeint_val(v) (*((long *) Data_custom_val(v))) +#ifndef ARCH_ALIGN_INT64 +#define Int64_val(v) (*((int64 *) Data_custom_val(v))) +#else +CAMLextern int64 Int64_val(value v); +#endif + +/* 3- Atoms are 0-tuples. They are statically allocated once and for all. */ + +CAMLextern header_t atom_table[]; +#define Atom(tag) (Val_hp (&(atom_table [(tag)]))) + +/* Is_atom tests whether a well-formed block is statically allocated + outside the heap. For the bytecode system, only zero-sized block (Atoms) + fall in this class. For the native-code generator, data + emitted by the code generator (as described in the table + caml_data_segments) are also atoms. */ + +#ifndef NATIVE_CODE +#define Is_atom(v) ((v) >= Atom(0) && (v) <= Atom(255)) +#else +CAMLextern char * static_data_start, * static_data_end; +#define Is_atom(v) \ + ((((char *)(v) >= static_data_start && (char *)(v) < static_data_end) || \ + ((v) >= Atom(0) && (v) <= Atom(255)))) +#endif + +/* Booleans are integers 0 or 1 */ + +#define Val_bool(x) Val_int((x) != 0) +#define Bool_val(x) Int_val(x) +#define Val_false Val_int(0) +#define Val_true Val_int(1) +#define Val_not(x) (Val_false + Val_true - (x)) + +/* The unit value is 0 (tagged) */ + +#define Val_unit Val_int(0) + +/* List constructors */ +#define Val_emptylist Val_int(0) +#define Tag_cons 0 + +/* The table of global identifiers */ + +extern value global_data; + + +#endif /* _mlvalues_ */ diff --git a/byterun/mpwtool.c b/byterun/mpwtool.c new file mode 100644 index 00000000..f9f47dd1 --- /dev/null +++ b/byterun/mpwtool.c @@ -0,0 +1,39 @@ +/***********************************************************************/ +/* */ +/* Objective Caml */ +/* */ +/* Damien Doligez, projet Para, 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: mpwtool.c,v 1.2 2001/12/07 13:39:33 xleroy Exp $ */ + +/* glue code for MPW tools */ + +#include +#include + +int ui_read (int fd, char *p, unsigned int n) +{ + return read (fd, p, n); +} + +int ui_write (int fd, char *p, unsigned int n) +{ + return write (fd, p, n); +} + +void ui_print_stderr (char *msg, void *arg) +{ + fprintf (stderr, msg, arg); +} + +void ui_exit (int retcode) +{ + exit (retcode); +} diff --git a/byterun/obj.c b/byterun/obj.c new file mode 100644 index 00000000..ac5d29c8 --- /dev/null +++ b/byterun/obj.c @@ -0,0 +1,160 @@ +/***********************************************************************/ +/* */ +/* 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: obj.c,v 1.20 2003/06/23 12:46:13 xleroy Exp $ */ + +/* Operations on objects */ + +#include +#include "alloc.h" +#include "fail.h" +#include "gc.h" +#include "major_gc.h" +#include "memory.h" +#include "minor_gc.h" +#include "misc.h" +#include "mlvalues.h" +#include "prims.h" + +CAMLprim value static_alloc(value size) +{ + return (value) stat_alloc((asize_t) Long_val(size)); +} + +CAMLprim value static_free(value blk) +{ + stat_free((void *) blk); + return Val_unit; +} + +CAMLprim value static_resize(value blk, value new_size) +{ + return (value) stat_resize((char *) blk, (asize_t) Long_val(new_size)); +} + +CAMLprim value obj_is_block(value arg) +{ + return Val_bool(Is_block(arg)); +} + +CAMLprim value obj_tag(value arg) +{ + return Val_int(Tag_val(arg)); +} + +CAMLprim value obj_set_tag (value arg, value new_tag) +{ + Tag_val (arg) = Int_val (new_tag); + return Val_unit; +} + +CAMLprim value obj_block(value tag, value size) +{ + value res; + mlsize_t sz, i; + tag_t tg; + + sz = Long_val(size); + tg = Long_val(tag); + if (sz == 0) return Atom(tg); + res = alloc(sz, tg); + for (i = 0; i < sz; i++) + Field(res, i) = Val_long(0); + + return res; +} + +CAMLprim value obj_dup(value arg) +{ + CAMLparam1 (arg); + CAMLlocal1 (res); + mlsize_t sz, i; + tag_t tg; + + sz = Wosize_val(arg); + if (sz == 0) return arg; + tg = Tag_val(arg); + if (tg >= No_scan_tag) { + res = alloc(sz, tg); + memcpy(Bp_val(res), Bp_val(arg), sz * sizeof(value)); + } else if (sz <= Max_young_wosize) { + res = alloc_small(sz, tg); + for (i = 0; i < sz; i++) Field(res, i) = Field(arg, i); + } else { + res = alloc_shr(sz, tg); + for (i = 0; i < sz; i++) initialize(&Field(res, i), Field(arg, i)); + } + CAMLreturn (res); +} + +/* Shorten the given block to the given size and return void. + Raise Invalid_argument if the given size is less than or equal + to 0 or greater than the current size. + + algorithm: + Change the length field of the header. Make up a white object + with the leftover part of the object: this is needed in the major + heap and harmless in the minor heap. +*/ +CAMLprim value obj_truncate (value v, value newsize) +{ + mlsize_t new_wosize = Long_val (newsize); + header_t hd = Hd_val (v); + tag_t tag = Tag_hd (hd); + color_t color = Color_hd (hd); + mlsize_t wosize = Wosize_hd (hd); + mlsize_t i; + + if (tag == Double_array_tag) new_wosize *= Double_wosize; /* PR#156 */ + + if (new_wosize <= 0 || new_wosize > wosize) invalid_argument ("Obj.truncate"); + if (new_wosize == wosize) return Val_unit; + /* PR#61: since we're about to lose our references to the elements + beyond new_wosize in v, erase them explicitly so that the GC + can darken them as appropriate. */ + if (tag < No_scan_tag) { + for (i = new_wosize; i < wosize; i++){ + modify(&Field(v, i), Val_unit); +#ifdef DEBUG + Field (v, i) = Debug_free_truncate; +#endif + } + } + /* We must use an odd tag for the header of the leftovers so it does not + look like a pointer because there may be some references to it in + ref_table. */ + Field (v, new_wosize) = + Make_header (Wosize_whsize (wosize-new_wosize), 1, Caml_white); + Hd_val (v) = Make_header (new_wosize, tag, color); + return Val_unit; +} + + +/* [lazy_is_forward] and [lazy_follow_forward] are used in stdlib/lazy.ml. + They are not written in O'Caml because they must be atomic with respect + to the GC. + */ + +CAMLprim value lazy_is_forward (value v) +{ + return Val_bool (Is_block (v) && Tag_val (v) == Forward_tag); +} + +CAMLprim value lazy_follow_forward (value v) +{ + if (Is_block (v) && Tag_val (v) == Forward_tag){ + return Forward_val (v); + }else{ + return v; + } +} diff --git a/byterun/osdeps.h b/byterun/osdeps.h new file mode 100644 index 00000000..02be9eac --- /dev/null +++ b/byterun/osdeps.h @@ -0,0 +1,64 @@ +/***********************************************************************/ +/* */ +/* 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$ */ + +/* Operating system - specific stuff */ + +#ifndef _osdeps_ + +#define _osdeps_ + +#include "misc.h" + +/* Decompose the given path into a list of directories, and add them + to the given table. Return the block to be freed later. */ +extern char * decompose_path(struct ext_table * tbl, char * path); + +/* Search the given file in the given list of directories. + If not found, return a copy of [name]. Result is allocated with + [stat_alloc]. */ +extern char * search_in_path(struct ext_table * path, char * name); + +/* Same, but search an executable name in the system path for executables. */ +CAMLextern char * search_exe_in_path(char * name); + +/* Same, but search a shared library in the given path. */ +extern char * search_dll_in_path(struct ext_table * path, char * name); + +/* Open a shared library and return a handle on it. + Return [NULL] on error. */ +extern void * caml_dlopen(char * libname); + +/* Close a shared library handle */ +extern void caml_dlclose(void * handle); + +/* Look up the given symbol in the given shared library. + Return [NULL] if not found, or symbol value if found. */ +extern void * caml_dlsym(void * handle, char * name); + +/* Return an error message describing the most recent dynlink failure. */ +extern char * caml_dlerror(void); + +/* Add to [contents] the (short) names of the files contained in + the directory named [dirname]. No entries are added for [.] and [..]. + Return 0 on success, -1 on error; set errno in the case of error. */ +extern int caml_read_directory(char * dirname, struct ext_table * contents); + +#ifdef __linux__ +/* Recover executable name from /proc/self/exe if possible */ +extern int executable_name(char * name, int name_len); +#endif + +#endif + diff --git a/byterun/parsing.c b/byterun/parsing.c new file mode 100644 index 00000000..e0a26f87 --- /dev/null +++ b/byterun/parsing.c @@ -0,0 +1,290 @@ +/***********************************************************************/ +/* */ +/* 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: parsing.c,v 1.17 2002/11/01 17:06:42 doligez Exp $ */ + +/* The PDA automaton for parsers generated by camlyacc */ + +#include +#include +#include "config.h" +#include "mlvalues.h" +#include "memory.h" +#include "alloc.h" + +#define ERRCODE 256 + +struct parser_tables { /* Mirrors parse_tables in ../stdlib/parsing.mli */ + value actions; + value transl_const; + value transl_block; + char * lhs; + char * len; + char * defred; + char * dgoto; + char * sindex; + char * rindex; + char * gindex; + value tablesize; + char * table; + char * check; + value error_function; + char * names_const; + char * names_block; +}; + +struct parser_env { /* Mirrors parser_env in ../stdlib/parsing.ml */ + value s_stack; + value v_stack; + value symb_start_stack; + value symb_end_stack; + value stacksize; + value stackbase; + value curr_char; + value lval; + value symb_start; + value symb_end; + value asp; + value rule_len; + value rule_number; + value sp; + value state; + value errflag; +}; + +#if defined(ARCH_BIG_ENDIAN) || SIZEOF_SHORT != 2 +#define Short(tbl,n) \ + (*((unsigned char *)((tbl) + (n) * 2)) + \ + (*((schar *)((tbl) + (n) * 2 + 1)) << 8)) +#else +#define Short(tbl,n) (((short *)(tbl))[n]) +#endif + +int parser_trace = 0; + +/* Input codes */ +/* Mirrors parser_input in ../stdlib/parsing.ml */ +#define START 0 +#define TOKEN_READ 1 +#define STACKS_GROWN_1 2 +#define STACKS_GROWN_2 3 +#define SEMANTIC_ACTION_COMPUTED 4 +#define ERROR_DETECTED 5 + +/* Output codes */ +/* Mirrors parser_output in ../stdlib/parsing.ml */ +#define READ_TOKEN Val_int(0) +#define RAISE_PARSE_ERROR Val_int(1) +#define GROW_STACKS_1 Val_int(2) +#define GROW_STACKS_2 Val_int(3) +#define COMPUTE_SEMANTIC_ACTION Val_int(4) +#define CALL_ERROR_FUNCTION Val_int(5) + +/* To preserve local variables when communicating with the ML code */ + +#define SAVE \ + env->sp = Val_int(sp), \ + env->state = Val_int(state), \ + env->errflag = Val_int(errflag) + +#define RESTORE \ + sp = Int_val(env->sp), \ + state = Int_val(env->state), \ + errflag = Int_val(env->errflag) + +/* Auxiliary for printing token just read */ + +static char * token_name(char * names, int number) +{ + for (/*nothing*/; number > 0; number--) { + if (names[0] == 0) return ""; + names += strlen(names) + 1; + } + return names; +} + +static void print_token(struct parser_tables *tables, int state, value tok) +{ + mlsize_t i; + value v; + + if (Is_long(tok)) { + fprintf(stderr, "State %d: read token %s\n", + state, token_name(tables->names_const, Int_val(tok))); + } else { + fprintf(stderr, "State %d: read token %s(", + state, token_name(tables->names_block, Tag_val(tok))); + v = Field(tok, 0); + if (Is_long(v)) + fprintf(stderr, "%ld", Long_val(v)); + else if (Tag_val(v) == String_tag) + fprintf(stderr, "%s", String_val(v)); + else if (Tag_val(v) == Double_tag) + fprintf(stderr, "%g", Double_val(v)); + else + fprintf(stderr, "_"); + fprintf(stderr, ")\n"); + } +} + +/* The pushdown automata */ + +CAMLprim value parse_engine(struct parser_tables *tables, + struct parser_env *env, value cmd, value arg) +{ + int state; + mlsize_t sp, asp; + int errflag; + int n, n1, n2, m, state1; + + switch(Int_val(cmd)) { + + case START: + state = 0; + sp = Int_val(env->sp); + errflag = 0; + + loop: + n = Short(tables->defred, state); + if (n != 0) goto reduce; + if (Int_val(env->curr_char) >= 0) goto testshift; + SAVE; + return READ_TOKEN; + /* The ML code calls the lexer and updates */ + /* symb_start and symb_end */ + case TOKEN_READ: + RESTORE; + if (Is_block(arg)) { + env->curr_char = Field(tables->transl_block, Tag_val(arg)); + modify(&env->lval, Field(arg, 0)); + } else { + env->curr_char = Field(tables->transl_const, Int_val(arg)); + modify(&env->lval, Val_long(0)); + } + if (parser_trace) print_token(tables, state, arg); + + testshift: + n1 = Short(tables->sindex, state); + n2 = n1 + Int_val(env->curr_char); + if (n1 != 0 && n2 >= 0 && n2 <= Int_val(tables->tablesize) && + Short(tables->check, n2) == Int_val(env->curr_char)) goto shift; + n1 = Short(tables->rindex, state); + n2 = n1 + Int_val(env->curr_char); + if (n1 != 0 && n2 >= 0 && n2 <= Int_val(tables->tablesize) && + Short(tables->check, n2) == Int_val(env->curr_char)) { + n = Short(tables->table, n2); + goto reduce; + } + if (errflag > 0) goto recover; + SAVE; + return CALL_ERROR_FUNCTION; + /* The ML code calls the error function */ + case ERROR_DETECTED: + RESTORE; + recover: + if (errflag < 3) { + errflag = 3; + while (1) { + state1 = Int_val(Field(env->s_stack, sp)); + n1 = Short(tables->sindex, state1); + n2 = n1 + ERRCODE; + if (n1 != 0 && n2 >= 0 && n2 <= Int_val(tables->tablesize) && + Short(tables->check, n2) == ERRCODE) { + if (parser_trace) + fprintf(stderr, "Recovering in state %d\n", state1); + goto shift_recover; + } else { + if (parser_trace) fprintf(stderr, "Discarding state %d\n", state1); + if (sp <= Int_val(env->stackbase)) { + if (parser_trace) fprintf(stderr, "No more states to discard\n"); + return RAISE_PARSE_ERROR; /* The ML code raises Parse_error */ + } + sp--; + } + } + } else { + if (Int_val(env->curr_char) == 0) + return RAISE_PARSE_ERROR; /* The ML code raises Parse_error */ + if (parser_trace) fprintf(stderr, "Discarding last token read\n"); + env->curr_char = Val_int(-1); + goto loop; + } + + shift: + env->curr_char = Val_int(-1); + if (errflag > 0) errflag--; + shift_recover: + if (parser_trace) + fprintf(stderr, "State %d: shift to state %d\n", + state, Short(tables->table, n2)); + state = Short(tables->table, n2); + sp++; + if (sp < Long_val(env->stacksize)) goto push; + SAVE; + return GROW_STACKS_1; + /* The ML code resizes the stacks */ + case STACKS_GROWN_1: + RESTORE; + push: + Field(env->s_stack, sp) = Val_int(state); + modify(&Field(env->v_stack, sp), env->lval); + Store_field (env->symb_start_stack, sp, env->symb_start); + Store_field (env->symb_end_stack, sp, env->symb_end); + goto loop; + + reduce: + if (parser_trace) + fprintf(stderr, "State %d: reduce by rule %d\n", state, n); + m = Short(tables->len, n); + env->asp = Val_int(sp); + env->rule_number = Val_int(n); + env->rule_len = Val_int(m); + sp = sp - m + 1; + m = Short(tables->lhs, n); + state1 = Int_val(Field(env->s_stack, sp - 1)); + n1 = Short(tables->gindex, m); + n2 = n1 + state1; + if (n1 != 0 && n2 >= 0 && n2 <= Int_val(tables->tablesize) && + Short(tables->check, n2) == state1) { + state = Short(tables->table, n2); + } else { + state = Short(tables->dgoto, m); + } + if (sp < Long_val(env->stacksize)) goto semantic_action; + SAVE; + return GROW_STACKS_2; + /* The ML code resizes the stacks */ + case STACKS_GROWN_2: + RESTORE; + semantic_action: + SAVE; + return COMPUTE_SEMANTIC_ACTION; + /* The ML code calls the semantic action */ + case SEMANTIC_ACTION_COMPUTED: + RESTORE; + Field(env->s_stack, sp) = Val_int(state); + modify(&Field(env->v_stack, sp), arg); + asp = Int_val(env->asp); + Store_field (env->symb_end_stack, sp, Field(env->symb_end_stack, asp)); + if (sp > asp) { + /* This is an epsilon production. Take symb_start equal to symb_end. */ + Store_field (env->symb_start_stack, sp, Field(env->symb_end_stack, asp)); + } + goto loop; + + default: /* Should not happen */ + Assert(0); + return RAISE_PARSE_ERROR; /* Keeps gcc -Wall happy */ + } + +} diff --git a/byterun/prims.h b/byterun/prims.h new file mode 100644 index 00000000..b7180f71 --- /dev/null +++ b/byterun/prims.h @@ -0,0 +1,33 @@ +/***********************************************************************/ +/* */ +/* 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: prims.h,v 1.7 2003/05/26 12:41:54 xleroy Exp $ */ + +/* Interface with C primitives. */ + +#ifndef _prims_ +#define _prims_ + +typedef value (*c_primitive)(); + +extern c_primitive builtin_cprim[]; +extern char * names_of_builtin_cprim[]; + +extern struct ext_table prim_table; +#ifdef DEBUG +extern struct ext_table prim_name_table; +#endif + +#define Primitive(n) ((c_primitive)(prim_table.contents[n])) + +#endif /* _prims_ */ diff --git a/byterun/printexc.c b/byterun/printexc.c new file mode 100644 index 00000000..97b7efd3 --- /dev/null +++ b/byterun/printexc.c @@ -0,0 +1,138 @@ +/***********************************************************************/ +/* */ +/* 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: printexc.c,v 1.13 2001/12/07 13:39:34 xleroy Exp $ */ + +/* Print an uncaught exception and abort */ + +#include +#include +#include +#include "backtrace.h" +#include "callback.h" +#include "debugger.h" +#include "fail.h" +#include "misc.h" +#include "mlvalues.h" +#ifdef HAS_UI +#include "ui.h" +#endif +#include "printexc.h" + +struct stringbuf { + char * ptr; + char * end; + char data[256]; +}; + +static void add_char(struct stringbuf *buf, char c) +{ + if (buf->ptr < buf->end) *(buf->ptr++) = c; +} + +static void add_string(struct stringbuf *buf, char *s) +{ + int len = strlen(s); + if (buf->ptr + len > buf->end) len = buf->end - buf->ptr; + if (len > 0) memmove(buf->ptr, s, len); + buf->ptr += len; +} + +CAMLexport char * format_caml_exception(value exn) +{ + mlsize_t start, i; + value bucket, v; + struct stringbuf buf; + char intbuf[64]; + char * res; + + buf.ptr = buf.data; + buf.end = buf.data + sizeof(buf.data) - 1; + add_string(&buf, String_val(Field(Field(exn, 0), 0))); + if (Wosize_val(exn) >= 2) { + /* Check for exceptions in the style of Match_failure and Assert_failure */ + if (Wosize_val(exn) == 2 && + Is_block(Field(exn, 1)) && + Tag_val(Field(exn, 1)) == 0) { + bucket = Field(exn, 1); + start = 0; + } else { + bucket = exn; + start = 1; + } + add_char(&buf, '('); + for (i = start; i < Wosize_val(bucket); i++) { + if (i > start) add_string(&buf, ", "); + v = Field(bucket, i); + if (Is_long(v)) { + sprintf(intbuf, "%ld", Long_val(v)); + add_string(&buf, intbuf); + } else if (Tag_val(v) == String_tag) { + add_char(&buf, '"'); + add_string(&buf, String_val(v)); + add_char(&buf, '"'); + } else { + add_char(&buf, '_'); + } + } + add_char(&buf, ')'); + } + *buf.ptr = 0; /* Terminate string */ + i = buf.ptr - buf.data + 1; + res = malloc(i); + if (res == NULL) return NULL; + memmove(res, buf.data, i); + return res; +} + + +void fatal_uncaught_exception(value exn) +{ + char * msg; + value * at_exit; +#ifndef NATIVE_CODE + int saved_backtrace_active, saved_backtrace_pos; +#endif + /* Build a string representation of the exception */ + msg = format_caml_exception(exn); + /* Perform "at_exit" processing, ignoring all exceptions that may + be triggered by this */ +#ifndef NATIVE_CODE + saved_backtrace_active = backtrace_active; + saved_backtrace_pos = backtrace_pos; + backtrace_active = 0; +#endif + at_exit = caml_named_value("Pervasives.do_at_exit"); + if (at_exit != NULL) callback_exn(*at_exit, Val_unit); +#ifndef NATIVE_CODE + backtrace_active = saved_backtrace_active; + backtrace_pos = saved_backtrace_pos; +#endif + /* Display the uncaught exception */ +#ifdef HAS_UI + ui_print_stderr("Fatal error: exception %s\n", msg); +#else + fprintf(stderr, "Fatal error: exception %s\n", msg); +#endif + free(msg); + /* Display the backtrace if available */ +#ifndef NATIVE_CODE + if (backtrace_active && !debugger_in_use) print_exception_backtrace(); +#endif + /* Terminate the process */ +#ifdef HAS_UI + ui_exit(2); +#else + exit(2); +#endif +} diff --git a/byterun/printexc.h b/byterun/printexc.h new file mode 100644 index 00000000..0bef3809 --- /dev/null +++ b/byterun/printexc.h @@ -0,0 +1,27 @@ +/***********************************************************************/ +/* */ +/* 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: printexc.h,v 1.3 2001/12/07 13:39:34 xleroy Exp $ */ + +#ifndef _printexc_ +#define _printexc_ + + +#include "misc.h" +#include "mlvalues.h" + +CAMLextern char * format_caml_exception (value); +void fatal_uncaught_exception (value) Noreturn; + + +#endif /* _printexc_ */ diff --git a/byterun/reverse.h b/byterun/reverse.h new file mode 100644 index 00000000..97cefd15 --- /dev/null +++ b/byterun/reverse.h @@ -0,0 +1,88 @@ +/***********************************************************************/ +/* */ +/* 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: reverse.h,v 1.11 2002/04/18 07:27:38 garrigue Exp $ */ + +/* Swap byte-order in 16, 32, and 64-bit integers or floats */ + +#ifndef _reverse_ +#define _reverse_ + +#define Reverse_16(dst,src) { \ + char * _p, * _q; \ + char _a; \ + _p = (char *) (src); \ + _q = (char *) (dst); \ + _a = _p[0]; \ + _q[0] = _p[1]; \ + _q[1] = _a; \ +} + +#define Reverse_32(dst,src) { \ + char * _p, * _q; \ + char _a, _b; \ + _p = (char *) (src); \ + _q = (char *) (dst); \ + _a = _p[0]; \ + _b = _p[1]; \ + _q[0] = _p[3]; \ + _q[1] = _p[2]; \ + _q[3] = _a; \ + _q[2] = _b; \ +} + +#define Reverse_64(dst,src) { \ + char * _p, * _q; \ + char _a, _b; \ + _p = (char *) (src); \ + _q = (char *) (dst); \ + _a = _p[0]; \ + _b = _p[1]; \ + _q[0] = _p[7]; \ + _q[1] = _p[6]; \ + _q[7] = _a; \ + _q[6] = _b; \ + _a = _p[2]; \ + _b = _p[3]; \ + _q[2] = _p[5]; \ + _q[3] = _p[4]; \ + _q[5] = _a; \ + _q[4] = _b; \ +} + +#define Perm_index(perm,i) ((perm >> (i * 4)) & 0xF) + +#define Permute_64(dst,perm_dst,src,perm_src) { \ + char * _p; \ + char _a, _b, _c, _d, _e, _f, _g, _h; \ + _p = (char *) (src); \ + _a = _p[Perm_index(perm_src, 0)]; \ + _b = _p[Perm_index(perm_src, 1)]; \ + _c = _p[Perm_index(perm_src, 2)]; \ + _d = _p[Perm_index(perm_src, 3)]; \ + _e = _p[Perm_index(perm_src, 4)]; \ + _f = _p[Perm_index(perm_src, 5)]; \ + _g = _p[Perm_index(perm_src, 6)]; \ + _h = _p[Perm_index(perm_src, 7)]; \ + _p = (char *) (dst); \ + _p[Perm_index(perm_dst, 0)] = _a; \ + _p[Perm_index(perm_dst, 1)] = _b; \ + _p[Perm_index(perm_dst, 2)] = _c; \ + _p[Perm_index(perm_dst, 3)] = _d; \ + _p[Perm_index(perm_dst, 4)] = _e; \ + _p[Perm_index(perm_dst, 5)] = _f; \ + _p[Perm_index(perm_dst, 6)] = _g; \ + _p[Perm_index(perm_dst, 7)] = _h; \ +} + +#endif /* _reverse_ */ diff --git a/byterun/roots.c b/byterun/roots.c new file mode 100644 index 00000000..8f386d8d --- /dev/null +++ b/byterun/roots.c @@ -0,0 +1,111 @@ +/***********************************************************************/ +/* */ +/* 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: roots.c,v 1.24 2002/01/18 15:13:25 doligez Exp $ */ + +/* To walk the memory roots for garbage collection */ + +#include "finalise.h" +#include "globroots.h" +#include "major_gc.h" +#include "memory.h" +#include "minor_gc.h" +#include "misc.h" +#include "mlvalues.h" +#include "roots.h" +#include "stacks.h" + +CAMLexport struct caml__roots_block *local_roots = NULL; + +void (*scan_roots_hook) (scanning_action f) = NULL; + +/* FIXME rename to [oldify_young_roots] and synchronise with asmrun/roots.c */ +/* Call [oldify_one] on (at least) all the roots that point to the minor + heap. */ +void oldify_local_roots (void) +{ + register value * sp; + struct global_root * gr; + struct caml__roots_block *lr; + long i, j; + + /* The stack */ + for (sp = extern_sp; sp < stack_high; sp++) { + oldify_one (*sp, sp); + } + /* Local C roots */ /* FIXME do the old-frame trick ? */ + for (lr = local_roots; lr != NULL; lr = lr->next) { + for (i = 0; i < lr->ntables; i++){ + for (j = 0; j < lr->nitems; j++){ + sp = &(lr->tables[i][j]); + oldify_one (*sp, sp); + } + } + } + /* Global C roots */ + for (gr = caml_global_roots.forward[0]; gr != NULL; gr = gr->forward[0]) { + oldify_one(*(gr->root), 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) +{ + struct global_root * gr; + + /* Global variables */ + f(global_data, &global_data); + + /* The stack and the local C roots */ + do_local_roots(f, extern_sp, stack_high, 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, value *stack_low, value *stack_high, + struct caml__roots_block *local_roots) +{ + register value * sp; + struct caml__roots_block *lr; + int i, j; + + for (sp = stack_low; sp < stack_high; sp++) { + f (*sp, sp); + } + for (lr = local_roots; lr != NULL; lr = lr->next) { + for (i = 0; i < lr->ntables; i++){ + for (j = 0; j < lr->nitems; j++){ + sp = &(lr->tables[i][j]); + f (*sp, sp); + } + } + } +} + diff --git a/byterun/roots.h b/byterun/roots.h new file mode 100644 index 00000000..642ffeb2 --- /dev/null +++ b/byterun/roots.h @@ -0,0 +1,38 @@ +/***********************************************************************/ +/* */ +/* 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: roots.h,v 1.16 2001/12/07 13:39:36 xleroy Exp $ */ + +#ifndef _roots_ +#define _roots_ + +#include "misc.h" +#include "memory.h" + +typedef void (*scanning_action) (value, value *); + +void oldify_local_roots (void); +void darken_all_roots (void); +void do_roots (scanning_action); +#ifndef NATIVE_CODE +CAMLextern void do_local_roots (scanning_action, value *, value *, + struct caml__roots_block *); +#else +CAMLextern void do_local_roots(scanning_action f, char * bottom_of_stack, + unsigned long last_retaddr, value * gc_regs, + struct caml__roots_block * local_roots); +#endif + +CAMLextern void (*scan_roots_hook) (scanning_action); + +#endif /* _roots_ */ diff --git a/byterun/rotatecursor.c b/byterun/rotatecursor.c new file mode 100644 index 00000000..9c0e4e87 --- /dev/null +++ b/byterun/rotatecursor.c @@ -0,0 +1,120 @@ +/***********************************************************************/ +/* */ +/* Objective Caml */ +/* */ +/* Damien Doligez, projet Para, 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: rotatecursor.c,v 1.10 2001/12/07 13:39:36 xleroy Exp $ */ + +/* rotatecursor library, written by + This file is in the public domain. + + version 1.13 + + See rotatecursor.h for documentation. +*/ + +#include +#include +#include +#include + +#include "rotatecursor.h" + +typedef struct { + TMTask t; + int volatile *p1; + int volatile *p2; +} Xtmtask; + +int volatile rotatecursor_flag = 1; +static int rotatecursor_inited = 0; +static int rotatecursor_period = 50; +static Xtmtask rotatecursor_tmtask; +static pascal void (*rotatecursor_action) (long) = &RotateCursor; + + +#if GENERATINGCFM + +static void rotatecursor_timerproc (Xtmtask *p) +{ + if (p->p1 != NULL && *(p->p1) == 0) *(p->p1) = 1; + if (p->p2 != NULL && *(p->p2) == 0) *(p->p2) = 1; +} + +#else /* GENERATINGCFM */ + +extern Xtmtask *getparam() ONEWORDINLINE(0x2009); /* MOVE.L A1, D0 */ + +static void rotatecursor_timerproc (void) +{ + register Xtmtask *p = getparam (); + + if (p->p1 != NULL && *(p->p1) == 0) *(p->p1) = 1; + if (p->p2 != NULL && *(p->p2) == 0) *(p->p2) = 1; +} + +#endif /* else GENERATINGCFM */ + + +void rotatecursor_final (void) +{ + if (rotatecursor_inited){ + RmvTime ((QElemPtr) &rotatecursor_tmtask); + rotatecursor_flag = 1; + rotatecursor_inited = 0; + } +} + +static void rotatecursor_init (void) +{ + if (rotatecursor_inited) return; + + rotatecursor_tmtask.t.tmAddr = NewTimerProc (rotatecursor_timerproc); + rotatecursor_tmtask.t.tmCount = 0; + rotatecursor_tmtask.t.tmWakeUp = 0; + rotatecursor_tmtask.t.tmReserved = 0; + rotatecursor_tmtask.p1 = NULL; + rotatecursor_tmtask.p2 = &rotatecursor_flag; + + InsTime ((QElemPtr) &rotatecursor_tmtask); + atexit (rotatecursor_final); + rotatecursor_flag = 1; + + rotatecursor_inited = 1; +} + +void rotatecursor_options (int volatile *p1, int period, pascal void (*f) (long)) +{ + if (!rotatecursor_inited) rotatecursor_init (); + + rotatecursor_tmtask.p1 = p1; + if (p1 != NULL && *p1 == 0) *p1 = rotatecursor_flag; + rotatecursor_period = (period == 0) ? 50 : period; + rotatecursor_action = (f == NULL) ? &RotateCursor : f; +} + +int rotatecursor_rearm (void) +{ + if (!rotatecursor_inited) rotatecursor_init (); + + rotatecursor_flag = 0; + PrimeTime ((QElemPtr) &rotatecursor_tmtask, rotatecursor_period); + return 0; +} + +int rotatecursor_ticker (void) +{ + if (!rotatecursor_inited) rotatecursor_init (); + + rotatecursor_rearm (); + (*rotatecursor_action) (32); + return 0; +} diff --git a/byterun/rotatecursor.h b/byterun/rotatecursor.h new file mode 100644 index 00000000..6710c02c --- /dev/null +++ b/byterun/rotatecursor.h @@ -0,0 +1,124 @@ +/***********************************************************************/ +/* */ +/* Objective Caml */ +/* */ +/* Damien Doligez, projet Para, 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: rotatecursor.h,v 1.9 2001/12/07 13:39:36 xleroy Exp $ */ + +/* rotatecursor library, written by + This file is in the public domain. + + version 1.13 + + The goal of this library is to help implement cooperative multitasking + for MPW tools: to make sure that your program calls RotateCursor often + enough (about 20 times per second) but not too often (to avoid a big + slowdown). + It can also be used for applications with a little more work. + + + Simple usage for MPW tools: + ^^^^^^^^^^^^^^^^^^^^^^^^^^^ + 1. #include this file where appropriate + 2. Insert the following line in every loop of your program: + ROTATECURSOR_MAGIC (); + The overhead of this macro is only a few CPU cycles, so it can be + used without problem even in tight loops. + + + Simple usage for applications: + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + 1. Write a function with prototype: + pascal void myaction (long x); + This functions should get and handle all events until the event + queue is empty (i.e. until it gets a null event). It should also + animate the cursor. + 2. #include this file where appropriate + 3. Add this line to the init code of your program: + rotatecursor_options (NULL, 0, &myaction); + 4. Insert the following line in every loop of your program: + ROTATECURSOR_MAGIC (); + The overhead of this macro is only a few CPU cycles, so it can be + used without problem even in tight loops. + 5. If there is no function called RotateCursor in your libraries, you + will have to provide one that does nothing (it will not be called). + + See below for advanced options. +*/ + +#ifndef _rotatecursor_h_ +#define _rotatecursor_h_ + +extern int volatile rotatecursor_flag; +/* + [rotatecursor_flag] will be automagically set to 1 when the time comes + to call [rotatecursor_ticker]. +*/ + + +void rotatecursor_options (int volatile *p1, int period, + pascal void (*action) (long)); +/* + Use [rotatecursor_options] to change advanced parameters: + + 1. [p1] is a pointer to another variable that will be set to 1 when + the time is up, unless it is already nonzero. Typical use is when + you already have a variable in your program that is set + asynchronously for something else, and you want to avoid testing + two different variables in your inner loop. Pass [NULL] in this + argument if you don't need this feature. + + 2. [period] is the interval (in milliseconds) between calls to + RotateCursor. Reasonable values are between 10 and 200. + If you pass 0 in this argument, the default value (50) will + be used. This value is passed to PrimeTime, so a negative value + represents a delay in microseconds (not very useful here...) + + 3. [action] is the function that will be called at regular intervals + by [rotatecursor_ticker]. If you pass [NULL] in this argument, + the default function, [RotateCursor], will be called. +*/ + +int rotatecursor_rearm (void); +/* + [rotatecursor_rearm] resets [rotatecursor_flag] to 0 and rearms the + Time Manager task that will set [rotatecursor_flag] to 1 after the + appropriate delay. + You can use [rotatecursor_rearm] if some part of your program needs + to perform a periodic action that is not the normal one set up + with [rotatecursor_options]. + This function always returns 0. +*/ + +int rotatecursor_ticker (void); +/* + [rotatecursor_ticker] calls [rotatecursor_rearm] (see below) and your + [action] function (or [RotateCursor]). + This function always returns 0. It returns an int so you can use + it in an expression as well as a statement. + */ + +#define ROTATECURSOR_MAGIC() (rotatecursor_flag ? rotatecursor_ticker () : 0) +/* + [ROTATECURSOR_MAGIC] is a simple interface to [rotatecursor_flag] + and [rotatecursor_ticker]. Can be used as a statement (followed by + a semicolon) or in an expression (followed by a comma). +*/ + +void rotatecursor_final (void); +/* + [rotatecursor_final] is set up (with [atexit]) to be called before your + program finishes. If for any reason the [atexit] functions are not + called before your program exits, you should call this function by hand. + It is harmless to call [rotatecursor_final] twice. +*/ + +#endif /* _rotatecursor_h_ */ diff --git a/byterun/signals.c b/byterun/signals.c new file mode 100644 index 00000000..98b35d2e --- /dev/null +++ b/byterun/signals.c @@ -0,0 +1,295 @@ +/***********************************************************************/ +/* */ +/* 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: signals.c,v 1.39 2002/04/18 07:27:38 garrigue Exp $ */ + +#include +#include "alloc.h" +#include "callback.h" +#include "config.h" +#include "fail.h" +#include "memory.h" +#include "misc.h" +#include "mlvalues.h" +#include "roots.h" +#include "signals.h" +#include "sys.h" + +#if macintosh +#include "rotatecursor.h" +#endif /* macintosh */ + +#ifdef _WIN32 +typedef void (*sighandler)(int sig); +extern sighandler win32_signal(int sig, sighandler action); +#define signal(sig,act) win32_signal(sig,act) +#endif + +int volatile async_signal_mode = 0; +int volatile pending_signal = 0; +int volatile something_to_do = 0; +int volatile force_major_slice = 0; +value signal_handlers = 0; +void (*enter_blocking_section_hook)(void) = NULL; +void (*leave_blocking_section_hook)(void) = NULL; +void (* volatile async_action_hook)(void) = NULL; + +void process_event(void) +{ + int signal_number; + void (*async_action)(void); + if (force_major_slice) minor_collection (); /* FIXME should be check_urgent_gc */ + /* If a signal arrives between the following two instructions, + it will be lost. To do: use atomic swap or atomic read-and-clear + for processors that support it? */ + signal_number = pending_signal; + pending_signal = 0; + if (signal_number) execute_signal(signal_number, 0); + /* If an async action is scheduled between the following two instructions, + it will be lost. */ + async_action = async_action_hook; + async_action_hook = NULL; + if (async_action != NULL) (*async_action)(); +#if macintosh + ROTATECURSOR_MAGIC (); +#endif +} + +static int rev_convert_signal_number(int signo); + +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)); +} + +void handle_signal(int signal_number) +{ +#if !defined(POSIX_SIGNALS) && !defined(BSD_SIGNALS) + signal(signal_number, handle_signal); +#endif + if (async_signal_mode){ + leave_blocking_section (); + execute_signal(signal_number, 1); + enter_blocking_section (); + }else{ + pending_signal = signal_number; + something_to_do = 1; + } +} + +void urge_major_slice (void) +{ + force_major_slice = 1; + something_to_do = 1; +} + +CAMLexport void enter_blocking_section(void) +{ + int temp; + + while (1){ + Assert (!async_signal_mode); + /* If a signal arrives between the next two instructions, + it will be lost. */ + temp = pending_signal; pending_signal = 0; + if (temp) execute_signal(temp, 0); + async_signal_mode = 1; + if (!pending_signal) break; + async_signal_mode = 0; + } + if (enter_blocking_section_hook != NULL) enter_blocking_section_hook(); +} + +CAMLexport void leave_blocking_section(void) +{ +#ifdef _WIN32 + int signal_number; +#endif + + if (leave_blocking_section_hook != NULL) leave_blocking_section_hook(); +#ifdef _WIN32 + /* Under Win32, asynchronous signals such as ctrl-C are not processed + immediately (see ctrl_handler in win32.c), but simply set + pending_signal and let the system call run to completion. + Hence, test pending_signal here and act upon it, before we get + a chance to process the result of the system call. */ + signal_number = pending_signal; + pending_signal = 0; + if (signal_number) execute_signal(signal_number, 1); +#endif + Assert(async_signal_mode); + async_signal_mode = 0; +} + +#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 +}; + +CAMLexport 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 + +CAMLprim value install_signal_handler(value signal_number, value action) +{ + 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 = handle_signal; + break; + } +#ifdef POSIX_SIGNALS + sigact.sa_handler = act; + sigemptyset(&sigact.sa_mask); + sigact.sa_flags = 0; + 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 == 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); +} diff --git a/byterun/signals.h b/byterun/signals.h new file mode 100644 index 00000000..49cfa8e2 --- /dev/null +++ b/byterun/signals.h @@ -0,0 +1,45 @@ +/***********************************************************************/ +/* */ +/* 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: signals.h,v 1.18 2003/06/23 12:52:06 xleroy Exp $ */ + +#ifndef _signals_ +#define _signals_ + +#include "misc.h" +#include "mlvalues.h" + +/* */ +extern value signal_handlers; +CAMLextern int volatile pending_signal; +CAMLextern int volatile something_to_do; +extern int volatile force_major_slice; +CAMLextern int volatile async_signal_mode; +/* */ + +CAMLextern void enter_blocking_section (void); +CAMLextern void leave_blocking_section (void); + +/* */ +void urge_major_slice (void); +CAMLextern int convert_signal_number (int); +void execute_signal(int signal_number, int in_signal_handler); +void process_event(void); + +CAMLextern void (*enter_blocking_section_hook)(void); +CAMLextern void (*leave_blocking_section_hook)(void); +CAMLextern void (* volatile async_action_hook)(void); +/* */ + +#endif /* _signals_ */ + diff --git a/byterun/stacks.c b/byterun/stacks.c new file mode 100644 index 00000000..131a58a6 --- /dev/null +++ b/byterun/stacks.c @@ -0,0 +1,102 @@ +/***********************************************************************/ +/* */ +/* 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: stacks.c,v 1.18 2001/12/07 13:39:36 xleroy Exp $ */ + +/* To initialize and resize the stacks */ + +#include +#include "config.h" +#include "fail.h" +#include "misc.h" +#include "mlvalues.h" +#include "stacks.h" + +CAMLexport value * stack_low; +CAMLexport value * stack_high; +CAMLexport value * stack_threshold; +CAMLexport value * extern_sp; +CAMLexport value * trapsp; +CAMLexport value * trap_barrier; +value global_data; + +unsigned long max_stack_size; /* also used in gc_ctrl.c */ + +void init_stack (long unsigned int initial_max_size) +{ + stack_low = (value *) stat_alloc(Stack_size); + stack_high = stack_low + Stack_size / sizeof (value); + stack_threshold = stack_low + Stack_threshold / sizeof (value); + extern_sp = stack_high; + trapsp = stack_high; + trap_barrier = stack_high + 1; + max_stack_size = initial_max_size; + gc_message (0x08, "Initial stack limit: %luk bytes\n", + max_stack_size / 1024 * sizeof (value)); +} + +void realloc_stack(asize_t required_space) +{ + asize_t size; + value * new_low, * new_high, * new_sp; + value * p; + + Assert(extern_sp >= stack_low); + size = stack_high - stack_low; + do { + if (size >= max_stack_size) raise_stack_overflow(); + size *= 2; + } while (size < stack_high - extern_sp + required_space); + gc_message (0x08, "Growing stack to %luk bytes\n", + (unsigned long) size * sizeof(value) / 1024); + new_low = (value *) stat_alloc(size * sizeof(value)); + new_high = new_low + size; + +#define shift(ptr) \ + ((char *) new_high - ((char *) stack_high - (char *) (ptr))) + + new_sp = (value *) shift(extern_sp); + memmove((char *) new_sp, + (char *) extern_sp, + (stack_high - extern_sp) * sizeof(value)); + stat_free(stack_low); + trapsp = (value *) shift(trapsp); + trap_barrier = (value *) shift(trap_barrier); + for (p = trapsp; p < new_high; p = Trap_link(p)) + Trap_link(p) = (value *) shift(Trap_link(p)); + stack_low = new_low; + stack_high = new_high; + stack_threshold = stack_low + Stack_threshold / sizeof (value); + extern_sp = new_sp; + +#undef shift +} + +CAMLprim value ensure_stack_capacity(value required_space) +{ + asize_t req = Long_val(required_space); + if (extern_sp - req < stack_low) realloc_stack(req); + return Val_unit; +} + +void change_max_stack_size (long unsigned int new_max_size) +{ + asize_t size = stack_high - extern_sp + Stack_threshold / sizeof (value); + + if (new_max_size < size) new_max_size = size; + if (new_max_size != max_stack_size){ + gc_message (0x08, "Changing stack limit to %luk bytes\n", + new_max_size * sizeof (value) / 1024); + } + max_stack_size = new_max_size; +} diff --git a/byterun/stacks.h b/byterun/stacks.h new file mode 100644 index 00000000..7a53bbba --- /dev/null +++ b/byterun/stacks.h @@ -0,0 +1,43 @@ +/***********************************************************************/ +/* */ +/* 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: stacks.h,v 1.10 2001/12/07 13:39:36 xleroy Exp $ */ + +/* structure of the stacks */ + +#ifndef _stacks_ +#define _stacks_ + + +#include "misc.h" +#include "mlvalues.h" +#include "memory.h" + +CAMLextern value * stack_low; +CAMLextern value * stack_high; +CAMLextern value * stack_threshold; +CAMLextern value * extern_sp; +CAMLextern value * trapsp; +CAMLextern value * trap_barrier; + +#define Trap_pc(tp) (((code_t *)(tp))[0]) +#define Trap_link(tp) (((value **)(tp))[1]) + +void reset_roots (void); +void init_stack (unsigned long init_max_size); +void realloc_stack (asize_t required_size); +void change_max_stack_size (unsigned long new_max_size); + + +#endif /* _stacks_ */ + diff --git a/byterun/startup.c b/byterun/startup.c new file mode 100644 index 00000000..19435aa0 --- /dev/null +++ b/byterun/startup.c @@ -0,0 +1,456 @@ +/***********************************************************************/ +/* */ +/* 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: startup.c,v 1.56 2003/06/01 15:58:05 xleroy Exp $ */ + +/* Start-up code */ + +#include +#include +#include +#include +#include "config.h" +#ifdef HAS_UNISTD +#include +#endif +#ifdef _WIN32 +#include +#endif +#include "alloc.h" +#include "backtrace.h" +#include "callback.h" +#include "custom.h" +#include "debugger.h" +#include "dynlink.h" +#include "exec.h" +#include "fail.h" +#include "fix_code.h" +#include "gc_ctrl.h" +#include "instrtrace.h" +#include "interp.h" +#include "intext.h" +#include "io.h" +#include "memory.h" +#include "minor_gc.h" +#include "misc.h" +#include "mlvalues.h" +#include "osdeps.h" +#include "prims.h" +#include "printexc.h" +#include "reverse.h" +#include "signals.h" +#include "stacks.h" +#include "sys.h" +#include "startup.h" + +#ifndef O_BINARY +#define O_BINARY 0 +#endif + +#ifndef SEEK_END +#define SEEK_END 2 +#endif + +extern int parser_trace; + +CAMLexport header_t atom_table[256]; + +/* Initialize the atom table */ + +static void init_atoms(void) +{ + int i; + for(i = 0; i < 256; i++) atom_table[i] = Make_header(0, i, Caml_white); +} + +/* Read the trailer of a bytecode file */ + +static void fixup_endianness_trailer(uint32 * p) +{ +#ifndef ARCH_BIG_ENDIAN + Reverse_32(p, p); +#endif +} + +static int read_trailer(int fd, struct exec_trailer *trail) +{ + lseek(fd, (long) -TRAILER_SIZE, SEEK_END); + if (read(fd, (char *) trail, TRAILER_SIZE) < TRAILER_SIZE) + return BAD_BYTECODE; + fixup_endianness_trailer(&trail->num_sections); + if (strncmp(trail->magic, EXEC_MAGIC, 12) == 0) + return 0; + else + return BAD_BYTECODE; +} + +int attempt_open(char **name, struct exec_trailer *trail, + int do_open_script) +{ + char * truename; + int fd; + int err; + char buf [2]; + + truename = search_exe_in_path(*name); + *name = truename; + gc_message(0x100, "Opening bytecode executable %s\n", + (unsigned long) truename); + fd = open(truename, O_RDONLY | O_BINARY); + if (fd == -1) { + gc_message(0x100, "Cannot open file\n", 0); + return FILE_NOT_FOUND; + } + if (!do_open_script) { + err = read (fd, buf, 2); + if (err < 2 || (buf [0] == '#' && buf [1] == '!')) { + close(fd); + gc_message(0x100, "Rejected #! script\n", 0); + return BAD_BYTECODE; + } + } + err = read_trailer(fd, trail); + if (err != 0) { + close(fd); + gc_message(0x100, "Not a bytecode executable\n", 0); + return err; + } + return fd; +} + +/* Read the section descriptors */ + +void read_section_descriptors(int fd, struct exec_trailer *trail) +{ + int toc_size, i; + + toc_size = trail->num_sections * 8; + trail->section = stat_alloc(toc_size); + lseek(fd, - (long) (TRAILER_SIZE + toc_size), SEEK_END); + if (read(fd, (char *) trail->section, toc_size) != toc_size) + fatal_error("Fatal error: cannot read section table\n"); + /* Fixup endianness of lengths */ + for (i = 0; i < trail->num_sections; i++) + fixup_endianness_trailer(&(trail->section[i].len)); +} + +/* Position fd at the beginning of the section having the given name. + Return the length of the section data in bytes, or -1 if no section + found with that name. */ + +int32 seek_optional_section(int fd, struct exec_trailer *trail, char *name) +{ + long ofs; + int i; + + ofs = TRAILER_SIZE + trail->num_sections * 8; + for (i = trail->num_sections - 1; i >= 0; i--) { + ofs += trail->section[i].len; + if (strncmp(trail->section[i].name, name, 4) == 0) { + lseek(fd, -ofs, SEEK_END); + return trail->section[i].len; + } + } + return -1; +} + +/* Position fd at the beginning of the section having the given name. + Return the length of the section data in bytes. */ + +int32 seek_section(int fd, struct exec_trailer *trail, char *name) +{ + int32 len = seek_optional_section(fd, trail, name); + if (len == -1) + fatal_error_arg("Fatal_error: section `%s' is missing\n", name); + return len; +} + +/* Read and return the contents of the section having the given name. + Add a terminating 0. Return NULL if no such section. */ + +static char * read_section(int fd, struct exec_trailer *trail, char *name) +{ + int32 len; + char * data; + + len = seek_optional_section(fd, trail, name); + if (len == -1) return NULL; + data = stat_alloc(len + 1); + if (read(fd, data, len) != len) + fatal_error_arg("Fatal error: error reading section %s\n", name); + data[len] = 0; + return data; +} + +/* Invocation of ocamlrun: 4 cases. + + 1. runtime + bytecode + user types: ocamlrun [options] bytecode args... + arguments: ocamlrun [options] bytecode args... + + 2. bytecode script + user types: bytecode args... + 2a (kernel 1) arguments: ocamlrun ./bytecode args... + 2b (kernel 2) arguments: bytecode bytecode args... + + 3. concatenated runtime and bytecode + user types: composite args... + arguments: composite args... + +Algorithm: + 1- If argument 0 is a valid byte-code file that does not start with #!, + then we are in case 3 and we pass the same command line to the + Objective Caml program. + 2- In all other cases, we parse the command line as: + (whatever) [options] bytecode args... + and we strip "(whatever) [options]" from the command line. + +*/ + +/* 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 options on the command line */ + +static int parse_command_line(char **argv) +{ + int i, j; + + for(i = 1; argv[i] != NULL && argv[i][0] == '-'; i++) { + switch(argv[i][1]) { +#ifdef DEBUG + case 't': + trace_flag = 1; + break; +#endif + case 'v': + verb_gc = 0x001+0x004+0x008+0x010+0x020; + break; + case 'p': + for (j = 0; names_of_builtin_cprim[j] != NULL; j++) + printf("%s\n", names_of_builtin_cprim[j]); + exit(0); + break; + case 'b': + init_backtrace(); + break; + case 'I': + if (argv[i + 1] != NULL) { + ext_table_add(&shared_libs_path, argv[i + 1]); + i++; + } + break; + default: + fatal_error_arg("Unknown option %s.\n", argv[i]); + } + } + return i; +} + +/* 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). +*/ + +/* If you change these functions, see also their copy in asmrun/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 'b': init_backtrace(); break; + case 'p': parser_trace = 1; break; + } + } + } +} + +extern void init_ieee_floats (void); + +#ifdef _WIN32 +extern void caml_signal_thread(void * lpParam); +#endif + +/* Main entry point when loading code from a file */ + +CAMLexport void caml_main(char **argv) +{ + int fd, pos; + struct exec_trailer trail; + struct channel * chan; + value res; + char * shared_lib_path, * shared_libs, * req_prims; + char * exe_name; +#ifdef __linux__ + static char proc_self_exe[256]; +#endif + + /* Machine-dependent initialization of the floating-point hardware + so that it behaves as much as possible as specified in IEEE */ + init_ieee_floats(); + init_custom_operations(); + ext_table_init(&shared_libs_path, 8); + external_raise = NULL; + /* Determine options and position of bytecode file */ +#ifdef DEBUG + verb_gc = 63; +#endif + parse_camlrunparam(); + pos = 0; + exe_name = argv[0]; +#ifdef __linux__ + if (executable_name(proc_self_exe, sizeof(proc_self_exe)) == 0) + exe_name = proc_self_exe; +#endif + fd = attempt_open(&exe_name, &trail, 0); + if (fd < 0) { + pos = parse_command_line(argv); + if (argv[pos] == 0) + fatal_error("No bytecode file specified.\n"); + exe_name = argv[pos]; + fd = attempt_open(&exe_name, &trail, 1); + switch(fd) { + case FILE_NOT_FOUND: + fatal_error_arg("Fatal error: cannot find file %s\n", argv[pos]); + break; + case BAD_BYTECODE: + fatal_error_arg( + "Fatal error: the file %s is not a bytecode executable file\n", + argv[pos]); + break; + } + } + /* Read the table of contents (section descriptors) */ + read_section_descriptors(fd, &trail); + /* Initialize the abstract machine */ + init_gc (minor_heap_init, heap_size_init, heap_chunk_init, + percent_free_init, max_percent_free_init); + init_stack (max_stack_init); + init_atoms(); + /* Initialize the interpreter */ + interprete(NULL, 0); + /* Initialize the debugger, if needed */ + debugger_init(); + /* Load the code */ + code_size = seek_section(fd, &trail, "CODE"); + load_code(fd, code_size); + /* Build the table of primitives */ + shared_lib_path = read_section(fd, &trail, "DLPT"); + shared_libs = read_section(fd, &trail, "DLLS"); + req_prims = read_section(fd, &trail, "PRIM"); + if (req_prims == NULL) fatal_error("Fatal error: no PRIM section\n"); + build_primitive_table(shared_lib_path, shared_libs, req_prims); + stat_free(shared_lib_path); + stat_free(shared_libs); + stat_free(req_prims); + /* Load the globals */ + seek_section(fd, &trail, "DATA"); + chan = open_descriptor_in(fd); + global_data = input_val(chan); + close_channel(chan); /* this also closes fd */ + stat_free(trail.section); + /* Ensure that the globals are in the major heap. */ + oldify_one (global_data, &global_data); + oldify_mopup (); + /* Initialize system libraries */ + init_exceptions(); + sys_init(exe_name, argv + pos); +#ifdef _WIN32 + /* Start a thread to handle signals */ + if (getenv("CAMLSIGPIPE")) + _beginthread(caml_signal_thread, 4096, NULL); +#endif + /* Execute the program */ + debugger(PROGRAM_START); + res = interprete(start_code, code_size); + if (Is_exception_result(res)) { + exn_bucket = Extract_exception(res); + if (debugger_in_use) { + extern_sp = &exn_bucket; /* The debugger needs the exception value. */ + debugger(UNCAUGHT_EXC); + } + fatal_uncaught_exception(exn_bucket); + } +} + +/* Main entry point when code is linked in as initialized data */ + +CAMLexport void caml_startup_code(code_t code, asize_t code_size, + char *data, char **argv) +{ + value res; + + init_ieee_floats(); + init_custom_operations(); +#ifdef DEBUG + verb_gc = 63; +#endif + parse_camlrunparam(); + external_raise = NULL; + /* Initialize the abstract machine */ + init_gc (minor_heap_init, heap_size_init, heap_chunk_init, + percent_free_init, max_percent_free_init); + init_stack (max_stack_init); + init_atoms(); + /* Initialize the interpreter */ + interprete(NULL, 0); + /* Load the code */ + start_code = code; +#ifdef THREADED_CODE + thread_code(start_code, code_size); +#endif + /* Use the builtin table of primitives */ + prim_table.size = prim_table.capacity = -1; + prim_table.contents = (void **) builtin_cprim; + /* Load the globals */ + global_data = input_val_from_string((value)data, 0); + /* Ensure that the globals are in the major heap. */ + oldify_one (global_data, &global_data); + oldify_mopup (); + /* Run the code */ + init_exceptions(); + sys_init("", argv); + res = interprete(start_code, code_size); + if (Is_exception_result(res)) + fatal_uncaught_exception(Extract_exception(res)); +} + diff --git a/byterun/startup.h b/byterun/startup.h new file mode 100644 index 00000000..93d55f84 --- /dev/null +++ b/byterun/startup.h @@ -0,0 +1,21 @@ +#ifndef _startup_ +#define _startup_ + +#include "misc.h" +#include "exec.h" + +CAMLextern void caml_main(char **argv); +CAMLextern void caml_startup_code(code_t code, asize_t code_size, + char *data, char **argv); + +enum { FILE_NOT_FOUND = -1, BAD_BYTECODE = -2 }; + +extern int attempt_open(char **name, struct exec_trailer *trail, + int do_open_script); +extern void read_section_descriptors(int fd, struct exec_trailer *trail); +extern int32 seek_optional_section(int fd, struct exec_trailer *trail, + char *name); +extern int32 seek_section(int fd, struct exec_trailer *trail, char *name); + + +#endif diff --git a/byterun/str.c b/byterun/str.c new file mode 100644 index 00000000..7e3af3dd --- /dev/null +++ b/byterun/str.c @@ -0,0 +1,149 @@ +/***********************************************************************/ +/* */ +/* 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: str.c,v 1.20 2003/05/06 13:52:08 xleroy Exp $ */ + +/* Operations on strings */ + +#include +#include +#include "alloc.h" +#include "fail.h" +#include "mlvalues.h" +#include "misc.h" +#ifdef HAS_LOCALE +#include +#endif + +CAMLexport mlsize_t string_length(value s) +{ + mlsize_t temp; + temp = Bosize_val(s) - 1; + Assert (Byte (s, temp - Byte (s, temp)) == 0); + return temp - Byte (s, temp); +} + +CAMLprim value ml_string_length(value s) +{ + mlsize_t temp; + temp = Bosize_val(s) - 1; + Assert (Byte (s, temp - Byte (s, temp)) == 0); + return Val_long(temp - Byte (s, temp)); +} + +CAMLprim value create_string(value len) +{ + mlsize_t size = Long_val(len); + if (size > Bsize_wsize (Max_wosize) - 1) invalid_argument("String.create"); + return alloc_string(size); +} + +CAMLprim value string_get(value str, value index) +{ + long idx = Long_val(index); + if (idx < 0 || idx >= string_length(str)) invalid_argument("String.get"); + return Val_int(Byte_u(str, idx)); +} + +CAMLprim value string_set(value str, value index, value newval) +{ + long idx = Long_val(index); + if (idx < 0 || idx >= string_length(str)) invalid_argument("String.set"); + Byte_u(str, idx) = Int_val(newval); + return Val_unit; +} + +CAMLprim value string_equal(value s1, value s2) +{ + mlsize_t sz1 = Wosize_val(s1); + mlsize_t sz2 = Wosize_val(s2); + value * p1, * p2; + if (sz1 != sz2) return Val_false; + for(p1 = Op_val(s1), p2 = Op_val(s2); sz1 > 0; sz1--, p1++, p2++) + if (*p1 != *p2) return Val_false; + return Val_true; +} + +CAMLprim value string_notequal(value s1, value s2) +{ + return Val_not(string_equal(s1, s2)); +} + +CAMLprim value string_compare(value s1, value s2) +{ + mlsize_t len1, len2, len; + int res; + + len1 = string_length(s1); + len2 = string_length(s2); + res = memcmp(String_val(s1), String_val(s2), len1 <= len2 ? len1 : len2); + if (res < 0) return Val_int(-1); + if (res > 0) return Val_int(1); + if (len1 < len2) return Val_int(-1); + if (len1 > len2) return Val_int(1); + return Val_int(0); +} + +CAMLprim value string_lessthan(value s1, value s2) +{ + return string_compare(s1, s2) < Val_int(0) ? Val_true : Val_false; +} + +CAMLprim value string_lessequal(value s1, value s2) +{ + return string_compare(s1, s2) <= Val_int(0) ? Val_true : Val_false; +} + +CAMLprim value string_greaterthan(value s1, value s2) +{ + return string_compare(s1, s2) > Val_int(0) ? Val_true : Val_false; +} + +CAMLprim value string_greaterequal(value s1, value s2) +{ + return string_compare(s1, s2) >= Val_int(0) ? Val_true : Val_false; +} + +CAMLprim value blit_string(value s1, value ofs1, value s2, value ofs2, value n) +{ + memmove(&Byte(s2, Long_val(ofs2)), &Byte(s1, Long_val(ofs1)), Int_val(n)); + return Val_unit; +} + +CAMLprim value fill_string(value s, value offset, value len, value init) +{ + memset(&Byte(s, Long_val(offset)), Int_val(init), Long_val(len)); + return Val_unit; +} + +CAMLprim value is_printable(value chr) +{ + int c; + +#ifdef HAS_LOCALE + static int locale_is_set = 0; + if (! locale_is_set) { + setlocale(LC_CTYPE, ""); + locale_is_set = 1; + } +#endif + c = Int_val(chr); + return Val_bool(isprint(c)); +} + +CAMLprim value bitvect_test(value bv, value n) +{ + int pos = Int_val(n); + return Val_int(Byte_u(bv, pos >> 3) & (1 << (pos & 7))); +} + diff --git a/byterun/sys.c b/byterun/sys.c new file mode 100644 index 00000000..b450600c --- /dev/null +++ b/byterun/sys.c @@ -0,0 +1,349 @@ +/***********************************************************************/ +/* */ +/* 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: sys.c,v 1.63 2003/03/24 15:24:51 xleroy Exp $ */ + +/* Basic system calls */ + +#include +#include +#include +#include +#include +#include +#include +#if !macintosh +#include +#include +#endif +#if !macintosh && !_WIN32 +#include +#endif +#if macintosh +#include "macintosh.h" +#endif +#include "config.h" +#ifdef HAS_UNISTD +#include +#endif +#ifdef HAS_TIMES +#include +#endif +#ifdef HAS_GETTIMEOFDAY +#include +#endif +#include "alloc.h" +#include "debugger.h" +#include "fail.h" +#include "instruct.h" +#include "mlvalues.h" +#include "osdeps.h" +#include "signals.h" +#include "stacks.h" +#include "sys.h" +#ifdef HAS_UI +#include "ui.h" +#endif + +#ifndef _WIN32 +extern int errno; +#endif + +#ifdef HAS_STRERROR + +#ifndef _WIN32 +extern char * strerror(int); +#endif + +char * error_message(void) +{ + return strerror(errno); +} + +#else + +extern int sys_nerr; +extern char * sys_errlist []; + +char * error_message(void) +{ + if (errno < 0 || errno >= sys_nerr) + return "unknown error"; + else + return sys_errlist[errno]; +} + +#endif /* HAS_STRERROR */ + +#ifndef EAGAIN +#define EAGAIN (-1) +#endif +#ifndef EWOULDBLOCK +#define EWOULDBLOCK (-1) +#endif + +CAMLexport void sys_error(value arg) +{ + CAMLparam1 (arg); + char * err; + CAMLlocal1 (str); + + if (errno == EAGAIN || errno == EWOULDBLOCK) { + raise_sys_blocked_io(); + } else { + err = error_message(); + if (arg == NO_ARG) { + str = copy_string(err); + } else { + int err_len = strlen(err); + int arg_len = string_length(arg); + str = alloc_string(arg_len + 2 + err_len); + memmove(&Byte(str, 0), String_val(arg), arg_len); + memmove(&Byte(str, arg_len), ": ", 2); + memmove(&Byte(str, arg_len + 2), err, err_len); + } + raise_sys_error(str); + } +} + +CAMLprim value sys_exit(value retcode) +{ +#ifndef NATIVE_CODE + debugger(PROGRAM_EXIT); +#endif +#ifdef HAS_UI + ui_exit(Int_val(retcode)); +#else + exit(Int_val(retcode)); +#endif + return Val_unit; +} + +#ifndef O_BINARY +#define O_BINARY 0 +#endif +#ifndef O_TEXT +#define O_TEXT 0 +#endif +#ifndef O_NONBLOCK +#ifdef O_NDELAY +#define O_NONBLOCK O_NDELAY +#else +#define O_NONBLOCK 0 +#endif +#endif + +static int sys_open_flags[] = { + O_RDONLY, O_WRONLY, O_APPEND | O_WRONLY, O_CREAT, O_TRUNC, O_EXCL, + O_BINARY, O_TEXT, O_NONBLOCK +}; + +CAMLprim value sys_open(value path, value flags, value perm) +{ + CAMLparam3(path, flags, perm); + int fd; + char * p; + + p = stat_alloc(string_length(path) + 1); + strcpy(p, String_val(path)); + /* open on a named FIFO can block (PR#1533) */ + enter_blocking_section(); + fd = open(p, convert_flag_list(flags, sys_open_flags) +#if !macintosh + , Int_val(perm) +#endif + ); + leave_blocking_section(); + stat_free(p); + if (fd == -1) sys_error(path); +#if defined(F_SETFD) && defined(FD_CLOEXEC) + fcntl(fd, F_SETFD, FD_CLOEXEC); +#endif + CAMLreturn(Val_long(fd)); +} + +CAMLprim value sys_close(value fd) +{ + close(Int_val(fd)); + return Val_unit; +} + +CAMLprim value sys_file_exists(value name) +{ +#if macintosh + int f; + f = open (String_val (name), O_RDONLY); + if (f == -1) return (Val_bool (0)); + close (f); + return (Val_bool (1)); +#else + struct stat st; + return Val_bool(stat(String_val(name), &st) == 0); +#endif +} + +CAMLprim value sys_remove(value name) +{ + int ret; + ret = unlink(String_val(name)); + if (ret != 0) sys_error(name); + return Val_unit; +} + +CAMLprim value sys_rename(value oldname, value newname) +{ + if (rename(String_val(oldname), String_val(newname)) != 0) + sys_error(oldname); + return Val_unit; +} + +CAMLprim value sys_chdir(value dirname) +{ + if (chdir(String_val(dirname)) != 0) sys_error(dirname); + return Val_unit; +} + +CAMLprim value sys_getcwd(value unit) +{ + char buff[4096]; +#ifdef HAS_GETCWD + if (getcwd(buff, sizeof(buff)) == 0) sys_error(NO_ARG); +#else + if (getwd(buff) == 0) sys_error(NO_ARG); +#endif /* HAS_GETCWD */ + return copy_string(buff); +} + +CAMLprim value sys_getenv(value var) +{ + char * res; + + res = getenv(String_val(var)); + if (res == 0) raise_not_found(); + return copy_string(res); +} + +char * caml_exe_name; +static char ** caml_main_argv; + +CAMLprim value sys_get_argv(value unit) +{ + CAMLparam0 (); /* unit is unused */ + CAMLlocal3 (exe_name, argv, res); + exe_name = copy_string(caml_exe_name); + argv = copy_string_array((char const **) caml_main_argv); + res = alloc_small(2, 0); + Field(res, 0) = exe_name; + Field(res, 1) = argv; + CAMLreturn(res); +} + +void sys_init(char * exe_name, char **argv) +{ + caml_exe_name = exe_name; + caml_main_argv = argv; +} + +#ifdef _WIN32 +#define WIFEXITED(status) 1 +#define WEXITSTATUS(status) (status) +#else +#if !(defined(WIFEXITED) && defined(WEXITSTATUS)) +/* Assume old-style V7 status word */ +#define WIFEXITED(status) (((status) & 0xFF) == 0) +#define WEXITSTATUS(status) (((status) >> 8) & 0xFF) +#endif +#endif + +CAMLprim value sys_system_command(value command) +{ + CAMLparam1 (command); + int status, retcode; + char *buf; + unsigned long len; + + len = string_length (command); + buf = stat_alloc (len + 1); + memmove (buf, String_val (command), len + 1); + enter_blocking_section (); + status = system(buf); + leave_blocking_section (); + stat_free(buf); + if (status == -1) sys_error(command); + if (WIFEXITED(status)) + retcode = WEXITSTATUS(status); + else + retcode = 255; + CAMLreturn (Val_int(retcode)); +} + +CAMLprim value sys_time(value unit) +{ +#ifdef HAS_TIMES +#ifndef CLK_TCK +#ifdef HZ +#define CLK_TCK HZ +#else +#define CLK_TCK 60 +#endif +#endif + struct tms t; + times(&t); + return copy_double((double)(t.tms_utime + t.tms_stime) / CLK_TCK); +#else + /* clock() is standard ANSI C */ + return copy_double((double)clock() / CLOCKS_PER_SEC); +#endif +} + +CAMLprim value sys_random_seed (value unit) +{ + long seed; +#ifdef HAS_GETTIMEOFDAY + struct timeval tv; + gettimeofday(&tv, NULL); + seed = tv.tv_sec ^ tv.tv_usec; +#else + seed = time (NULL); +#endif +#ifdef HAS_UNISTD + seed ^= getppid() << 16 | getpid(); +#endif + return Val_long(seed); +} + +CAMLprim value sys_get_config(value unit) +{ + CAMLparam0 (); /* unit is unused */ + CAMLlocal2 (result, ostype); + + ostype = copy_string(OCAML_OS_TYPE); + result = alloc_small (2, 0); + Field(result, 0) = ostype; + Field(result, 1) = Val_long (8 * sizeof(value)); + CAMLreturn (result); +} + +CAMLprim value sys_read_directory(value path) +{ + CAMLparam1(path); + CAMLlocal1(result); + struct ext_table tbl; + + ext_table_init(&tbl, 50); + if (caml_read_directory(String_val(path), &tbl) == -1) sys_error(path); + ext_table_add(&tbl, NULL); + result = copy_string_array((char const **) tbl.contents); + ext_table_free(&tbl, 1); + CAMLreturn(result); +} diff --git a/byterun/sys.h b/byterun/sys.h new file mode 100644 index 00000000..3943df5b --- /dev/null +++ b/byterun/sys.h @@ -0,0 +1,29 @@ +/***********************************************************************/ +/* */ +/* 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: sys.h,v 1.11 2002/02/11 13:51:40 xleroy Exp $ */ + +#ifndef _sys_ +#define _sys_ + +#include "misc.h" + +#define NO_ARG Val_int(0) + +CAMLextern void sys_error (value); +extern void sys_init (char * exe_name, char ** argv); +CAMLextern value sys_exit (value); + +extern char * caml_exe_name; + +#endif /* _sys_ */ diff --git a/byterun/terminfo.c b/byterun/terminfo.c new file mode 100644 index 00000000..2f2c78f6 --- /dev/null +++ b/byterun/terminfo.c @@ -0,0 +1,132 @@ +/***********************************************************************/ +/* */ +/* 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: terminfo.c,v 1.21 2002/08/13 17:16:32 doligez Exp $ */ + +/* Read and output terminal commands */ + +#include "config.h" +#include "alloc.h" +#include "fail.h" +#include "io.h" +#include "mlvalues.h" + +#define Uninitialised (Val_int(0)) +#define Bad_term (Val_int(1)) +#define Good_term_tag 0 + +#if defined (HAS_TERMCAP) && !defined (NATIVE_CODE) + +extern int tgetent (char * buffer, char * name); +extern char * tgetstr (char * id, char ** area); +extern int tgetnum (char * id); +extern int tputs (char * str, int count, int (*outchar)(int c)); + +static struct channel *chan; +static char area [1024]; +static char *area_p = area; +static int num_lines; +static char *up = NULL; +static char *down = NULL; +static char *standout = NULL; +static char *standend = NULL; + +CAMLprim value terminfo_setup (value vchan) +{ + value result; + static char buffer[1024]; + char *term; + + chan = Channel (vchan); + + term = getenv ("TERM"); + if (term == NULL) return Bad_term; + if (tgetent(buffer, term) != 1) return Bad_term; + + num_lines = tgetnum ("li"); + up = tgetstr ("up", &area_p); + down = tgetstr ("do", &area_p); + standout = tgetstr ("us", &area_p); + standend = tgetstr ("ue", &area_p); + if (standout == NULL || standend == NULL){ + standout = tgetstr ("so", &area_p); + standend = tgetstr ("se", &area_p); + } + Assert (area_p <= area + 1024); + if (num_lines == -1 || up == NULL || down == NULL + || standout == NULL || standend == NULL){ + return Bad_term; + } + result = alloc_small (1, Good_term_tag); + Field (result, 0) = Val_int (num_lines); + return result; +} + +static int terminfo_putc (int c) +{ + putch (chan, c); + return c; +} + +CAMLprim value terminfo_backup (value lines) +{ + int i; + + for (i = 0; i < Int_val (lines); i++){ + tputs (up, 1, terminfo_putc); + } + return Val_unit; +} + +CAMLprim value terminfo_standout (value start) +{ + tputs (Bool_val (start) ? standout : standend, 1, terminfo_putc); + return Val_unit; +} + +CAMLprim value terminfo_resume (value lines) +{ + int i; + + for (i = 0; i < Int_val (lines); i++){ + tputs (down, 1, terminfo_putc); + } + return Val_unit; +} + +#else /* defined (HAS_TERMCAP) && !defined (NATIVE_CODE) */ + +CAMLexport value terminfo_setup (value vchan) +{ + return Bad_term; +} + +CAMLexport value terminfo_backup (value lines) +{ + invalid_argument("Terminfo.backup"); + return Val_unit; +} + +CAMLexport value terminfo_standout (value start) +{ + invalid_argument("Terminfo.standout"); + return Val_unit; +} + +CAMLexport value terminfo_resume (value lines) +{ + invalid_argument("Terminfo.resume"); + return Val_unit; +} + +#endif /* defined (HAS_TERMCAP) && !defined (NATIVE_CODE) */ diff --git a/byterun/ui.h b/byterun/ui.h new file mode 100644 index 00000000..7f773a78 --- /dev/null +++ b/byterun/ui.h @@ -0,0 +1,23 @@ +/***********************************************************************/ +/* */ +/* Objective Caml */ +/* */ +/* Damien Doligez, projet Para, 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: ui.h,v 1.4 2001/12/07 13:39:38 xleroy Exp $ */ + +/* Function declarations for non-Unix user interfaces */ + +#include "config.h" + +void ui_exit (int return_code); +int ui_read (int file_desc, char *buf, unsigned int length); +int ui_write (int file_desc, char *buf, unsigned int length); +void ui_print_stderr (char *format, void *arg); diff --git a/byterun/unix.c b/byterun/unix.c new file mode 100644 index 00000000..1e47b720 --- /dev/null +++ b/byterun/unix.c @@ -0,0 +1,377 @@ +/***********************************************************************/ +/* */ +/* 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$ */ + +/* Unix-specific stuff */ + +#include +#include +#include +#include +#include +#include +#include "config.h" +#ifdef SUPPORT_DYNAMIC_LINKING +#ifdef HAS_NSLINKMODULE +#include +#else +#include +#endif +#endif +#ifdef HAS_UNISTD +#include +#endif +#ifdef HAS_DIRENT +#include +#else +#include +#endif +#include "memory.h" +#include "misc.h" +#include "osdeps.h" + +#ifndef S_ISREG +#define S_ISREG(mode) (((mode) & S_IFMT) == S_IFREG) +#endif + +char * decompose_path(struct ext_table * tbl, char * path) +{ + char * p, * q; + int n; + + if (path == NULL) return NULL; + p = stat_alloc(strlen(path) + 1); + strcpy(p, path); + q = p; + while (1) { + for (n = 0; q[n] != 0 && q[n] != ':'; n++) /*nothing*/; + ext_table_add(tbl, q); + q = q + n; + if (*q == 0) break; + *q = 0; + q += 1; + } + return p; +} + +char * search_in_path(struct ext_table * path, char * name) +{ + char * p, * fullname; + int i; + struct stat st; + + for (p = name; *p != 0; p++) { + if (*p == '/') goto not_found; + } + for (i = 0; i < path->size; i++) { + fullname = stat_alloc(strlen((char *)(path->contents[i])) + + strlen(name) + 2); + strcpy(fullname, (char *)(path->contents[i])); + if (fullname[0] != 0) strcat(fullname, "/"); + strcat(fullname, name); + if (stat(fullname, &st) == 0 && S_ISREG(st.st_mode)) return fullname; + stat_free(fullname); + } + not_found: + fullname = stat_alloc(strlen(name) + 1); + strcpy(fullname, name); + return fullname; +} + +#ifdef __CYGWIN32__ + +/* Cygwin needs special treatment because of the implicit ".exe" at the + end of executable file names */ + +static int cygwin_file_exists(char * name) +{ + int fd; + /* Cannot use stat() here because it adds ".exe" implicitly */ + fd = open(name, O_RDONLY); + if (fd == -1) return 0; + close(fd); + return 1; +} + +static char * cygwin_search_exe_in_path(struct ext_table * path, char * name) +{ + char * p, * fullname; + int i; + + for (p = name; *p != 0; p++) { + if (*p == '/' || *p == '\\') goto not_found; + } + for (i = 0; i < path->size; i++) { + fullname = stat_alloc(strlen((char *)(path->contents[i])) + + strlen(name) + 6); + strcpy(fullname, (char *)(path->contents[i])); + strcat(fullname, "/"); + strcat(fullname, name); + if (cygwin_file_exists(fullname)) return fullname; + strcat(fullname, ".exe"); + if (cygwin_file_exists(fullname)) return fullname; + stat_free(fullname); + } + not_found: + fullname = stat_alloc(strlen(name) + 5); + strcpy(fullname, name); + if (cygwin_file_exists(fullname)) return fullname; + strcat(fullname, ".exe"); + if (cygwin_file_exists(fullname)) return fullname; + strcpy(fullname, name); + return fullname; +} + +#endif + +char * search_exe_in_path(char * name) +{ + struct ext_table path; + char * tofree; + char * res; + + ext_table_init(&path, 8); + tofree = decompose_path(&path, getenv("PATH")); +#ifndef __CYGWIN32__ + res = search_in_path(&path, name); +#else + res = cygwin_search_exe_in_path(&path, name); +#endif + stat_free(tofree); + ext_table_free(&path, 0); + return res; +} + +char * search_dll_in_path(struct ext_table * path, char * name) +{ + char * dllname = stat_alloc(strlen(name) + 4); + char * res; + strcpy(dllname, name); + strcat(dllname, ".so"); + res = search_in_path(path, dllname); + stat_free(dllname); + return res; +} + +#ifdef SUPPORT_DYNAMIC_LINKING +#ifdef HAS_NSLINKMODULE +/* Use MacOSX bundles */ + +static char *dlerror_string = "No error"; + +void * caml_dlopen(char * libname) +{ + NSObjectFileImage image; + NSObjectFileImageReturnCode retCode = + NSCreateObjectFileImageFromFile(libname, &image); + switch (retCode) { + case NSObjectFileImageSuccess: + dlerror_string = NULL; + return (void*)NSLinkModule(image, libname, NSLINKMODULE_OPTION_BINDNOW + | NSLINKMODULE_OPTION_RETURN_ON_ERROR); + case NSObjectFileImageAccess: + dlerror_string = "cannot access this bundle"; break; + case NSObjectFileImageArch: + dlerror_string = "this bundle has wrong CPU architecture"; break; + case NSObjectFileImageFormat: + case NSObjectFileImageInappropriateFile: + dlerror_string = "this file is not a proper bundle"; break; + default: + dlerror_string = "could not read object file"; break; + } + return NULL; +} + +void caml_dlclose(void * handle) +{ + dlerror_string = NULL; + NSUnLinkModule((NSModule)handle, NSUNLINKMODULE_OPTION_NONE); +} + +void * caml_dlsym(void * handle, char * name) +{ + NSSymbol sym; + char _name[1000] = "_"; + strncat (_name, name, 998); + dlerror_string = NULL; + sym = NSLookupSymbolInModule((NSModule)handle, _name); + if (sym != NULL) return NSAddressOfSymbol(sym); + else return NULL; +} + +char * caml_dlerror(void) +{ + NSLinkEditErrors c; + int errnum; + const char *fileName, *errorString; + if (dlerror_string != NULL) return dlerror_string; + NSLinkEditError(&c,&errnum,&fileName,&errorString); + return (char *) errorString; +} + +#else +/* Use normal dlopen */ + +#ifndef RTLD_GLOBAL +#define RTLD_GLOBAL 0 +#endif +#ifndef RTLD_NODELETE +#define RTLD_NODELETE 0 +#endif + +void * caml_dlopen(char * libname) +{ + return dlopen(libname, RTLD_NOW|RTLD_GLOBAL|RTLD_NODELETE); +} + +void caml_dlclose(void * handle) +{ + dlclose(handle); +} + +void * caml_dlsym(void * handle, char * name) +{ +#ifdef DL_NEEDS_UNDERSCORE + char _name[1000] = "_"; + strncat (_name, name, 998); + name = _name; +#endif + return dlsym(handle, name); +} + +char * caml_dlerror(void) +{ + return dlerror(); +} + +#endif +#else + +void * caml_dlopen(char * libname) +{ + return NULL; +} + +void caml_dlclose(void * handle) +{ +} + +void * caml_dlsym(void * handle, char * name) +{ + return NULL; +} + +char * caml_dlerror(void) +{ + return "dynamic loading not supported on this platform"; +} + +#endif + +#ifdef USE_MMAP_INSTEAD_OF_MALLOC + +/* The code below supports the use of mmap() rather than malloc() + for allocating the chunks composing the major heap. + This code is needed for the IA64 under Linux, where the native + malloc() implementation can return pointers several *exabytes* apart, + (some coming from mmap(), other from sbrk()); this makes the + page table *way* too large. + No other tested platform requires this hack so far. However, it could + be useful for other 64-bit platforms in the future. */ + +#include + +char *aligned_mmap (asize_t size, int modulo, void **block) +{ + char *raw_mem; + unsigned long aligned_mem; + Assert (modulo < Page_size); + raw_mem = (char *) mmap(NULL, size + Page_size, PROT_READ | PROT_WRITE, + MAP_PRIVATE | MAP_ANONYMOUS, -1, 0); + if (raw_mem == MAP_FAILED) return NULL; + *block = raw_mem; + raw_mem += modulo; /* Address to be aligned */ + aligned_mem = (((unsigned long) raw_mem / Page_size + 1) * Page_size); +#ifdef DEBUG + { + unsigned long *p; + unsigned long *p0 = (void *) *block, + *p1 = (void *) (aligned_mem - modulo), + *p2 = (void *) (aligned_mem - modulo + size), + *p3 = (void *) ((char *) *block + size + Page_size); + + for (p = p0; p < p1; p++) *p = Debug_filler_align; + for (p = p1; p < p2; p++) *p = Debug_uninit_align; + for (p = p2; p < p3; p++) *p = Debug_filler_align; + } +#endif + return (char *) (aligned_mem - modulo); +} + +void aligned_munmap (char * addr, asize_t size) +{ + int retcode = munmap (addr, size + Page_size); + Assert(retcode == 0); +} + +#endif + +/* Add to [contents] the (short) names of the files contained in + the directory named [dirname]. No entries are added for [.] and [..]. + Return 0 on success, -1 on error; set errno in the case of error. */ + +int caml_read_directory(char * dirname, struct ext_table * contents) +{ + DIR * d; +#ifdef HAS_DIRENT + struct dirent * e; +#else + struct direct * e; +#endif + char * p; + + d = opendir(dirname); + if (d == NULL) return -1; + while (1) { + e = readdir(d); + if (e == NULL) break; + if (strcmp(e->d_name, ".") == 0 || strcmp(e->d_name, "..") == 0) continue; + p = stat_alloc(strlen(e->d_name) + 1); + strcpy(p, e->d_name); + ext_table_add(contents, p); + } + closedir(d); + return 0; +} + +/* Recover executable name from /proc/self/exe if possible */ + +#ifdef __linux__ + +int executable_name(char * name, int name_len) +{ + int retcode; + struct stat st; + + retcode = readlink("/proc/self/exe", name, name_len); + if (retcode == -1 || retcode >= name_len) return -1; + name[retcode] = 0; + /* Make sure that the contents of /proc/self/exe is a regular file. + (Old Linux kernels return an inode number instead.) */ + if (stat(name, &st) != 0) return -1; + if (! S_ISREG(st.st_mode)) return -1; + return 0; +} + +#endif diff --git a/byterun/weak.c b/byterun/weak.c new file mode 100644 index 00000000..1c2d7682 --- /dev/null +++ b/byterun/weak.c @@ -0,0 +1,122 @@ +/***********************************************************************/ +/* */ +/* 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: weak.c,v 1.20 2002/09/17 14:12:48 doligez Exp $ */ + +/* Operations on weak arrays */ + +#include + +#include "alloc.h" +#include "fail.h" +#include "memory.h" +#include "mlvalues.h" + +value weak_list_head = 0; + +CAMLprim value weak_create (value len) +{ + mlsize_t size, i; + value res; + + size = Long_val (len) + 1; + if (size <= 0 || size > Max_wosize) invalid_argument ("Weak.create"); + res = alloc_shr (size, Abstract_tag); + for (i = 1; i < size; i++) Field (res, i) = 0; + Field (res, 0) = weak_list_head; + weak_list_head = res; + return res; +} + +#define None_val (Val_int(0)) +#define Some_tag 0 + +CAMLprim value weak_set (value ar, value n, value el) +{ + mlsize_t offset = Long_val (n) + 1; + Assert (Is_in_heap (ar)); + if (offset < 1 || offset >= Wosize_val (ar)) invalid_argument ("Weak.set"); + Field (ar, offset) = 0; + if (el != None_val){ + value v; Assert (Wosize_val (el) == 1); + v = Field (el, 0); + if (Is_block (v) && (Is_young (v) || Is_in_heap (v))){ + Modify (&Field (ar, offset), v); + } + } + return Val_unit; +} + +#define Setup_for_gc +#define Restore_after_gc + +CAMLprim value weak_get (value ar, value n) +{ + CAMLparam2 (ar, n); + mlsize_t offset = Long_val (n) + 1; + CAMLlocal2 (res, elt); + Assert (Is_in_heap (ar)); + if (offset < 1 || offset >= Wosize_val (ar)) invalid_argument ("Weak.get"); + if (Field (ar, offset) == 0){ + res = None_val; + }else{ + elt = Field (ar, offset); + if (gc_phase == Phase_mark) darken (elt, NULL); + res = alloc_small (1, Some_tag); + Field (res, 0) = elt; + } + CAMLreturn (res); +} + +#undef Setup_for_gc +#undef Restore_after_gc + +CAMLprim value weak_get_copy (value ar, value n) +{ + CAMLparam2 (ar, n); + mlsize_t offset = Long_val (n) + 1; + CAMLlocal2 (res, elt); + value v; /* Caution: this is NOT a local root. */ + Assert (Is_in_heap (ar)); + if (offset < 1 || offset >= Wosize_val (ar)) invalid_argument ("Weak.get"); + + v = Field (ar, offset); + if (v == 0) CAMLreturn (None_val); + if (Is_block (v) && (Is_young (v) || Is_in_heap (v))){ + elt = alloc (Wosize_val (v), Tag_val (v)); /* The GC may erase or move v. */ + v = Field (ar, offset); + if (v == 0) CAMLreturn (None_val); + if (Tag_val (v) < No_scan_tag){ + mlsize_t i; + for (i = 0; i < Wosize_val (v); i++){ + Modify (&Field (elt, i), Field (v, i)); + } + }else{ + memmove (Bp_val (elt), Bp_val (v), Bosize_val (v)); + } + }else{ + elt = v; + } + res = alloc_small (1, Some_tag); + Field (res, 0) = elt; + + CAMLreturn (res); +} + +CAMLprim value weak_check (value ar, value n) +{ + mlsize_t offset = Long_val (n) + 1; + Assert (Is_in_heap (ar)); + if (offset < 1 || offset >= Wosize_val (ar)) invalid_argument ("Weak.get"); + return Val_bool (Field (ar, offset) != 0); +} diff --git a/byterun/weak.h b/byterun/weak.h new file mode 100644 index 00000000..cf324c5c --- /dev/null +++ b/byterun/weak.h @@ -0,0 +1,20 @@ +/***********************************************************************/ +/* */ +/* 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: weak.h,v 1.4 2001/12/07 13:39:38 xleroy Exp $ */ + +/* Operations on weak arrays */ + +#include "mlvalues.h" + +extern value weak_list_head; diff --git a/byterun/win32.c b/byterun/win32.c new file mode 100644 index 00000000..e50307fe --- /dev/null +++ b/byterun/win32.c @@ -0,0 +1,392 @@ +/***********************************************************************/ +/* */ +/* 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: win32.c,v 1.18 2003/05/12 14:21:20 xleroy Exp $ */ + +/* Win32-specific stuff */ + +#include +#include +#include +#ifndef HAS_UI +#include +#endif +#include +#include +#include +#include +#include +#include +#include +#include "memory.h" +#include "misc.h" +#include "osdeps.h" +#include "signals.h" + +#ifndef S_ISREG +#define S_ISREG(mode) (((mode) & S_IFMT) == S_IFREG) +#endif + +char * decompose_path(struct ext_table * tbl, char * path) +{ + char * p, * q; + int n; + + if (path == NULL) return NULL; + p = stat_alloc(strlen(path) + 1); + strcpy(p, path); + q = p; + while (1) { + for (n = 0; q[n] != 0 && q[n] != ';'; n++) /*nothing*/; + ext_table_add(tbl, q); + q = q + n; + if (*q == 0) break; + *q = 0; + q += 1; + } + return p; +} + +char * search_in_path(struct ext_table * path, char * name) +{ + char * p, * fullname; + int i; + struct stat st; + + for (p = name; *p != 0; p++) { + if (*p == '/' || *p == '\\') goto not_found; + } + for (i = 0; i < path->size; i++) { + fullname = stat_alloc(strlen((char *)(path->contents[i])) + + strlen(name) + 2); + strcpy(fullname, (char *)(path->contents[i])); + strcat(fullname, "\\"); + strcat(fullname, name); + gc_message(0x100, "Searching %s\n", (unsigned long) fullname); + if (stat(fullname, &st) == 0 && S_ISREG(st.st_mode)) return fullname; + stat_free(fullname); + } + not_found: + gc_message(0x100, "%s not found in search path\n", (unsigned long) name); + fullname = stat_alloc(strlen(name) + 1); + strcpy(fullname, name); + return fullname; +} + +CAMLexport char * search_exe_in_path(char * name) +{ +#define MAX_PATH_LENGTH 512 + char * fullname = stat_alloc(512); + char * filepart; + + if (! SearchPath(NULL, /* use system search path */ + name, + ".exe", /* add .exe extension if needed */ + MAX_PATH_LENGTH, /* size of buffer */ + fullname, + &filepart)) + strcpy(fullname, name); + return fullname; +} + +char * search_dll_in_path(struct ext_table * path, char * name) +{ + char * dllname = stat_alloc(strlen(name) + 5); + char * res; + strcpy(dllname, name); + strcat(dllname, ".dll"); + res = search_in_path(path, dllname); + stat_free(dllname); + return res; +} + +void * caml_dlopen(char * libname) +{ + return (void *) LoadLibrary(libname); +} + +void caml_dlclose(void * handle) +{ + FreeLibrary((HMODULE) handle); +} + +void * caml_dlsym(void * handle, char * name) +{ + return (void *) GetProcAddress((HMODULE) handle, name); +} + +char * caml_dlerror(void) +{ + static char dlerror_buffer[256]; + DWORD msglen = + FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM | FORMAT_MESSAGE_IGNORE_INSERTS, + NULL, /* message source */ + GetLastError(), /* error number */ + 0, /* default language */ + dlerror_buffer, /* destination */ + sizeof(dlerror_buffer), /* size of destination */ + NULL); /* no inserts */ + if (msglen == 0) + return "unknown error"; + else + return dlerror_buffer; +} + +/* Proper emulation of signal(), including ctrl-C and ctrl-break */ + +typedef void (*sighandler)(int sig); +static int ctrl_handler_installed = 0; +static volatile sighandler ctrl_handler_action = SIG_DFL; + +static BOOL WINAPI ctrl_handler(DWORD event) +{ + int saved_mode; + sighandler action; + + /* Only ctrl-C and ctrl-Break are handled */ + if (event != CTRL_C_EVENT && event != CTRL_BREAK_EVENT) return FALSE; + /* Default behavior is to exit, which we get by not handling the event */ + if (ctrl_handler_action == SIG_DFL) return FALSE; + /* Ignore behavior is to do nothing, which we get by claiming that we + have handled the event */ + if (ctrl_handler_action == SIG_IGN) return TRUE; + /* Reset handler to default action for consistency with signal() */ + action = ctrl_handler_action; + ctrl_handler_action = SIG_DFL; + /* Call user-provided signal handler. Win32 doesn't like it when + we do a longjmp() at this point (it looks like we're running in + a different thread than the main program!). So, pretend we are not in + async signal mode, so that the handler simply records the signal. */ + saved_mode = async_signal_mode; + async_signal_mode = 0; + action(SIGINT); + async_signal_mode = saved_mode; + /* We have handled the event */ + return TRUE; +} + +sighandler win32_signal(int sig, sighandler action) +{ + sighandler oldaction; + + if (sig != SIGINT) return signal(sig, action); + if (! ctrl_handler_installed) { + SetConsoleCtrlHandler(ctrl_handler, TRUE); + ctrl_handler_installed = 1; + } + oldaction = ctrl_handler_action; + ctrl_handler_action = action; + return oldaction; +} + +/* Expansion of @responsefile and *? file patterns in the command line */ + +#ifndef HAS_UI + +static int argc; +static char ** argv; +static int argvsize; + +static void store_argument(char * arg); +static void expand_argument(char * arg); +static void expand_pattern(char * arg); +static void expand_diversion(char * filename); + +static void out_of_memory(void) +{ + fprintf(stderr, "Out of memory while expanding command line\n"); + exit(2); +} + +static void store_argument(char * arg) +{ + if (argc + 1 >= argvsize) { + argvsize *= 2; + argv = (char **) realloc(argv, argvsize * sizeof(char *)); + if (argv == NULL) out_of_memory(); + } + argv[argc++] = arg; +} + +static void expand_argument(char * arg) +{ + char * p; + + if (arg[0] == '@') { + expand_diversion(arg + 1); + return; + } + for (p = arg; *p != 0; p++) { + if (*p == '*' || *p == '?') { + expand_pattern(arg); + return; + } + } + store_argument(arg); +} + +static void expand_pattern(char * pat) +{ + int handle; + struct _finddata_t ffblk; + int preflen; + + handle = _findfirst(pat, &ffblk); + if (handle == -1) { + store_argument(pat); /* a la Bourne shell */ + return; + } + for (preflen = strlen(pat); preflen > 0; preflen--) { + char c = pat[preflen - 1]; + if (c == '\\' || c == '/' || c == ':') break; + } + do { + char * name = malloc(preflen + strlen(ffblk.name) + 1); + if (name == NULL) out_of_memory(); + memcpy(name, pat, preflen); + strcpy(name + preflen, ffblk.name); + store_argument(name); + } while (_findnext(handle, &ffblk) != -1); + _findclose(handle); +} + +static void expand_diversion(char * filename) +{ + struct _stat stat; + int fd; + char * buf, * endbuf, * p, * q, * s; + int inquote; + + if (_stat(filename, &stat) == -1 || + (fd = _open(filename, O_RDONLY | O_BINARY, 0)) == -1) { + fprintf(stderr, "Cannot open file %s\n", filename); + exit(2); + } + buf = (char *) malloc(stat.st_size + 1); + if (buf == NULL) out_of_memory(); + _read(fd, buf, stat.st_size); + endbuf = buf + stat.st_size; + _close(fd); + for (p = buf; p < endbuf; /*nothing*/) { + /* Skip leading blanks */ + while (p < endbuf && isspace(*p)) p++; + if (p >= endbuf) break; + s = p; + /* Skip to end of argument, taking quotes into account */ + q = s; + inquote = 0; + while (p < endbuf) { + if (! inquote) { + if (isspace(*p)) break; + if (*p == '"') { inquote = 1; p++; continue; } + *q++ = *p++; + } else { + switch (*p) { + case '"': + inquote = 0; p++; continue; + case '\\': + if (p + 4 <= endbuf && strncmp(p, "\\\\\\\"", 4) == 0) { + p += 4; *q++ = '\\'; *q++ = '"'; continue; + } + if (p + 3 <= endbuf && strncmp(p, "\\\\\"", 3) == 0) { + p += 3; *q++ = '\\'; inquote = 0; continue; + } + if (p + 2 <= endbuf && p[1] == '"') { + p += 2; *q++ = '"'; continue; + } + /* fallthrough */ + default: + *q++ = *p++; + } + } + } + /* Delimit argument and expand it */ + *q++ = 0; + expand_argument(s); + p++; + } +} + +CAMLexport void expand_command_line(int * argcp, char *** argvp) +{ + int i; + argc = 0; + argvsize = 16; + argv = (char **) malloc(argvsize * sizeof(char *)); + if (argv == NULL) out_of_memory(); + for (i = 0; i < *argcp; i++) expand_argument((*argvp)[i]); + argv[argc] = NULL; + *argcp = argc; + *argvp = argv; +} + +#endif + +/* Add to [contents] the (short) names of the files contained in + the directory named [dirname]. No entries are added for [.] and [..]. + Return 0 on success, -1 on error; set errno in the case of error. */ + +int caml_read_directory(char * dirname, struct ext_table * contents) +{ + char * template; + long h; + struct _finddata_t fileinfo; + char * p; + + template = stat_alloc(strlen(dirname) + 5); + strcpy(template, dirname); + strcat(template, "\\*.*"); + h = _findfirst(template, &fileinfo); + stat_free(template); + if (h == -1) return errno == ENOENT ? 0 : -1; + do { + if (strcmp(fileinfo.name, ".") != 0 && strcmp(fileinfo.name, "..") != 0) { + p = stat_alloc(strlen(fileinfo.name) + 1); + strcpy(p, fileinfo.name); + ext_table_add(contents, p); + } + } while (_findnext(h, &fileinfo) == 0); + _findclose(h); + return 0; +} + +#ifndef NATIVE_CODE + +/* Set up a new thread for control-C emulation and termination */ + +void caml_signal_thread(void * lpParam) +{ + char *endptr; + HANDLE h; + /* Get an hexa-code raw handle through the environment */ + h = (HANDLE) strtol(getenv("CAMLSIGPIPE"), &endptr, 16); + while (1) { + DWORD numread; + BOOL ret; + char iobuf[2]; + /* This shall always return a single character */ + ret = ReadFile(h, iobuf, 1, &numread, NULL); + if (!ret || numread != 1) sys_exit(Val_int(2)); + switch (iobuf[0]) { + case 'C': + pending_signal = SIGINT; + something_to_do = 1; + break; + case 'T': + raise(SIGTERM); + return; + } + } +} + +#endif diff --git a/camlp4/CHANGES b/camlp4/CHANGES new file mode 100644 index 00000000..038cc06b --- /dev/null +++ b/camlp4/CHANGES @@ -0,0 +1,751 @@ +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 new file mode 100644 index 00000000..bbb9eb14 --- /dev/null +++ b/camlp4/ICHANGES @@ -0,0 +1,17 @@ +Internal, very small, undocumented, or invisible changes +******************************************************** + +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 new file mode 100644 index 00000000..f0bbf29c --- /dev/null +++ b/camlp4/Makefile @@ -0,0 +1,190 @@ +# $Id: Makefile,v 1.20 2003/07/10 12:27:00 michel Exp $ + +include config/Makefile + +DIRS=odyl camlp4 meta etc top ocpp lib man +FDIRS=odyl camlp4 meta lib +OPTDIRS= lib odyl camlp4 meta 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 new file mode 100644 index 00000000..010895d3 --- /dev/null +++ b/camlp4/Makefile.Mac @@ -0,0 +1,204 @@ +####################################################################### +# # +# Camlp4 # +# # +# Damien Doligez, projet Para, INRIA Rocquencourt # +# # +# Copyright 1999 Institut National de Recherche en Informatique et # +# en Automatique. Distributed only by permission. # +# # +####################################################################### + +# $Id: Makefile.Mac,v 1.1 2001/12/13 13:59:22 doligez Exp $ + +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 new file mode 100644 index 00000000..85599a4b --- /dev/null +++ b/camlp4/boot/.cvsignore @@ -0,0 +1,5 @@ +*.cm[oia] +camlp4 +camlp4o +camlp4r +SAVED diff --git a/camlp4/camlp4/.cvsignore b/camlp4/camlp4/.cvsignore new file mode 100644 index 00000000..38b5e090 --- /dev/null +++ b/camlp4/camlp4/.cvsignore @@ -0,0 +1,6 @@ +*.cm[oia] +camlp4 +*.lib +crc.ml +extract_crc +phony diff --git a/camlp4/camlp4/.depend b/camlp4/camlp4/.depend new file mode 100644 index 00000000..bf820654 --- /dev/null +++ b/camlp4/camlp4/.depend @@ -0,0 +1,21 @@ +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 new file mode 100644 index 00000000..ccc6936f --- /dev/null +++ b/camlp4/camlp4/Makefile @@ -0,0 +1,71 @@ +# $Id: Makefile,v 1.17 2003/07/14 17:59:28 mauny Exp $ + +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 *.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 new file mode 100644 index 00000000..7e1b4e0c --- /dev/null +++ b/camlp4/camlp4/Makefile.Mac @@ -0,0 +1,69 @@ +####################################################################### +# # +# Camlp4 # +# # +# Damien Doligez, projet Para, INRIA Rocquencourt # +# # +# Copyright 1999 Institut National de Recherche en Informatique et # +# en Automatique. Distributed only by permission. # +# # +####################################################################### + +# $Id: Makefile.Mac,v 1.4 2003/07/10 12:28:14 michel Exp $ + +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 new file mode 100644 index 00000000..3665195f --- /dev/null +++ b/camlp4/camlp4/Makefile.Mac.depend @@ -0,0 +1,15 @@ +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 new file mode 100644 index 00000000..f822ff8e --- /dev/null +++ b/camlp4/camlp4/argl.ml @@ -0,0 +1,424 @@ +(* camlp4r q_MLast.cmo *) +(* $Id: argl.ml,v 1.12 2003/07/10 12:28:14 michel Exp $ *) + +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 new file mode 100644 index 00000000..01ffdfa3 --- /dev/null +++ b/camlp4/camlp4/ast2pt.ml @@ -0,0 +1,866 @@ +(* camlp4r *) +(***********************************************************************) +(* *) +(* Camlp4 *) +(* *) +(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 2002 Institut National de Recherche en Informatique et *) +(* Automatique. Distributed only by permission. *) +(* *) +(***********************************************************************) + +(* $Id: ast2pt.ml,v 1.25 2003/07/16 18:59:12 mauny Exp $ *) + +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 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 "labeled type not allowed here" + | TyLid loc s -> mktyp loc (Ptyp_constr (lident s) []) + | TyMan loc _ _ -> error loc "type manifest not allowed here" + | TyOlb loc lab _ -> error loc "labeled 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 new file mode 100644 index 00000000..a981dfaf --- /dev/null +++ b/camlp4/camlp4/ast2pt.mli @@ -0,0 +1,23 @@ +(* camlp4r *) +(***********************************************************************) +(* *) +(* Camlp4 *) +(* *) +(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 2002 Institut National de Recherche en Informatique et *) +(* Automatique. Distributed only by permission. *) +(* *) +(***********************************************************************) + +(* $Id: ast2pt.mli,v 1.3 2002/07/19 14:53:44 mauny Exp $ *) + +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 new file mode 100644 index 00000000..c783ef12 --- /dev/null +++ b/camlp4/camlp4/mLast.mli @@ -0,0 +1,211 @@ +(* camlp4r *) +(***********************************************************************) +(* *) +(* Camlp4 *) +(* *) +(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 2002 Institut National de Recherche en Informatique et *) +(* Automatique. Distributed only by permission. *) +(* *) +(***********************************************************************) + +(* $Id: mLast.mli,v 1.15 2003/07/16 12:50:07 mauny Exp $ *) + +(* 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 new file mode 100644 index 00000000..3420822c --- /dev/null +++ b/camlp4/camlp4/pcaml.ml @@ -0,0 +1,457 @@ +(* 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: pcaml.ml,v 1.12 2003/07/10 12:28:14 michel Exp $ *) + +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 new file mode 100644 index 00000000..53f5310c --- /dev/null +++ b/camlp4/camlp4/pcaml.mli @@ -0,0 +1,157 @@ +(* camlp4r *) +(***********************************************************************) +(* *) +(* Camlp4 *) +(* *) +(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 2001 Institut National de Recherche en Informatique et *) +(* Automatique. Distributed only by permission. *) +(* *) +(***********************************************************************) + +(* $Id: pcaml.mli,v 1.6 2003/07/10 12:28:15 michel Exp $ *) + +(** 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 new file mode 100644 index 00000000..4cb75451 --- /dev/null +++ b/camlp4/camlp4/quotation.ml @@ -0,0 +1,33 @@ +(* camlp4r *) +(***********************************************************************) +(* *) +(* Camlp4 *) +(* *) +(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 2002 Institut National de Recherche en Informatique et *) +(* Automatique. Distributed only by permission. *) +(* *) +(***********************************************************************) + +(* $Id: quotation.ml,v 1.3 2002/07/19 14:53:44 mauny Exp $ *) + +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 new file mode 100644 index 00000000..97c6ebde --- /dev/null +++ b/camlp4/camlp4/quotation.mli @@ -0,0 +1,48 @@ +(* 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.mli,v 1.2 2002/07/19 14:53:44 mauny Exp $ *) + +(** 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 new file mode 100644 index 00000000..6678a1af --- /dev/null +++ b/camlp4/camlp4/reloc.ml @@ -0,0 +1,289 @@ +(* camlp4r *) +(***********************************************************************) +(* *) +(* Camlp4 *) +(* *) +(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1998 Institut National de Recherche en Informatique et *) +(* Automatique. Distributed only by permission. *) +(* *) +(***********************************************************************) + +(* $Id: reloc.ml,v 1.14 2003/07/16 12:50:07 mauny Exp $ *) + +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 new file mode 100644 index 00000000..2abd2525 --- /dev/null +++ b/camlp4/camlp4/reloc.mli @@ -0,0 +1,16 @@ +(* camlp4r *) +(***********************************************************************) +(* *) +(* Camlp4 *) +(* *) +(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1998 Institut National de Recherche en Informatique et *) +(* Automatique. Distributed only by permission. *) +(* *) +(***********************************************************************) + +(* $Id: reloc.mli,v 1.2 2002/07/19 14:53:44 mauny Exp $ *) + +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 new file mode 100644 index 00000000..afa8fd9b --- /dev/null +++ b/camlp4/camlp4/spretty.ml @@ -0,0 +1,478 @@ +(* camlp4r *) +(***********************************************************************) +(* *) +(* Camlp4 *) +(* *) +(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 2002 Institut National de Recherche en Informatique et *) +(* Automatique. Distributed only by permission. *) +(* *) +(***********************************************************************) + +(* $Id: spretty.ml,v 1.2 2002/07/19 14:53:44 mauny Exp $ *) + +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 -> invalid_arg "hprint_pretty" + | 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 new file mode 100644 index 00000000..86ef8464 --- /dev/null +++ b/camlp4/camlp4/spretty.mli @@ -0,0 +1,54 @@ +(* camlp4r *) +(***********************************************************************) +(* *) +(* Camlp4 *) +(* *) +(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1998 Institut National de Recherche en Informatique et *) +(* Automatique. Distributed only by permission. *) +(* *) +(***********************************************************************) + +(* $Id: spretty.mli,v 1.2 2002/07/19 14:53:44 mauny Exp $ *) + +(* 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 new file mode 100644 index 00000000..47817cce --- /dev/null +++ b/camlp4/compile/.cvsignore @@ -0,0 +1,4 @@ +*.fast +*.fast.opt +o_fast.ml +pa_o_fast.ml diff --git a/camlp4/compile/.depend b/camlp4/compile/.depend new file mode 100644 index 00000000..707bed8f --- /dev/null +++ b/camlp4/compile/.depend @@ -0,0 +1,4 @@ +compile.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi +compile.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx +pa_o_fast.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi +pa_o_fast.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx diff --git a/camlp4/compile/Makefile b/camlp4/compile/Makefile new file mode 100644 index 00000000..ce167481 --- /dev/null +++ b/camlp4/compile/Makefile @@ -0,0 +1,45 @@ +# $Id: Makefile,v 1.7 2002/07/22 16:38:07 doligez Exp $ + +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; 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 new file mode 100644 index 00000000..b3e6dad0 --- /dev/null +++ b/camlp4/compile/comp_head.ml @@ -0,0 +1,70 @@ +(* camlp4r q_MLast.cmo pa_extend.cmo *) +(* $Id: comp_head.ml,v 1.3 2002/07/19 14:53:45 mauny Exp $ *) + +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 new file mode 100644 index 00000000..74c34b15 --- /dev/null +++ b/camlp4/compile/comp_trail.ml @@ -0,0 +1,33 @@ + +(****************************************) + +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 new file mode 100644 index 00000000..fd245d9e --- /dev/null +++ b/camlp4/compile/compile.ml @@ -0,0 +1,571 @@ +(* camlp4r *) +(* $Id: compile.ml,v 1.12 2003/07/10 12:28:15 michel Exp $ *) + +#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 new file mode 100755 index 00000000..780fea0c --- /dev/null +++ b/camlp4/compile/compile.sh @@ -0,0 +1,26 @@ +#!/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 +$OTOP/boot/ocamlrun$EXE ../camlp4/camlp4$EXE ./compile.cmo ./tmp.cmo ../etc/pr_r.cmo ../etc/pr_rp.cmo $ARGS -sep "\n\n" -impl /dev/null +rm tmp.* diff --git a/camlp4/config/.cvsignore b/camlp4/config/.cvsignore new file mode 100644 index 00000000..f9761cda --- /dev/null +++ b/camlp4/config/.cvsignore @@ -0,0 +1,2 @@ +Makefile.cnf +Makefile diff --git a/camlp4/config/Makefile-nt.cnf b/camlp4/config/Makefile-nt.cnf new file mode 100644 index 00000000..e69de29b diff --git a/camlp4/config/Makefile.tpl b/camlp4/config/Makefile.tpl new file mode 100644 index 00000000..f5798fa5 --- /dev/null +++ b/camlp4/config/Makefile.tpl @@ -0,0 +1,28 @@ +# $Id: Makefile.tpl,v 1.4 2001/09/09 08:22:46 ddr Exp $ + +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 new file mode 100644 index 00000000..62bad2ab --- /dev/null +++ b/camlp4/config/config.mpw @@ -0,0 +1,50 @@ +####################################################################### +# # +# Camlp4 # +# # +# Damien Doligez, projet Para, INRIA Rocquencourt # +# # +# Copyright 1999 Institut National de Recherche en Informatique et # +# en Automatique. Distributed only by permission. # +# # +####################################################################### + +# $Id: config.mpw,v 1.1 2001/12/13 13:59:23 doligez Exp $ + +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 new file mode 100755 index 00000000..f7df2e0e --- /dev/null +++ b/camlp4/config/configure_batch @@ -0,0 +1,111 @@ +#! /bin/sh +# $Id: configure_batch,v 1.4 2002/07/23 14:11:49 doligez Exp $ + +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 "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 new file mode 100644 index 00000000..92c764ca --- /dev/null +++ b/camlp4/etc/.cvsignore @@ -0,0 +1,6 @@ +*.cm[oia] +camlp4o +camlp4sch +camlp4o.opt +mkcamlp4.sh +mkcamlp4.mpw diff --git a/camlp4/etc/.depend b/camlp4/etc/.depend new file mode 100644 index 00000000..50e140c7 --- /dev/null +++ b/camlp4/etc/.depend @@ -0,0 +1,67 @@ +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_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_o.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi +pa_o.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx +pa_ocamllex.cmo: $(OTOP)/lex/compact.cmi $(OTOP)/lex/cset.cmi \ + $(OTOP)/lex/lexgen.cmi ../camlp4/mLast.cmi ../camlp4/pcaml.cmi \ + $(OTOP)/lex/syntax.cmi +pa_ocamllex.cmx: $(OTOP)/lex/compact.cmx $(OTOP)/lex/cset.cmx \ + $(OTOP)/lex/lexgen.cmx ../camlp4/mLast.cmi ../camlp4/pcaml.cmx \ + $(OTOP)/lex/syntax.cmx +pa_olabl.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi +pa_olabl.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx +pa_oop.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi +pa_oop.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx +pa_op.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi +pa_op.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx +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_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_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 new file mode 100644 index 00000000..2855ccba --- /dev/null +++ b/camlp4/etc/Makefile @@ -0,0 +1,99 @@ +# $Id: Makefile,v 1.14 2003/07/15 09:34:47 mauny Exp $ + +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=pa_o.cmx pa_op.cmx ../meta/pr_dump.cmx +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 $@ + +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)/."; 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 new file mode 100644 index 00000000..7e567cfb --- /dev/null +++ b/camlp4/etc/Makefile.Mac @@ -0,0 +1,71 @@ +####################################################################### +# # +# Camlp4 # +# # +# Damien Doligez, projet Para, INRIA Rocquencourt # +# # +# Copyright 1999 Institut National de Recherche en Informatique et # +# en Automatique. Distributed only by permission. # +# # +####################################################################### + +# $Id: Makefile.Mac,v 1.2 2002/07/19 14:53:45 mauny Exp $ + +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 new file mode 100644 index 00000000..c8007dcb --- /dev/null +++ b/camlp4/etc/Makefile.Mac.depend @@ -0,0 +1,40 @@ +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 new file mode 100644 index 00000000..5c8555bb --- /dev/null +++ b/camlp4/etc/lib.sml @@ -0,0 +1,384 @@ +(* $Id: lib.sml,v 1.2 2002/07/19 14:53:45 mauny Exp $ *) + +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 new file mode 100644 index 00000000..9877ff2c --- /dev/null +++ b/camlp4/etc/mkcamlp4.mpw.tpl @@ -0,0 +1,33 @@ +####################################################################### +# # +# Camlp4 # +# # +# Damien Doligez, projet Para, INRIA Rocquencourt # +# # +# Copyright 1999 Institut National de Recherche en Informatique et # +# en Automatique. Distributed only by permission. # +# # +####################################################################### + +# $Id: mkcamlp4.mpw.tpl,v 1.2 2003/07/10 12:28:18 michel Exp $ + +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 new file mode 100755 index 00000000..feb825e7 --- /dev/null +++ b/camlp4/etc/mkcamlp4.sh.tpl @@ -0,0 +1,24 @@ +#!/bin/sh +# $Id: mkcamlp4.sh.tpl,v 1.5 2003/07/10 12:28:19 michel Exp $ + +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 diff --git a/camlp4/etc/pa_extfold.ml b/camlp4/etc/pa_extfold.ml new file mode 100644 index 00000000..7c160fdc --- /dev/null +++ b/camlp4/etc/pa_extfold.ml @@ -0,0 +1,42 @@ +(* camlp4r pa_extend.cmo q_MLast.cmo *) +(* $Id: pa_extfold.ml,v 1.1 2002/07/19 14:53:45 mauny Exp $ *) + +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 new file mode 100644 index 00000000..331a09b3 --- /dev/null +++ b/camlp4/etc/pa_extfun.ml @@ -0,0 +1,123 @@ +(* camlp4r q_MLast.cmo pa_extend.cmo *) +(* $Id: pa_extfun.ml,v 1.2 2002/07/19 14:53:45 mauny Exp $ *) + +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 new file mode 100644 index 00000000..776e4ba8 --- /dev/null +++ b/camlp4/etc/pa_format.ml @@ -0,0 +1,39 @@ +(* camlp4r pa_extend.cmo q_MLast.cmo *) +(* $Id: pa_format.ml,v 1.2 2002/07/19 14:53:45 mauny Exp $ *) + +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 new file mode 100644 index 00000000..11373f38 --- /dev/null +++ b/camlp4/etc/pa_fstream.ml @@ -0,0 +1,163 @@ +(* camlp4r pa_extend.cmo q_MLast.cmo *) +(* $Id: pa_fstream.ml,v 1.3 2002/07/19 14:53:45 mauny Exp $ *) + +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 new file mode 100644 index 00000000..b43d1ed1 --- /dev/null +++ b/camlp4/etc/pa_ifdef.ml @@ -0,0 +1,87 @@ +(* camlp4r pa_extend.cmo q_MLast.cmo *) +(* $Id: pa_ifdef.ml,v 1.1 2003/07/10 12:28:19 michel Exp $ *) + +(* 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 new file mode 100644 index 00000000..533a58f8 --- /dev/null +++ b/camlp4/etc/pa_lefteval.ml @@ -0,0 +1,239 @@ +(* 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: pa_lefteval.ml,v 1.2 2003/07/10 12:28:20 michel Exp $ *) + +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 new file mode 100644 index 00000000..5dc914f2 --- /dev/null +++ b/camlp4/etc/pa_lisp.ml @@ -0,0 +1,684 @@ +;; camlp4 ./pa_lispr.cmo pa_extend.cmo q_MLast.cmo pr_dump.cmo +;; $Id: pa_lisp.ml,v 1.11 2003/07/10 12:28:20 michel Exp $ + +(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 new file mode 100644 index 00000000..fb150e20 --- /dev/null +++ b/camlp4/etc/pa_lispr.ml @@ -0,0 +1,665 @@ +(* 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 new file mode 100644 index 00000000..353f7fa9 --- /dev/null +++ b/camlp4/etc/pa_o.ml @@ -0,0 +1,1275 @@ +(* 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: pa_o.ml,v 1.50 2003/07/16 18:59:26 mauny Exp $ *) + +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 = labeled_patt; "->"; ce = class_expr -> + <:class_expr< fun $p$ -> $ce$ >> + | 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: AFTER "arrow" + [ NONA + [ i = lident_colon; t = SELF -> <:ctyp< ~ $i$ : $t$ >> + | i = QUESTIONIDENT; ":"; t = SELF -> <:ctyp< ? $i$ : $t$ >> ] ] + ; + 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 = TILDEIDENT; ":"; e = SELF -> <:expr< ~ $i$ : $e$ >> + | i = TILDEIDENT -> <:expr< ~ $i$ >> + | i = QUESTIONIDENT; ":"; e = SELF -> <:expr< ? $i$ : $e$ >> + | i = QUESTIONIDENT -> <: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 = TILDEIDENT; ":"; p = patt LEVEL "simple" -> + <:patt< ~ $i$ : $p$ >> + | i = TILDEIDENT -> + <:patt< ~ $i$ >> + | "~"; "("; i = LIDENT; ")" -> + <:patt< ~ $i$ >> + | "~"; "("; i = LIDENT; ":"; t = ctyp; ")" -> + <:patt< ~ $i$ : ($lid:i$ : $t$) >> + | i = QUESTIONIDENT; ":"; j = LIDENT -> + <:patt< ? $i$ : ($lid:j$) >> + | i = QUESTIONIDENT; ":"; "("; p = patt; "="; e = expr; ")" -> + <:patt< ? $i$ : ( $p$ = $e$ ) >> + | i = QUESTIONIDENT; ":"; "("; p = patt; ":"; t = ctyp; ")" -> + <:patt< ? $i$ : ( $p$ : $t$ ) >> + | i = QUESTIONIDENT; ":"; "("; p = patt; ":"; t = ctyp; "="; + e = expr; ")" -> + <:patt< ? $i$ : ( $p$ : $t$ = $e$ ) >> + | i = QUESTIONIDENT -> <: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 "ctyp1"; "->"; ct = SELF -> + <:class_type< [ ~ $i$ : $t$ ] -> $ct$ >> + | i = QUESTIONIDENT; ":"; t = ctyp LEVEL "ctyp1"; "->"; 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 new file mode 100644 index 00000000..f7b327de --- /dev/null +++ b/camlp4/etc/pa_ocamllex.ml @@ -0,0 +1,344 @@ +(* camlp4 ./pa_o.cmo q_MLast.cmo pa_extend.cmo pr_dump.cmo *) +(* $Id: pa_ocamllex.ml,v 1.9 2002/12/09 10:44:45 maranget Exp $ *) +(* 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 new file mode 100644 index 00000000..ac685269 --- /dev/null +++ b/camlp4/etc/pa_olabl.ml @@ -0,0 +1,2005 @@ +(* 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: pa_olabl.ml,v 1.20 2003/07/10 12:28:20 michel Exp $ *) + +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 new file mode 100644 index 00000000..3780ab52 --- /dev/null +++ b/camlp4/etc/pa_oop.ml @@ -0,0 +1,154 @@ +(* 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: pa_oop.ml,v 1.3 2002/07/19 14:53:46 mauny Exp $ *) + +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 new file mode 100644 index 00000000..34ad9b20 --- /dev/null +++ b/camlp4/etc/pa_op.ml @@ -0,0 +1,330 @@ +(* 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: pa_op.ml,v 1.6 2003/07/10 12:28:21 michel Exp $ *) + +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 new file mode 100644 index 00000000..d132b38b --- /dev/null +++ b/camlp4/etc/pa_ru.ml @@ -0,0 +1,46 @@ +(* 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: pa_ru.ml,v 1.7 2003/07/10 12:28:21 michel Exp $ *) + +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 new file mode 100644 index 00000000..62c211de --- /dev/null +++ b/camlp4/etc/pa_scheme.ml @@ -0,0 +1,1002 @@ +; camlp4 ./pa_schemer.cmo pa_extend.cmo q_MLast.cmo pr_dump.cmo +; $Id: pa_scheme.ml,v 1.1 2003/07/10 12:28:21 michel Exp $ + +(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 new file mode 100644 index 00000000..a7d64ce4 --- /dev/null +++ b/camlp4/etc/pa_schemer.ml @@ -0,0 +1,1067 @@ +(* 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 new file mode 100644 index 00000000..287d76ab --- /dev/null +++ b/camlp4/etc/pa_sml.ml @@ -0,0 +1,947 @@ +(* 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: pa_sml.ml,v 1.10 2003/07/10 12:28:21 michel Exp $ *) + +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 new file mode 100644 index 00000000..19260cde --- /dev/null +++ b/camlp4/etc/parserify.ml @@ -0,0 +1,301 @@ +(* camlp4r q_MLast.cmo *) +(* $Id: parserify.ml,v 1.1 2003/07/10 12:28:22 michel Exp $ *) + +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 new file mode 100644 index 00000000..704a2467 --- /dev/null +++ b/camlp4/etc/parserify.mli @@ -0,0 +1,12 @@ +(* camlp4r *) +(* $Id: parserify.mli,v 1.1 2003/07/10 12:28:22 michel Exp $ *) + +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 new file mode 100644 index 00000000..9b9ecd25 --- /dev/null +++ b/camlp4/etc/pr_depend.ml @@ -0,0 +1,322 @@ +(* camlp4r *) +(* $Id: pr_depend.ml,v 1.12 2003/07/16 12:50:08 mauny Exp $ *) + +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 + | 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 _ _ -> () + | 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 new file mode 100644 index 00000000..e19c8a17 --- /dev/null +++ b/camlp4/etc/pr_extend.ml @@ -0,0 +1,514 @@ +(* 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: pr_extend.ml,v 1.12 2002/07/19 14:53:46 mauny Exp $ *) + +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 new file mode 100644 index 00000000..9fafd20e --- /dev/null +++ b/camlp4/etc/pr_extfun.ml @@ -0,0 +1,92 @@ +(* camlp4r q_MLast.cmo ./pa_extfun.cmo *) +(* $Id: pr_extfun.ml,v 1.2 2002/07/19 14:53:46 mauny Exp $ *) + +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 new file mode 100644 index 00000000..e8ed06a7 --- /dev/null +++ b/camlp4/etc/pr_null.ml @@ -0,0 +1,16 @@ +(* camlp4r *) +(***********************************************************************) +(* *) +(* Camlp4 *) +(* *) +(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1998 Institut National de Recherche en Informatique et *) +(* Automatique. Distributed only by permission. *) +(* *) +(***********************************************************************) + +(* $Id: pr_null.ml,v 1.2 2002/07/19 14:53:46 mauny Exp $ *) + +Pcaml.print_interf.val := fun _ -> (); +Pcaml.print_implem.val := fun _ -> (); diff --git a/camlp4/etc/pr_o.ml b/camlp4/etc/pr_o.ml new file mode 100644 index 00000000..2a4dc5ac --- /dev/null +++ b/camlp4/etc/pr_o.ml @@ -0,0 +1,2060 @@ +(* 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: pr_o.ml,v 1.41 2003/07/16 12:50:08 mauny Exp $ *) + +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$ : ($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 new file mode 100644 index 00000000..13241e7c --- /dev/null +++ b/camlp4/etc/pr_op.ml @@ -0,0 +1,503 @@ +(* 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: pr_op.ml,v 1.4 2002/07/19 14:53:47 mauny Exp $ *) + +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 new file mode 100644 index 00000000..356aeee1 --- /dev/null +++ b/camlp4/etc/pr_op_main.ml @@ -0,0 +1,214 @@ +(* 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: pr_op_main.ml,v 1.1 2003/07/10 12:28:22 michel Exp $ *) + +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 new file mode 100644 index 00000000..8df612c9 --- /dev/null +++ b/camlp4/etc/pr_r.ml @@ -0,0 +1,1898 @@ +(* 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: pr_r.ml,v 1.46 2003/07/16 12:50:08 mauny Exp $ *) + +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 new file mode 100644 index 00000000..02daa6af --- /dev/null +++ b/camlp4/etc/pr_rp.ml @@ -0,0 +1,504 @@ +(* 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: pr_rp.ml,v 1.4 2002/07/19 14:53:47 mauny Exp $ *) + +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 new file mode 100644 index 00000000..38d25864 --- /dev/null +++ b/camlp4/etc/pr_rp_main.ml @@ -0,0 +1,206 @@ +(* 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: pr_rp_main.ml,v 1.1 2003/07/10 12:28:23 michel Exp $ *) + +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 new file mode 100644 index 00000000..3851d454 --- /dev/null +++ b/camlp4/etc/pr_scheme.ml @@ -0,0 +1,813 @@ +(* camlp4r q_MLast.cmo ./pa_extfun.cmo *) +(* $Id: pr_scheme.ml,v 1.1 2003/07/10 12:28:23 michel Exp $ *) + +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 new file mode 100644 index 00000000..30766e77 --- /dev/null +++ b/camlp4/etc/pr_schp_main.ml @@ -0,0 +1,119 @@ +(* camlp4r q_MLast.cmo ./pa_extfun.cmo *) +(* $Id: pr_schp_main.ml,v 1.1 2003/07/10 12:28:23 michel Exp $ *) + +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 new file mode 100644 index 00000000..2481c7fc --- /dev/null +++ b/camlp4/etc/q_phony.ml @@ -0,0 +1,49 @@ +(* 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: q_phony.ml,v 1.3 2003/07/10 12:28:24 michel Exp $ *) + +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 new file mode 100644 index 00000000..c77a681d --- /dev/null +++ b/camlp4/lib/.cvsignore @@ -0,0 +1,3 @@ +*.cm[oiax] +*.cmxa +*.lib diff --git a/camlp4/lib/.depend b/camlp4/lib/.depend new file mode 100644 index 00000000..0d5adc69 --- /dev/null +++ b/camlp4/lib/.depend @@ -0,0 +1,20 @@ +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 new file mode 100644 index 00000000..3ce2ee11 --- /dev/null +++ b/camlp4/lib/Makefile @@ -0,0 +1,52 @@ +# $Id: Makefile,v 1.6 2003/07/10 12:28:24 michel Exp $ + +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/." + if test -f $(TARGET:.cma=.lib); then \ + cp $(TARGET:.cma=.lib) "$(LIBDIR)/camlp4/."; \ + else \ + tar cf - $(TARGET:.cma=.a) | (cd "$(LIBDIR)/camlp4/."; tar xf -); \ + fi + +include .depend diff --git a/camlp4/lib/Makefile.Mac b/camlp4/lib/Makefile.Mac new file mode 100644 index 00000000..1b27c216 --- /dev/null +++ b/camlp4/lib/Makefile.Mac @@ -0,0 +1,46 @@ +####################################################################### +# # +# Camlp4 # +# # +# Damien Doligez, projet Para, INRIA Rocquencourt # +# # +# Copyright 1999 Institut National de Recherche en Informatique et # +# en Automatique. Distributed only by permission. # +# # +####################################################################### + +# $Id: Makefile.Mac,v 1.2 2002/07/19 14:53:47 mauny Exp $ + +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 new file mode 100644 index 00000000..8d12e3e0 --- /dev/null +++ b/camlp4/lib/Makefile.Mac.depend @@ -0,0 +1,13 @@ +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 new file mode 100644 index 00000000..3c48299b --- /dev/null +++ b/camlp4/lib/extfold.ml @@ -0,0 +1,91 @@ +(* camlp4r *) +(* $Id: extfold.ml,v 1.1 2002/07/19 14:53:47 mauny Exp $ *) + +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 new file mode 100644 index 00000000..c183fe03 --- /dev/null +++ b/camlp4/lib/extfold.mli @@ -0,0 +1,24 @@ +(* camlp4r *) +(* $Id: extfold.mli,v 1.1 2002/07/19 14:53:47 mauny Exp $ *) + +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 new file mode 100644 index 00000000..6c17b50d --- /dev/null +++ b/camlp4/lib/extfun.ml @@ -0,0 +1,109 @@ +(* camlp4r *) +(* $Id: extfun.ml,v 1.3 2003/07/10 12:28:24 michel Exp $ *) +(* 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 new file mode 100644 index 00000000..c66e99cd --- /dev/null +++ b/camlp4/lib/extfun.mli @@ -0,0 +1,36 @@ +(* camlp4r *) +(* $Id: extfun.mli,v 1.2 2002/07/19 14:53:48 mauny Exp $ *) + +(** 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 new file mode 100644 index 00000000..30a72ef4 --- /dev/null +++ b/camlp4/lib/fstream.ml @@ -0,0 +1,77 @@ +(* camlp4r *) +(* $Id: fstream.ml,v 1.5 2003/07/10 12:28:24 michel Exp $ *) +(* 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 new file mode 100644 index 00000000..1ec3e57f --- /dev/null +++ b/camlp4/lib/fstream.mli @@ -0,0 +1,60 @@ +(* camlp4r *) +(* $Id: fstream.mli,v 1.3 2002/07/19 14:53:48 mauny Exp $ *) + +(* 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 new file mode 100644 index 00000000..a7af21db --- /dev/null +++ b/camlp4/lib/gramext.ml @@ -0,0 +1,565 @@ +(* camlp4r *) +(***********************************************************************) +(* *) +(* Camlp4 *) +(* *) +(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 2002 Institut National de Recherche en Informatique et *) +(* Automatique. Distributed only by permission. *) +(* *) +(***********************************************************************) + +(* $Id: gramext.ml,v 1.4 2002/07/19 14:53:48 mauny Exp $ *) + +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 new file mode 100644 index 00000000..f01ba636 --- /dev/null +++ b/camlp4/lib/gramext.mli @@ -0,0 +1,81 @@ +(* camlp4r *) +(***********************************************************************) +(* *) +(* Camlp4 *) +(* *) +(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 2002 Institut National de Recherche en Informatique et *) +(* Automatique. Distributed only by permission. *) +(* *) +(***********************************************************************) + +(* $Id: gramext.mli,v 1.3 2002/07/19 14:53:48 mauny Exp $ *) + +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 new file mode 100644 index 00000000..dc88dbce --- /dev/null +++ b/camlp4/lib/grammar.ml @@ -0,0 +1,1064 @@ +(* camlp4r *) +(***********************************************************************) +(* *) +(* Camlp4 *) +(* *) +(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 2002 Institut National de Recherche en Informatique et *) +(* Automatique. Distributed only by permission. *) +(* *) +(***********************************************************************) + +(* $Id: grammar.ml,v 1.11 2003/07/10 12:28:25 michel Exp $ *) + +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 new file mode 100644 index 00000000..b363d333 --- /dev/null +++ b/camlp4/lib/grammar.mli @@ -0,0 +1,209 @@ +(* camlp4r *) +(***********************************************************************) +(* *) +(* Camlp4 *) +(* *) +(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 2002 Institut National de Recherche en Informatique et *) +(* Automatique. Distributed only by permission. *) +(* *) +(***********************************************************************) + +(* $Id: grammar.mli,v 1.5 2003/07/10 12:28:25 michel Exp $ *) + +(** 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 new file mode 100644 index 00000000..9a337483 --- /dev/null +++ b/camlp4/lib/plexer.ml @@ -0,0 +1,993 @@ +(* camlp4r *) +(***********************************************************************) +(* *) +(* Camlp4 *) +(* *) +(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 2002 Institut National de Recherche en Informatique et *) +(* Automatique. Distributed only by permission. *) +(* *) +(***********************************************************************) + +(* $Id: plexer.ml,v 1.15 2003/07/15 09:13:58 mauny Exp $ *) + +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 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) :] 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 + | [: `'\\'; 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 ] + | "TILDEIDENT" | "QUESTIONIDENT" | "INT" | "INT32" | "INT64" | "NATIVEINT" + | "FLOAT" | "CHAR" | "STRING" | + "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 new file mode 100644 index 00000000..74106bb7 --- /dev/null +++ b/camlp4/lib/plexer.mli @@ -0,0 +1,72 @@ +(* camlp4r *) +(***********************************************************************) +(* *) +(* Camlp4 *) +(* *) +(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 2002 Institut National de Recherche en Informatique et *) +(* Automatique. Distributed only by permission. *) +(* *) +(***********************************************************************) + +(* $Id: plexer.mli,v 1.7 2003/07/15 09:13:58 mauny Exp $ *) + +(** 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 new file mode 100644 index 00000000..c8d7c6a3 --- /dev/null +++ b/camlp4/lib/stdpp.ml @@ -0,0 +1,79 @@ +(* camlp4r *) +(***********************************************************************) +(* *) +(* Camlp4 *) +(* *) +(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 2002 Institut National de Recherche en Informatique et *) +(* Automatique. Distributed only by permission. *) +(* *) +(***********************************************************************) + +(* $Id: stdpp.ml,v 1.4 2003/07/10 12:28:25 michel Exp $ *) + +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 new file mode 100644 index 00000000..1a4490b8 --- /dev/null +++ b/camlp4/lib/stdpp.mli @@ -0,0 +1,37 @@ +(* camlp4r *) +(***********************************************************************) +(* *) +(* Camlp4 *) +(* *) +(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 2002 Institut National de Recherche en Informatique et *) +(* Automatique. Distributed only by permission. *) +(* *) +(***********************************************************************) + +(* $Id: stdpp.mli,v 1.4 2003/07/10 12:28:25 michel Exp $ *) + +(** 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 new file mode 100644 index 00000000..ecb56d86 --- /dev/null +++ b/camlp4/lib/token.ml @@ -0,0 +1,225 @@ +(* camlp4r *) +(***********************************************************************) +(* *) +(* Camlp4 *) +(* *) +(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 2001 Institut National de Recherche en Informatique et *) +(* Automatique. Distributed only by permission. *) +(* *) +(***********************************************************************) + +(* $Id: token.ml,v 1.8 2003/07/10 12:28:25 michel Exp $ *) + +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 ('\\', i - 1) + else + match s.[i] with + [ '0'..'9' as c -> backslash2 (10 * cod + valch c) s (i + 1) + | _ -> ('\\', i - 1) ] +and backslash2 cod s i = + if i = String.length s then ('\\', i - 2) + else + match s.[i] with + [ '0'..'9' as c -> (Char.chr (10 * cod + valch c), i + 1) + | _ -> ('\\', i - 2) ] +and backslash1h s i = + if i = String.length s then ('\\', i - 1) + 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) + | _ -> ('\\', i - 1) ] +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) + | _ -> ('\\', i - 2) ] +; + +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 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 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 new file mode 100644 index 00000000..9402a000 --- /dev/null +++ b/camlp4/lib/token.mli @@ -0,0 +1,128 @@ +(* camlp4r *) +(***********************************************************************) +(* *) +(* Camlp4 *) +(* *) +(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 2001 Institut National de Recherche en Informatique et *) +(* Automatique. Distributed only by permission. *) +(* *) +(***********************************************************************) + +(* $Id: token.mli,v 1.4 2003/07/10 12:28:25 michel Exp $ *) + +(** 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; +value eval_string : string -> string; + (** Convert a char or a string token, where the backslashes had not + been interpreted into a real char or string; raise [Failure] if + bad backslash sequence found; [Token.eval_char (Char.escaped c)] + returns [c] and [Token.eval_string (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 new file mode 100644 index 00000000..2dc933cb --- /dev/null +++ b/camlp4/man/.cvsignore @@ -0,0 +1,2 @@ +camlp4.1 +camlp4.help diff --git a/camlp4/man/Makefile b/camlp4/man/Makefile new file mode 100644 index 00000000..7a49883a --- /dev/null +++ b/camlp4/man/Makefile @@ -0,0 +1,28 @@ +# $Id: Makefile,v 1.6 2003/07/03 16:14:49 xleroy Exp $ + +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 new file mode 100644 index 00000000..39a82bce --- /dev/null +++ b/camlp4/man/Makefile.Mac @@ -0,0 +1,31 @@ +####################################################################### +# # +# Camlp4 # +# # +# Damien Doligez, projet Para, INRIA Rocquencourt # +# # +# Copyright 1999 Institut National de Recherche en Informatique et # +# en Automatique. Distributed only by permission. # +# # +####################################################################### + +# $Id: Makefile.Mac,v 1.1 2001/12/13 13:59:23 doligez Exp $ + +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 new file mode 100644 index 00000000..b40b5f9f --- /dev/null +++ b/camlp4/man/camlp4.1.tpl @@ -0,0 +1,302 @@ +.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 new file mode 100644 index 00000000..8b137891 --- /dev/null +++ b/camlp4/man/camlp4.help.tpl @@ -0,0 +1 @@ + diff --git a/camlp4/meta/.cvsignore b/camlp4/meta/.cvsignore new file mode 100644 index 00000000..460c5a60 --- /dev/null +++ b/camlp4/meta/.cvsignore @@ -0,0 +1,3 @@ +*.cm[oia] +camlp4r +camlp4r.opt diff --git a/camlp4/meta/.depend b/camlp4/meta/.depend new file mode 100644 index 00000000..8f5e0cff --- /dev/null +++ b/camlp4/meta/.depend @@ -0,0 +1,14 @@ +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_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 new file mode 100644 index 00000000..ece02752 --- /dev/null +++ b/camlp4/meta/Makefile @@ -0,0 +1,59 @@ +# $Id: Makefile,v 1.12 2003/07/15 09:33:19 mauny Exp $ + +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=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)/." ;\ + 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 new file mode 100644 index 00000000..ee4cd4f8 --- /dev/null +++ b/camlp4/meta/Makefile.Mac @@ -0,0 +1,50 @@ +####################################################################### +# # +# Camlp4 # +# # +# Damien Doligez, projet Para, INRIA Rocquencourt # +# # +# Copyright 1999 Institut National de Recherche en Informatique et # +# en Automatique. Distributed only by permission. # +# # +####################################################################### + +# $Id: Makefile.Mac,v 1.3 2002/07/19 14:53:49 mauny Exp $ + +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 new file mode 100644 index 00000000..29675238 --- /dev/null +++ b/camlp4/meta/Makefile.Mac.depend @@ -0,0 +1,12 @@ +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 new file mode 100755 index 00000000..a04c91f0 --- /dev/null +++ b/camlp4/meta/mk_q_MLast.sh @@ -0,0 +1,12 @@ +#!/bin/sh +# $Id: mk_q_MLast.sh,v 1.3 2002/02/06 04:36:36 ddr Exp $ + +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 new file mode 100644 index 00000000..ab33cad4 --- /dev/null +++ b/camlp4/meta/pa_extend.ml @@ -0,0 +1,916 @@ +(* 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: pa_extend.ml,v 1.32 2003/07/10 12:28:26 michel Exp $ *) + +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 new file mode 100644 index 00000000..dcb51760 --- /dev/null +++ b/camlp4/meta/pa_extend_m.ml @@ -0,0 +1,26 @@ +(* 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: pa_extend_m.ml,v 1.8 2002/07/19 14:53:50 mauny Exp $ *) + +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 new file mode 100644 index 00000000..980c85af --- /dev/null +++ b/camlp4/meta/pa_ifdef.ml @@ -0,0 +1,85 @@ +(* camlp4r pa_extend.cmo q_MLast.cmo *) +(* $Id: pa_ifdef.ml,v 1.5 2002/07/19 14:53:50 mauny Exp $ *) + +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 new file mode 100644 index 00000000..4f5dd823 --- /dev/null +++ b/camlp4/meta/pa_macro.ml @@ -0,0 +1,251 @@ +(* camlp4r *) +(* $Id: pa_macro.ml,v 1.1 2003/07/10 12:28:27 michel Exp $ *) + +(* +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 new file mode 100644 index 00000000..7f368fa9 --- /dev/null +++ b/camlp4/meta/pa_r.ml @@ -0,0 +1,936 @@ +(* 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: pa_r.ml,v 1.52 2003/07/16 12:50:08 mauny Exp $ *) + +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$ >> ] + | 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] ] ] + ; + (* Labels *) + ctyp: AFTER "arrow" + [ NONA + [ i = TILDEIDENT; ":"; t = SELF -> <:ctyp< ~ $i$ : $t$ >> + | i = QUESTIONIDENT; ":"; t = SELF -> <:ctyp< ? $i$ : $t$ >> ] ] + ; + 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 = TILDEIDENT -> <:patt< ~ $i$ >> + | i = QUESTIONIDENT; ":"; "("; 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 = TILDEIDENT -> <:patt< ~ $i$ >> + | i = QUESTIONIDENT; ":"; "("; 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 = TILDEIDENT -> <:expr< ~ $i$ >> + | i = QUESTIONIDENT; ":"; 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 new file mode 100644 index 00000000..c0a7d6f5 --- /dev/null +++ b/camlp4/meta/pa_rp.ml @@ -0,0 +1,318 @@ +(* 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: pa_rp.ml,v 1.7 2003/07/10 12:28:27 michel Exp $ *) + +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 new file mode 100644 index 00000000..d9623260 --- /dev/null +++ b/camlp4/meta/pr_dump.ml @@ -0,0 +1,52 @@ +(* camlp4r *) +(***********************************************************************) +(* *) +(* Camlp4 *) +(* *) +(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 2001 Institut National de Recherche en Informatique et *) +(* Automatique. Distributed only by permission. *) +(* *) +(***********************************************************************) + +(* $Id: pr_dump.ml,v 1.4 2003/07/10 12:28:27 michel Exp $ *) + +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 new file mode 100644 index 00000000..5f98d871 --- /dev/null +++ b/camlp4/meta/q_MLast.ml @@ -0,0 +1,1479 @@ +(* 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: q_MLast.ml,v 1.51 2003/07/16 12:50:08 mauny Exp $ *) + +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_QUESTIONIDENT = Grammar.Entry.create gram "a_QUESTIONIDENT"; + +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] ] + | 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] ] ] + ; + (* Labels *) + ctyp: AFTER "arrow" + [ NONA + [ i = a_TILDEIDENT; ":"; t = SELF -> Qast.Node "TyLab" [Qast.Loc; i; t] + | i = a_QUESTIONIDENT; ":"; t = SELF -> + Qast.Node "TyOlb" [Qast.Loc; i; t] ] ] + ; + 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_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_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_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_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_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_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_QUESTIONIDENT: + [ [ "?"; a = ANTIQUOT -> antiquot "" loc a + | s = QUESTIONIDENT -> 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 new file mode 100644 index 00000000..2551b024 --- /dev/null +++ b/camlp4/ocaml_src/.cvsignore @@ -0,0 +1 @@ +SAVED diff --git a/camlp4/ocaml_src/camlp4/.cvsignore b/camlp4/ocaml_src/camlp4/.cvsignore new file mode 100644 index 00000000..eb4bb86b --- /dev/null +++ b/camlp4/ocaml_src/camlp4/.cvsignore @@ -0,0 +1,3 @@ +camlp4 +crc.ml +extract_crc diff --git a/camlp4/ocaml_src/camlp4/.depend b/camlp4/ocaml_src/camlp4/.depend new file mode 100644 index 00000000..bf820654 --- /dev/null +++ b/camlp4/ocaml_src/camlp4/.depend @@ -0,0 +1,21 @@ +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 new file mode 100644 index 00000000..79ef816b --- /dev/null +++ b/camlp4/ocaml_src/camlp4/Makefile @@ -0,0 +1,71 @@ +# 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 *.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 new file mode 100644 index 00000000..b7561d8c --- /dev/null +++ b/camlp4/ocaml_src/camlp4/Makefile.Mac @@ -0,0 +1,69 @@ +####################################################################### +# # +# 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 new file mode 100644 index 00000000..3665195f --- /dev/null +++ b/camlp4/ocaml_src/camlp4/Makefile.Mac.depend @@ -0,0 +1,15 @@ +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 new file mode 100644 index 00000000..0f6ac98c --- /dev/null +++ b/camlp4/ocaml_src/camlp4/argl.ml @@ -0,0 +1,406 @@ +(* 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 new file mode 100644 index 00000000..781f7dd5 --- /dev/null +++ b/camlp4/ocaml_src/camlp4/ast2pt.ml @@ -0,0 +1,840 @@ +(* camlp4r *) +(***********************************************************************) +(* *) +(* Camlp4 *) +(* *) +(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 2002 Institut National de Recherche en Informatique et *) +(* Automatique. Distributed only by permission. *) +(* *) +(***********************************************************************) + +(* $Id: ast2pt.ml,v 1.23 2003/07/16 12:50:09 mauny Exp $ *) + +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 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 "labeled type not allowed here" + | TyLid (loc, s) -> mktyp loc (Ptyp_constr (lident s, [])) + | TyMan (loc, _, _) -> error loc "type manifest not allowed here" + | TyOlb (loc, lab, _) -> error loc "labeled 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) -> + List.fold_right + (fun (n, mt) l -> mksig loc (Psig_module (n, module_type mt)) :: l) + 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 new file mode 100644 index 00000000..d64fb6e3 --- /dev/null +++ b/camlp4/ocaml_src/camlp4/ast2pt.mli @@ -0,0 +1,23 @@ +(* 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 new file mode 100644 index 00000000..518d11b9 --- /dev/null +++ b/camlp4/ocaml_src/camlp4/mLast.mli @@ -0,0 +1,208 @@ +(* camlp4r *) +(***********************************************************************) +(* *) +(* Camlp4 *) +(* *) +(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 2002 Institut National de Recherche en Informatique et *) +(* Automatique. Distributed only by permission. *) +(* *) +(***********************************************************************) + +(* $Id: mLast.mli,v 1.16 2003/07/16 12:50:09 mauny Exp $ *) + +(* 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 new file mode 100644 index 00000000..7258fa07 --- /dev/null +++ b/camlp4/ocaml_src/camlp4/pcaml.ml @@ -0,0 +1,464 @@ +(* 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 new file mode 100644 index 00000000..8f8eacaf --- /dev/null +++ b/camlp4/ocaml_src/camlp4/pcaml.mli @@ -0,0 +1,158 @@ +(* 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 new file mode 100644 index 00000000..07057c96 --- /dev/null +++ b/camlp4/ocaml_src/camlp4/quotation.ml @@ -0,0 +1,33 @@ +(* 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 new file mode 100644 index 00000000..aba963d7 --- /dev/null +++ b/camlp4/ocaml_src/camlp4/quotation.mli @@ -0,0 +1,48 @@ +(* 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 new file mode 100644 index 00000000..da62c467 --- /dev/null +++ b/camlp4/ocaml_src/camlp4/reloc.ml @@ -0,0 +1,333 @@ +(* camlp4r *) +(***********************************************************************) +(* *) +(* Camlp4 *) +(* *) +(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1998 Institut National de Recherche en Informatique et *) +(* Automatique. Distributed only by permission. *) +(* *) +(***********************************************************************) + +(* $Id: reloc.ml,v 1.15 2003/07/16 12:50:09 mauny Exp $ *) + +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 new file mode 100644 index 00000000..21018b52 --- /dev/null +++ b/camlp4/ocaml_src/camlp4/reloc.mli @@ -0,0 +1,16 @@ +(* 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 new file mode 100644 index 00000000..fc21f735 --- /dev/null +++ b/camlp4/ocaml_src/camlp4/spretty.ml @@ -0,0 +1,465 @@ +(* 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 -> invalid_arg "hprint_pretty" + | 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 new file mode 100644 index 00000000..5c62d3f6 --- /dev/null +++ b/camlp4/ocaml_src/camlp4/spretty.mli @@ -0,0 +1,59 @@ +(* 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 new file mode 100644 index 00000000..0d5adc69 --- /dev/null +++ b/camlp4/ocaml_src/lib/.depend @@ -0,0 +1,20 @@ +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 new file mode 100644 index 00000000..d587e744 --- /dev/null +++ b/camlp4/ocaml_src/lib/Makefile @@ -0,0 +1,52 @@ +# 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/." + if test -f $(TARGET:.cma=.lib); then \ + cp $(TARGET:.cma=.lib) "$(LIBDIR)/camlp4/."; \ + else \ + tar cf - $(TARGET:.cma=.a) | (cd "$(LIBDIR)/camlp4/."; tar xf -); \ + fi + +include .depend diff --git a/camlp4/ocaml_src/lib/Makefile.Mac b/camlp4/ocaml_src/lib/Makefile.Mac new file mode 100644 index 00000000..2fc15c63 --- /dev/null +++ b/camlp4/ocaml_src/lib/Makefile.Mac @@ -0,0 +1,46 @@ +####################################################################### +# # +# 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 new file mode 100644 index 00000000..8d12e3e0 --- /dev/null +++ b/camlp4/ocaml_src/lib/Makefile.Mac.depend @@ -0,0 +1,13 @@ +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 new file mode 100644 index 00000000..0411497f --- /dev/null +++ b/camlp4/ocaml_src/lib/extfold.ml @@ -0,0 +1,124 @@ +(* 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 new file mode 100644 index 00000000..cb2824fb --- /dev/null +++ b/camlp4/ocaml_src/lib/extfold.mli @@ -0,0 +1,24 @@ +(* 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 new file mode 100644 index 00000000..f8a6b26a --- /dev/null +++ b/camlp4/ocaml_src/lib/extfun.ml @@ -0,0 +1,105 @@ +(* 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 new file mode 100644 index 00000000..2d42fe2e --- /dev/null +++ b/camlp4/ocaml_src/lib/extfun.mli @@ -0,0 +1,37 @@ +(* 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 new file mode 100644 index 00000000..9ffdb710 --- /dev/null +++ b/camlp4/ocaml_src/lib/fstream.ml @@ -0,0 +1,84 @@ +(* 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 new file mode 100644 index 00000000..d0e8f8b4 --- /dev/null +++ b/camlp4/ocaml_src/lib/fstream.mli @@ -0,0 +1,60 @@ +(* 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 new file mode 100644 index 00000000..41fdd76c --- /dev/null +++ b/camlp4/ocaml_src/lib/gramext.ml @@ -0,0 +1,531 @@ +(* 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 new file mode 100644 index 00000000..bd275ae8 --- /dev/null +++ b/camlp4/ocaml_src/lib/gramext.mli @@ -0,0 +1,79 @@ +(* 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 new file mode 100644 index 00000000..196a6b95 --- /dev/null +++ b/camlp4/ocaml_src/lib/grammar.ml @@ -0,0 +1,1119 @@ +(* 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 new file mode 100644 index 00000000..d38b449f --- /dev/null +++ b/camlp4/ocaml_src/lib/grammar.mli @@ -0,0 +1,200 @@ +(* 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 new file mode 100644 index 00000000..383f5848 --- /dev/null +++ b/camlp4/ocaml_src/lib/plexer.ml @@ -0,0 +1,1221 @@ +(* camlp4r *) +(***********************************************************************) +(* *) +(* Camlp4 *) +(* *) +(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 2002 Institut National de Recherche en Informatique et *) +(* Automatique. Distributed only by permission. *) +(* *) +(***********************************************************************) + +(* $Id: plexer.ml,v 1.16 2003/07/15 09:13:59 mauny Exp $ *) + +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 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 ep = Stream.count strm__ in + ("TILDEIDENT", get_buff len), (bp, ep) + | _ -> + 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 ep = Stream.count strm__ in + ("QUESTIONIDENT", get_buff len), (bp, ep) + | _ -> + 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__; 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 + | "TILDEIDENT" | "QUESTIONIDENT" | "INT" | "INT32" | "INT64" | + "NATIVEINT" | "FLOAT" | "CHAR" | "STRING" | "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 ("../../lib/plexer.ml", 959, 17))); + tok_using = + (fun _ -> raise (Match_failure ("../../lib/plexer.ml", 959, 37))); + tok_removing = + (fun _ -> raise (Match_failure ("../../lib/plexer.ml", 959, 60))); + tok_match = + (fun _ -> raise (Match_failure ("../../lib/plexer.ml", 960, 18))); + tok_text = + (fun _ -> raise (Match_failure ("../../lib/plexer.ml", 960, 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 ("../../lib/plexer.ml", 988, 17))); + tok_using = + (fun _ -> raise (Match_failure ("../../lib/plexer.ml", 988, 37))); + tok_removing = + (fun _ -> raise (Match_failure ("../../lib/plexer.ml", 988, 60))); + tok_match = + (fun _ -> raise (Match_failure ("../../lib/plexer.ml", 989, 18))); + tok_text = + (fun _ -> raise (Match_failure ("../../lib/plexer.ml", 989, 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 new file mode 100644 index 00000000..a541007d --- /dev/null +++ b/camlp4/ocaml_src/lib/plexer.mli @@ -0,0 +1,72 @@ +(* 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 new file mode 100644 index 00000000..d91ee78c --- /dev/null +++ b/camlp4/ocaml_src/lib/stdpp.ml @@ -0,0 +1,99 @@ +(* 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 new file mode 100644 index 00000000..68c0cb6a --- /dev/null +++ b/camlp4/ocaml_src/lib/stdpp.mli @@ -0,0 +1,37 @@ +(* 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 new file mode 100644 index 00000000..67aaffde --- /dev/null +++ b/camlp4/ocaml_src/lib/token.ml @@ -0,0 +1,220 @@ +(* 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 '\\', i - 1 + else + match s.[i] with + '0'..'9' as c -> backslash2 (10 * cod + valch c) s (i + 1) + | _ -> '\\', i - 1 +and backslash2 cod s i = + if i = String.length s then '\\', i - 2 + else + match s.[i] with + '0'..'9' as c -> Char.chr (10 * cod + valch c), i + 1 + | _ -> '\\', i - 2 +and backslash1h s i = + if i = String.length s then '\\', i - 1 + 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) + | _ -> '\\', i - 1 +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 + | _ -> '\\', i - 2 +;; + +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 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 -> 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 new file mode 100644 index 00000000..e561e28e --- /dev/null +++ b/camlp4/ocaml_src/lib/token.mli @@ -0,0 +1,128 @@ +(* 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;; +val eval_string : string -> string;; + (** Convert a char or a string token, where the backslashes had not + been interpreted into a real char or string; raise [Failure] if + bad backslash sequence found; [Token.eval_char (Char.escaped c)] + returns [c] and [Token.eval_string (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 new file mode 100644 index 00000000..45db1720 --- /dev/null +++ b/camlp4/ocaml_src/meta/.cvsignore @@ -0,0 +1,2 @@ +camlp4o.out +camlp4r.out diff --git a/camlp4/ocaml_src/meta/.depend b/camlp4/ocaml_src/meta/.depend new file mode 100644 index 00000000..8f5e0cff --- /dev/null +++ b/camlp4/ocaml_src/meta/.depend @@ -0,0 +1,14 @@ +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_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 new file mode 100644 index 00000000..a7cd03d7 --- /dev/null +++ b/camlp4/ocaml_src/meta/Makefile @@ -0,0 +1,51 @@ +# 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 +CAMLP4RM=pa_r.cmo pa_rp.cmo pr_dump.cmo +CAMLP4RMX=pa_r.cmx pa_rp.cmx pr_dump.cmx +SHELL=/bin/sh +COUT=$(OBJS) camlp4r$(EXE) +COPT=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 $(COPT); then cp $(COPT) "$(BINDIR)/."; fi + +include .depend diff --git a/camlp4/ocaml_src/meta/Makefile.Mac b/camlp4/ocaml_src/meta/Makefile.Mac new file mode 100644 index 00000000..b62b945c --- /dev/null +++ b/camlp4/ocaml_src/meta/Makefile.Mac @@ -0,0 +1,50 @@ +####################################################################### +# # +# 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 new file mode 100644 index 00000000..29675238 --- /dev/null +++ b/camlp4/ocaml_src/meta/Makefile.Mac.depend @@ -0,0 +1,12 @@ +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 new file mode 100644 index 00000000..d68baf8d --- /dev/null +++ b/camlp4/ocaml_src/meta/pa_extend.ml @@ -0,0 +1,2027 @@ +(* 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 new file mode 100644 index 00000000..11fd07f5 --- /dev/null +++ b/camlp4/ocaml_src/meta/pa_extend_m.ml @@ -0,0 +1,40 @@ +(* 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 new file mode 100644 index 00000000..6384d6be --- /dev/null +++ b/camlp4/ocaml_src/meta/pa_ifdef.ml @@ -0,0 +1,216 @@ +(* 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 new file mode 100644 index 00000000..599608f9 --- /dev/null +++ b/camlp4/ocaml_src/meta/pa_macro.ml @@ -0,0 +1,392 @@ +(* 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 new file mode 100644 index 00000000..74a74f93 --- /dev/null +++ b/camlp4/ocaml_src/meta/pa_r.ml @@ -0,0 +1,2830 @@ +(* 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: pa_r.ml,v 1.46 2003/07/16 12:50:09 mauny Exp $ *) + +open Stdpp +open Pcaml + +let _ = 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 +let _ = + Pcaml.add_option "-help_seq" (Arg.Unit help_sequences) + "Print explanations about new sequences and exit." + +let _ = + 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 + +let _ = Pcaml.parse_interf := Grammar.Entry.parse interf +let _ = 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 +let _ = + Pcaml.add_option "-no_warn_seq" (Arg.Clear not_yet_warned) + "No warning when using old syntax for sequences." + +let _ = + 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))]; + 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.After "arrow"), + [None, Some Gramext.NonA, + [[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 ("TILDEIDENT", ""); Gramext.Stoken ("", ":"); + Gramext.Sself], + Gramext.action + (fun (t : 'ctyp) _ (i : string) (loc : int * int) -> + (MLast.TyLab (loc, i, t) : 'ctyp))]]; + 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 ("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 ("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 ("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 ("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 ("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 ("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))]]]) + +let _ = + 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 new file mode 100644 index 00000000..ad743e87 --- /dev/null +++ b/camlp4/ocaml_src/meta/pa_rp.ml @@ -0,0 +1,641 @@ +(* 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 new file mode 100644 index 00000000..db422853 --- /dev/null +++ b/camlp4/ocaml_src/meta/pr_dump.ml @@ -0,0 +1,48 @@ +(* 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 new file mode 100644 index 00000000..07002367 --- /dev/null +++ b/camlp4/ocaml_src/meta/q_MLast.ml @@ -0,0 +1,4687 @@ +(* 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: q_MLast.ml,v 1.55 2003/07/16 12:50:10 mauny Exp $ *) + +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_QUESTIONIDENT = Grammar.Entry.create gram "a_QUESTIONIDENT" + +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 + +let _ = + 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 ("./meta/q_MLast.ml", 300, 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 ("./meta/q_MLast.ml", 358, 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))]; + 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.After "arrow"), + [None, Some Gramext.NonA, + [[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_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))]]; + 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_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_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_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_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_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_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))]]]) + +let _ = + 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 *) + +let _ = + 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_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))]]] + +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 _ = + 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 _ = + 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 _ = + 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 _ = + 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 _ = + 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 _ = + 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 _ = + 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 _ = + 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 _ = + 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 _ = + 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 _ = + 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 _ = + 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 _ = + 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 new file mode 100644 index 00000000..18deb618 --- /dev/null +++ b/camlp4/ocaml_src/odyl/.cvsignore @@ -0,0 +1,2 @@ +odyl +odyl_config.ml diff --git a/camlp4/ocaml_src/odyl/.depend b/camlp4/ocaml_src/odyl/.depend new file mode 100644 index 00000000..7823dd01 --- /dev/null +++ b/camlp4/ocaml_src/odyl/.depend @@ -0,0 +1,6 @@ +odyl.cmo: odyl_config.cmo odyl_main.cmi +odyl.cmx: odyl_config.cmx odyl_main.cmx +odyl_main.cmo: $(OTOP)/otherlibs/dynlink/dynlink.cmi odyl_config.cmo \ + odyl_main.cmi +odyl_main.cmx: odyl_config.cmx \ + odyl_main.cmi diff --git a/camlp4/ocaml_src/odyl/Makefile b/camlp4/ocaml_src/odyl/Makefile new file mode 100644 index 00000000..6b837d96 --- /dev/null +++ b/camlp4/ocaml_src/odyl/Makefile @@ -0,0 +1,60 @@ +# 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 "$(LIBDIR)/camlp4/." + +include .depend diff --git a/camlp4/ocaml_src/odyl/Makefile.Mac b/camlp4/ocaml_src/odyl/Makefile.Mac new file mode 100644 index 00000000..41b16d30 --- /dev/null +++ b/camlp4/ocaml_src/odyl/Makefile.Mac @@ -0,0 +1,49 @@ +####################################################################### +# # +# 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 new file mode 100644 index 00000000..adaff277 --- /dev/null +++ b/camlp4/ocaml_src/odyl/Makefile.Mac.depend @@ -0,0 +1,4 @@ +odyl_main.cmoÄ odyl_config.cmo odyl_main.cmi +odyl_main.cmxÄ odyl_config.cmx odyl_main.cmi +odyl.cmoÄ odyl_config.cmo odyl_main.cmi +odyl.cmxÄ odyl_config.cmx odyl_main.cmx diff --git a/camlp4/ocaml_src/odyl/odyl.ml b/camlp4/ocaml_src/odyl/odyl.ml new file mode 100644 index 00000000..096e13ee --- /dev/null +++ b/camlp4/ocaml_src/odyl/odyl.ml @@ -0,0 +1,50 @@ +(* 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 new file mode 100644 index 00000000..22e5e65d --- /dev/null +++ b/camlp4/ocaml_src/odyl/odyl_main.ml @@ -0,0 +1,77 @@ +(* 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 new file mode 100644 index 00000000..be441a6c --- /dev/null +++ b/camlp4/ocaml_src/odyl/odyl_main.mli @@ -0,0 +1,13 @@ +(* 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 new file mode 100644 index 00000000..b3294497 --- /dev/null +++ b/camlp4/ocaml_src/tools/camlp4_comm.mpw @@ -0,0 +1,27 @@ +####################################################################### +# # +# Camlp4 # +# # +# Damien Doligez, projet Para, INRIA Rocquencourt # +# # +# Copyright 1999 Institut National de Recherche en Informatique et # +# en Automatique. Distributed only by permission. # +# # +####################################################################### + +# $Id: camlp4_comm.mpw,v 1.2 2002/07/19 14:53:55 mauny Exp $ + +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 new file mode 100755 index 00000000..357a9295 --- /dev/null +++ b/camlp4/ocaml_src/tools/camlp4_comm.sh @@ -0,0 +1,9 @@ +#!/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 new file mode 100644 index 00000000..2c4a0ee1 --- /dev/null +++ b/camlp4/ocaml_src/tools/extract_crc.mpw @@ -0,0 +1,3 @@ +# $Id: extract_crc.mpw,v 1.1 2001/12/13 13:59:25 doligez Exp $ + +"{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 new file mode 100755 index 00000000..e69de29b diff --git a/camlp4/ocaml_src/tools/ocamlc.mpw b/camlp4/ocaml_src/tools/ocamlc.mpw new file mode 100644 index 00000000..7e594c03 --- /dev/null +++ b/camlp4/ocaml_src/tools/ocamlc.mpw @@ -0,0 +1,3 @@ +# + +"{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 new file mode 100755 index 00000000..ee654c2c --- /dev/null +++ b/camlp4/ocaml_src/tools/ocamlc.sh @@ -0,0 +1,8 @@ +#!/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 new file mode 100755 index 00000000..1fb669d6 --- /dev/null +++ b/camlp4/ocaml_src/tools/ocamlopt.sh @@ -0,0 +1,8 @@ +#!/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 new file mode 100644 index 00000000..e69de29b diff --git a/camlp4/ocaml_stuff/parsing/.depend b/camlp4/ocaml_stuff/parsing/.depend new file mode 100644 index 00000000..4364f56e --- /dev/null +++ b/camlp4/ocaml_stuff/parsing/.depend @@ -0,0 +1,2 @@ +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 new file mode 100644 index 00000000..28041288 --- /dev/null +++ b/camlp4/ocaml_stuff/utils/.depend @@ -0,0 +1,2 @@ +config.cmo: config.cmi +config.cmx: config.cmi diff --git a/camlp4/ocpp/.cvsignore b/camlp4/ocpp/.cvsignore new file mode 100644 index 00000000..baef26c6 --- /dev/null +++ b/camlp4/ocpp/.cvsignore @@ -0,0 +1,3 @@ +*.cm[oia] +ocpp +crc.ml diff --git a/camlp4/ocpp/.depend b/camlp4/ocpp/.depend new file mode 100644 index 00000000..e69de29b diff --git a/camlp4/ocpp/Makefile b/camlp4/ocpp/Makefile new file mode 100644 index 00000000..af4a11f5 --- /dev/null +++ b/camlp4/ocpp/Makefile @@ -0,0 +1,25 @@ +# $Id: Makefile,v 1.5 2003/07/10 12:28:33 michel Exp $ + +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 new file mode 100644 index 00000000..0a737ed5 --- /dev/null +++ b/camlp4/ocpp/Makefile.Mac @@ -0,0 +1,41 @@ +####################################################################### +# # +# Camlp4 # +# # +# Damien Doligez, projet Para, INRIA Rocquencourt # +# # +# Copyright 1999 Institut National de Recherche en Informatique et # +# en Automatique. Distributed only by permission. # +# # +####################################################################### + +# $Id: Makefile.Mac,v 1.2 2003/07/10 12:28:33 michel Exp $ + +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 new file mode 100644 index 00000000..e62f689a --- /dev/null +++ b/camlp4/ocpp/ocpp.ml @@ -0,0 +1,140 @@ +(* camlp4r *) +(***********************************************************************) +(* *) +(* Camlp4 *) +(* *) +(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 2002 Institut National de Recherche en Informatique et *) +(* Automatique. Distributed only by permission. *) +(* *) +(***********************************************************************) + +(* $Id: ocpp.ml,v 1.5 2003/07/10 12:28:33 michel Exp $ *) + +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 new file mode 100644 index 00000000..8ae0ebb0 --- /dev/null +++ b/camlp4/odyl/.cvsignore @@ -0,0 +1,4 @@ +*.cm[oia] +odyl +*.lib +odyl_config.ml diff --git a/camlp4/odyl/.depend b/camlp4/odyl/.depend new file mode 100644 index 00000000..7823dd01 --- /dev/null +++ b/camlp4/odyl/.depend @@ -0,0 +1,6 @@ +odyl.cmo: odyl_config.cmo odyl_main.cmi +odyl.cmx: odyl_config.cmx odyl_main.cmx +odyl_main.cmo: $(OTOP)/otherlibs/dynlink/dynlink.cmi odyl_config.cmo \ + odyl_main.cmi +odyl_main.cmx: odyl_config.cmx \ + odyl_main.cmi diff --git a/camlp4/odyl/Makefile b/camlp4/odyl/Makefile new file mode 100644 index 00000000..097ccb67 --- /dev/null +++ b/camlp4/odyl/Makefile @@ -0,0 +1,61 @@ +# $Id: Makefile,v 1.14 2003/07/16 13:34:59 xleroy Exp $ + +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 new file mode 100644 index 00000000..9664fe84 --- /dev/null +++ b/camlp4/odyl/Makefile.Mac @@ -0,0 +1,49 @@ +####################################################################### +# # +# Camlp4 # +# # +# Damien Doligez, projet Para, INRIA Rocquencourt # +# # +# Copyright 1999 Institut National de Recherche en Informatique et # +# en Automatique. Distributed only by permission. # +# # +####################################################################### + +# $Id: Makefile.Mac,v 1.1 2001/12/13 13:59:25 doligez Exp $ + +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 new file mode 100644 index 00000000..adaff277 --- /dev/null +++ b/camlp4/odyl/Makefile.Mac.depend @@ -0,0 +1,4 @@ +odyl_main.cmoÄ odyl_config.cmo odyl_main.cmi +odyl_main.cmxÄ odyl_config.cmx odyl_main.cmi +odyl.cmoÄ odyl_config.cmo odyl_main.cmi +odyl.cmxÄ odyl_config.cmx odyl_main.cmx diff --git a/camlp4/odyl/odyl.ml b/camlp4/odyl/odyl.ml new file mode 100644 index 00000000..7e895eb1 --- /dev/null +++ b/camlp4/odyl/odyl.ml @@ -0,0 +1,51 @@ +(* camlp4r *) +(***********************************************************************) +(* *) +(* Camlp4 *) +(* *) +(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 2001 Institut National de Recherche en Informatique et *) +(* Automatique. Distributed only by permission. *) +(* *) +(***********************************************************************) + +(* $Id: odyl.ml,v 1.2 2002/07/19 14:53:56 mauny Exp $ *) + +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 new file mode 100644 index 00000000..66c236c5 --- /dev/null +++ b/camlp4/odyl/odyl_main.ml @@ -0,0 +1,82 @@ +(* 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: odyl_main.ml,v 1.4 2003/07/10 12:28:34 michel Exp $ *) + +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 new file mode 100644 index 00000000..1dc1683a --- /dev/null +++ b/camlp4/odyl/odyl_main.mli @@ -0,0 +1,13 @@ +(* camlp4r *) +(* $Id: odyl_main.mli,v 1.2 2002/07/19 14:53:56 mauny Exp $ *) + +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 new file mode 100755 index 00000000..a0bebbe2 --- /dev/null +++ b/camlp4/tools/apply.sh @@ -0,0 +1,28 @@ +#!/bin/sh +# $Id: apply.sh,v 1.2 2002/07/23 14:11:49 doligez Exp $ + +ARGS1= +FILE= +while test "" != "$1"; do + case $1 in + *.ml*) FILE=$1;; + *) ARGS1="$ARGS1 $1";; + esac + shift +done + +head -1 $FILE >/dev/null || exit 1 + +set - `head -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 new file mode 100644 index 00000000..fc68eec9 --- /dev/null +++ b/camlp4/tools/camlp4_comm.mpw @@ -0,0 +1,53 @@ +####################################################################### +# # +# Camlp4 # +# # +# Damien Doligez, projet Para, INRIA Rocquencourt # +# # +# Copyright 1999 Institut National de Recherche en Informatique et # +# en Automatique. Distributed only by permission. # +# # +####################################################################### + +# $Id: camlp4_comm.mpw,v 1.1 2001/12/13 13:59:25 doligez Exp $ + +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 new file mode 100755 index 00000000..bc79f149 --- /dev/null +++ b/camlp4/tools/camlp4_comm.sh @@ -0,0 +1,37 @@ +#!/bin/sh +# $Id: camlp4_comm.sh,v 1.7 2003/07/10 12:28:35 michel Exp $ + +ARGS1= +FILE= +QUIET=no +while test "" != "$1"; do + case $1 in + -q) QUIET=yes;; + *.ml*) FILE=$1;; + *) ARGS1="$ARGS1 $1";; + esac + shift +done + +head -1 $FILE >/dev/null || exit 1 + +set - `head -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 new file mode 100755 index 00000000..98ba728f --- /dev/null +++ b/camlp4/tools/conv.sh @@ -0,0 +1,22 @@ +#!/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 - `head -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 new file mode 100644 index 00000000..2c4a0ee1 --- /dev/null +++ b/camlp4/tools/extract_crc.mpw @@ -0,0 +1,3 @@ +# $Id: extract_crc.mpw,v 1.1 2001/12/13 13:59:25 doligez Exp $ + +"{OTOP}boot:ocamlrun" "{OTOP}otherlibs:dynlink:extract_crc" {"parameters"} diff --git a/camlp4/tools/extract_crc.sh b/camlp4/tools/extract_crc.sh new file mode 100755 index 00000000..e69de29b diff --git a/camlp4/tools/ocamlc.mpw b/camlp4/tools/ocamlc.mpw new file mode 100644 index 00000000..cee6feaa --- /dev/null +++ b/camlp4/tools/ocamlc.mpw @@ -0,0 +1,3 @@ +# $Id: ocamlc.mpw,v 1.1 2001/12/13 13:59:25 doligez Exp $ + +"{OTOP}boot:ocamlrun" "{OTOP}ocamlc" -I "{OTOP}stdlib:" {"parameters"} diff --git a/camlp4/tools/ocamlc.sh b/camlp4/tools/ocamlc.sh new file mode 100755 index 00000000..ee654c2c --- /dev/null +++ b/camlp4/tools/ocamlc.sh @@ -0,0 +1,8 @@ +#!/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 new file mode 100755 index 00000000..1fb669d6 --- /dev/null +++ b/camlp4/tools/ocamlopt.sh @@ -0,0 +1,8 @@ +#!/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 new file mode 100644 index 00000000..df1824f4 --- /dev/null +++ b/camlp4/top/.cvsignore @@ -0,0 +1 @@ +*.cm[oia] diff --git a/camlp4/top/.depend b/camlp4/top/.depend new file mode 100644 index 00000000..0860d8d7 --- /dev/null +++ b/camlp4/top/.depend @@ -0,0 +1,12 @@ +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)/typing/outcometree.cmi $(OTOP)/toplevel/toploop.cmi +rprint.cmx: $(OTOP)/typing/outcometree.cmi $(OTOP)/toplevel/toploop.cmx diff --git a/camlp4/top/Makefile b/camlp4/top/Makefile new file mode 100644 index 00000000..b8851f07 --- /dev/null +++ b/camlp4/top/Makefile @@ -0,0 +1,52 @@ +# $Id: Makefile,v 1.11 2003/07/10 12:28:35 michel Exp $ + +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 new file mode 100644 index 00000000..292d66b0 --- /dev/null +++ b/camlp4/top/Makefile.Mac @@ -0,0 +1,60 @@ +####################################################################### +# # +# Camlp4 # +# # +# Damien Doligez, projet Para, INRIA Rocquencourt # +# # +# Copyright 1999 Institut National de Recherche en Informatique et # +# en Automatique. Distributed only by permission. # +# # +####################################################################### + +# $Id: Makefile.Mac,v 1.2 2002/07/19 14:53:56 mauny Exp $ + +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 new file mode 100644 index 00000000..6b7096da --- /dev/null +++ b/camlp4/top/Makefile.Mac.depend @@ -0,0 +1,2 @@ +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 new file mode 100644 index 00000000..9c6663ac --- /dev/null +++ b/camlp4/top/camlp4_top.ml @@ -0,0 +1,172 @@ +(* 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: camlp4_top.ml,v 1.12 2002/09/09 14:22:27 guesdon Exp $ *) + +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 new file mode 100644 index 00000000..1fa4aebd --- /dev/null +++ b/camlp4/top/oprint.ml @@ -0,0 +1,589 @@ +(* camlp4r *) +(***********************************************************************) +(* *) +(* Camlp4 *) +(* *) +(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 2002 Institut National de Recherche en Informatique et *) +(* Automatique. Distributed only by permission. *) +(* *) +(***********************************************************************) + +(* $Id: oprint.ml,v 1.5 2003/07/15 09:14:00 mauny Exp $ *) + +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 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 + | 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_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 new file mode 100644 index 00000000..6d6fc5b1 --- /dev/null +++ b/camlp4/top/rprint.ml @@ -0,0 +1,414 @@ +(* camlp4r *) +(***********************************************************************) +(* *) +(* Camlp4 *) +(* *) +(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 2002 Institut National de Recherche en Informatique et *) +(* Automatique. Distributed only by permission. *) +(* *) +(***********************************************************************) + +(* $Id: rprint.ml,v 1.11 2003/07/15 09:14:00 mauny Exp $ *) + +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_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 + | 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 new file mode 100644 index 00000000..eaf9ea55 --- /dev/null +++ b/config/.cvsignore @@ -0,0 +1,4 @@ +m.h +s.h +Makefile + diff --git a/config/Makefile-templ b/config/Makefile-templ new file mode 100644 index 00000000..f11b3a01 --- /dev/null +++ b/config/Makefile-templ @@ -0,0 +1,310 @@ +######################################################################### +# # +# 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: Makefile-templ,v 1.27 2003/07/03 15:13:22 xleroy Exp $ + +### 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 new file mode 100644 index 00000000..6360e652 --- /dev/null +++ b/config/Makefile.mingw @@ -0,0 +1,123 @@ +######################################################################### +# # +# 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: Makefile.mingw,v 1.11 2003/07/08 15:12:58 xleroy Exp $ + +# 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 new file mode 100644 index 00000000..9b995b42 --- /dev/null +++ b/config/Makefile.msvc @@ -0,0 +1,129 @@ +######################################################################### +# # +# 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: Makefile.msvc,v 1.11 2003/07/03 16:14:49 xleroy Exp $ + +# 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 new file mode 100644 index 00000000..160d33ec --- /dev/null +++ b/config/auto-aux/align.c @@ -0,0 +1,103 @@ +/***********************************************************************/ +/* */ +/* 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: align.c,v 1.7 2001/12/07 13:39:41 xleroy Exp $ */ + +#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 new file mode 100644 index 00000000..f1a416b8 --- /dev/null +++ b/config/auto-aux/ansi.c @@ -0,0 +1,21 @@ +/***********************************************************************/ +/* */ +/* 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 new file mode 100644 index 00000000..7d141dd7 --- /dev/null +++ b/config/auto-aux/async_io.c @@ -0,0 +1,60 @@ +/***********************************************************************/ +/* */ +/* 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: async_io.c,v 1.8 2003/02/11 14:05:36 xleroy Exp $ */ + +#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 new file mode 100644 index 00000000..537c4f7b --- /dev/null +++ b/config/auto-aux/bytecopy.c @@ -0,0 +1,34 @@ +/***********************************************************************/ +/* */ +/* 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: bytecopy.c,v 1.7 2001/12/07 13:39:43 xleroy Exp $ */ + +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 new file mode 100644 index 00000000..9cf6956e --- /dev/null +++ b/config/auto-aux/dblalign.c @@ -0,0 +1,55 @@ +/***********************************************************************/ +/* */ +/* 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: dblalign.c,v 1.9 2001/12/07 13:39:43 xleroy Exp $ */ + +#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 new file mode 100644 index 00000000..24d3786c --- /dev/null +++ b/config/auto-aux/divmod.c @@ -0,0 +1,47 @@ +/***********************************************************************/ +/* */ +/* 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 new file mode 100644 index 00000000..63ade0a5 --- /dev/null +++ b/config/auto-aux/elf.c @@ -0,0 +1,26 @@ +/***********************************************************************/ +/* */ +/* 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: elf.c,v 1.4 2001/12/07 13:39:43 xleroy Exp $ */ + +#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 new file mode 100644 index 00000000..fad4b9d8 --- /dev/null +++ b/config/auto-aux/endian.c @@ -0,0 +1,41 @@ +/***********************************************************************/ +/* */ +/* 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: endian.c,v 1.8 2001/12/07 13:39:43 xleroy Exp $ */ + +#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 new file mode 100644 index 00000000..6a1ee687 --- /dev/null +++ b/config/auto-aux/getgroups.c @@ -0,0 +1,32 @@ +/***********************************************************************/ +/* */ +/* 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: getgroups.c,v 1.8 2001/12/07 13:39:43 xleroy Exp $ */ + +#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 new file mode 100644 index 00000000..60c34e25 --- /dev/null +++ b/config/auto-aux/gethostbyaddr.c @@ -0,0 +1,51 @@ +/***********************************************************************/ +/* */ +/* 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: gethostbyaddr.c,v 1.2 2002/05/06 08:29:52 xleroy Exp $ */ + +#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 new file mode 100644 index 00000000..f1830aa7 --- /dev/null +++ b/config/auto-aux/gethostbyname.c @@ -0,0 +1,41 @@ +/***********************************************************************/ +/* */ +/* 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: gethostbyname.c,v 1.2 2002/05/06 08:29:52 xleroy Exp $ */ + +#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 new file mode 100755 index 00000000..99384768 --- /dev/null +++ b/config/auto-aux/hasgot @@ -0,0 +1,28 @@ +#!/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/int64align.c b/config/auto-aux/int64align.c new file mode 100644 index 00000000..5f83e68c --- /dev/null +++ b/config/auto-aux/int64align.c @@ -0,0 +1,56 @@ +/***********************************************************************/ +/* */ +/* 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: int64align.c,v 1.2 2001/12/07 13:39:43 xleroy Exp $ */ + +#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 new file mode 100644 index 00000000..40abd085 --- /dev/null +++ b/config/auto-aux/longlong.c @@ -0,0 +1,43 @@ +/***********************************************************************/ +/* */ +/* 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: longlong.c,v 1.4 2002/05/25 08:33:26 xleroy Exp $ */ + +#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 new file mode 100755 index 00000000..ce65bd07 --- /dev/null +++ b/config/auto-aux/runtest @@ -0,0 +1,8 @@ +#!/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 new file mode 100644 index 00000000..209b4906 --- /dev/null +++ b/config/auto-aux/schar.c @@ -0,0 +1,23 @@ +/***********************************************************************/ +/* */ +/* 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: schar.c,v 1.8 2001/12/07 13:39:44 xleroy Exp $ */ + +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 new file mode 100644 index 00000000..9b28c626 --- /dev/null +++ b/config/auto-aux/schar2.c @@ -0,0 +1,23 @@ +/***********************************************************************/ +/* */ +/* 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: schar2.c,v 1.8 2001/12/07 13:39:44 xleroy Exp $ */ + +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 new file mode 100755 index 00000000..9b31267f --- /dev/null +++ b/config/auto-aux/searchpath @@ -0,0 +1,9 @@ +#!/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 new file mode 100755 index 00000000..eb447baa --- /dev/null +++ b/config/auto-aux/sharpbang @@ -0,0 +1,2 @@ +#! /bin/cat +exit 1 diff --git a/config/auto-aux/sharpbang2 b/config/auto-aux/sharpbang2 new file mode 100755 index 00000000..37530963 --- /dev/null +++ b/config/auto-aux/sharpbang2 @@ -0,0 +1,2 @@ +#! /usr/bin/cat +exit 1 diff --git a/config/auto-aux/sighandler.c b/config/auto-aux/sighandler.c new file mode 100644 index 00000000..5ab79d7c --- /dev/null +++ b/config/auto-aux/sighandler.c @@ -0,0 +1,23 @@ +/***********************************************************************/ +/* */ +/* 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: sighandler.c,v 1.7 2001/12/07 13:39:44 xleroy Exp $ */ + +#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 new file mode 100644 index 00000000..ffafd521 --- /dev/null +++ b/config/auto-aux/signals.c @@ -0,0 +1,68 @@ +/***********************************************************************/ +/* */ +/* 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: signals.c,v 1.7 2001/12/07 13:39:44 xleroy Exp $ */ + +/* 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 new file mode 100644 index 00000000..5ed0a3d2 --- /dev/null +++ b/config/auto-aux/sizes.c @@ -0,0 +1,23 @@ +/***********************************************************************/ +/* */ +/* 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: sizes.c,v 1.9 2001/12/07 13:39:44 xleroy Exp $ */ + +#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 new file mode 100644 index 00000000..3ab90bce --- /dev/null +++ b/config/auto-aux/solaris-ld @@ -0,0 +1,7 @@ +#!/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 new file mode 100644 index 00000000..d56e26e7 --- /dev/null +++ b/config/auto-aux/stackov.c @@ -0,0 +1,72 @@ +/***********************************************************************/ +/* */ +/* 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: stackov.c,v 1.3 2001/12/07 13:39:44 xleroy Exp $ */ + +#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); + } +} + +void f(char * c); +void g(char * c) { char d[1024]; f(d); } +void f(char * c) { char d[1024]; g(d); } + +int main(int argc, char ** argv) +{ + struct sigaltstack stk; + struct sigaction act; + struct rlimit limit; + + 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; + limit.rlim_max = limit.rlim_cur = 0x20000; + if (sigaltstack(&stk, NULL) != 0) { perror("sigaltstack"); return 2; } + if (sigaction(SIGSEGV, &act, NULL) != 0) { perror("sigaction"); return 2; } + if (setrlimit(RLIMIT_STACK, &limit) != 0) { perror("setrlimit"); return 2; } + f(NULL); + return 2; +} diff --git a/config/auto-aux/tclversion.c b/config/auto-aux/tclversion.c new file mode 100644 index 00000000..ebd1224f --- /dev/null +++ b/config/auto-aux/tclversion.c @@ -0,0 +1,7 @@ +#include +#include + +main () +{ + puts(TCL_VERSION); +} diff --git a/config/auto-aux/trycompile b/config/auto-aux/trycompile new file mode 100755 index 00000000..797a1c38 --- /dev/null +++ b/config/auto-aux/trycompile @@ -0,0 +1,7 @@ +#!/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 new file mode 100644 index 00000000..5de19fd1 --- /dev/null +++ b/config/config.Mac @@ -0,0 +1,76 @@ +######################################################################### +# # +# 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: config.Mac,v 1.21 2001/12/13 13:59:26 doligez Exp $ + +### 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 new file mode 100755 index 00000000..7620ff94 --- /dev/null +++ b/config/gnu/config.guess @@ -0,0 +1,1366 @@ +#! /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='2001-06-25' + +# 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=`(head -1 /etc/motd | awk '{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 | head -1 | awk '{ 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 new file mode 100755 index 00000000..fdcc42bc --- /dev/null +++ b/config/gnu/config.sub @@ -0,0 +1,1375 @@ +#! /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 new file mode 100644 index 00000000..1925449b --- /dev/null +++ b/config/m-MacOS.h @@ -0,0 +1,33 @@ +/***********************************************************************/ +/* */ +/* 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: m-MacOS.h,v 1.3 2001/12/07 13:39:39 xleroy Exp $ */ + +#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 new file mode 100644 index 00000000..25aaa748 --- /dev/null +++ b/config/m-nt.h @@ -0,0 +1,34 @@ +/***********************************************************************/ +/* */ +/* 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: m-nt.h,v 1.10 2002/06/07 09:49:37 xleroy Exp $ */ + +/* 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 new file mode 100644 index 00000000..7162f11f --- /dev/null +++ b/config/m-templ.h @@ -0,0 +1,81 @@ +/***********************************************************************/ +/* */ +/* 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: m-templ.h,v 1.14 2001/12/07 13:39:40 xleroy Exp $ */ + +/* 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 new file mode 100644 index 00000000..b804bb73 --- /dev/null +++ b/config/s-MacOS.h @@ -0,0 +1,20 @@ +/***********************************************************************/ +/* */ +/* 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: s-MacOS.h,v 1.4 2001/12/07 13:39:40 xleroy Exp $ */ + +#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 new file mode 100644 index 00000000..368ea7ea --- /dev/null +++ b/config/s-nt.h @@ -0,0 +1,29 @@ +/***********************************************************************/ +/* */ +/* 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: s-nt.h,v 1.12 2002/06/18 13:00:55 xleroy Exp $ */ + +/* 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 new file mode 100644 index 00000000..80857c24 --- /dev/null +++ b/config/s-templ.h @@ -0,0 +1,207 @@ +/***********************************************************************/ +/* */ +/* 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: s-templ.h,v 1.21 2002/05/06 08:29:52 xleroy Exp $ */ + +/* 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 new file mode 100755 index 00000000..b45aaefb --- /dev/null +++ b/configure @@ -0,0 +1,1522 @@ +#! /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,v 1.195 2003/07/22 07:41:31 xleroy Exp $ + +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 +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 + +# 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-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-*-*) + # On Sparc V9 with certain versions of gcc, determination of double + # alignment is not reliable (PR#1521), hence force it + 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;; + 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|i386,bsd_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 + mips-*-ultrix*) bignum_arch=mips;; + alpha*-*-osf*) bignum_arch=alpha;; + i[3456]86-*-linux*) + case `sh ./runtest elf.c` in + elf) bignum_arch=x86;; + *) bignum_arch=C;; + esac;; + i[3456]86-*-beos) bignum_arch=x86;; + i[3456]86-*-*bsd*) + case `sh ./runtest elf.c` in + elf) bignum_arch=x86;; + *) bignum_arch=C;; + esac;; + sparc*-*-sunos*) bignum_arch=supersparc;; + sparc*-*-solaris*) bignum_arch=supersparc-solaris;; + sparc*-*-*bsd*) bignum_arch=sparc;; + m68k-*-sunos*) bignum_arch=68K;; + *) bignum_arch=C +esac + +# Some systems (e.g. Solaris) don't have an assembler! +if sh ./searchpath as; then :; else bignum_arch=C; fi + +echo "BIGNUM_ARCH=$bignum_arch" >> 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 ./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 +else + echo "POSIX threads not found." +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.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" + 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" + 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 ...... $bignum_arch" + +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 new file mode 100644 index 00000000..b608cf55 --- /dev/null +++ b/debugger/.cvsignore @@ -0,0 +1,4 @@ +lexer.ml +parser.ml +parser.mli +ocamldebug diff --git a/debugger/.depend b/debugger/.depend new file mode 100644 index 00000000..433b005e --- /dev/null +++ b/debugger/.depend @@ -0,0 +1,186 @@ +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_aux.cmi: ../parsing/longident.cmi primitives.cmi +parser.cmi: ../parsing/longident.cmi parser_aux.cmi +pattern_matching.cmi: debugcom.cmi parser_aux.cmi ../typing/typedtree.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 primitives.cmi source.cmi symbols.cmi \ + breakpoints.cmi +breakpoints.cmx: checkpoints.cmx debugcom.cmx exec.cmx \ + ../bytecomp/instruct.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 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 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 +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 new file mode 100644 index 00000000..e739b77b --- /dev/null +++ b/debugger/Makefile @@ -0,0 +1,113 @@ +######################################################################### +# # +# 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: Makefile,v 1.27 2002/11/18 09:23:31 xleroy Exp $ + +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 \ + 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 new file mode 100644 index 00000000..9a055e02 --- /dev/null +++ b/debugger/breakpoints.ml @@ -0,0 +1,237 @@ +(***********************************************************************) +(* *) +(* 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.ml,v 1.11 2002/11/05 16:33:23 doligez Exp $ *) + +(******************************* Breakpoints ***************************) + +open Instruct +open Primitives +open Debugcom +open Checkpoints +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); + print_string "Breakpoint "; + print_int !breakpoint_number; + print_string " at "; + print_int event.ev_pos; + print_string " : file "; + print_string event.ev_module; + begin try + let (start, line) = + line_of_pos (get_buffer event.ev_module) event.ev_char.Lexing.pos_cnum + in + print_string ", line "; + print_int line; + print_string ", character "; + print_int (event.ev_char.Lexing.pos_cnum - start + 1) + with Not_found | Out_of_range -> + print_string ", character "; + print_int event.ev_char.Lexing.pos_cnum + end; + 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 new file mode 100644 index 00000000..f3be8ec5 --- /dev/null +++ b/debugger/breakpoints.mli @@ -0,0 +1,61 @@ +(***********************************************************************) +(* *) +(* 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.mli,v 1.2 1999/11/17 18:57:22 xleroy Exp $ *) + +(******************************* 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 new file mode 100644 index 00000000..2f0fe622 --- /dev/null +++ b/debugger/checkpoints.ml @@ -0,0 +1,85 @@ +(***********************************************************************) +(* *) +(* 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.ml,v 1.4 2002/10/29 17:53:23 doligez Exp $ *) + +(*************************** 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 new file mode 100644 index 00000000..cbd576a2 --- /dev/null +++ b/debugger/checkpoints.mli @@ -0,0 +1,58 @@ +(***********************************************************************) +(* *) +(* 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.mli,v 1.4 2002/10/29 17:53:23 doligez Exp $ *) + +(***************************** 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 new file mode 100644 index 00000000..0b6ed387 --- /dev/null +++ b/debugger/command_line.ml @@ -0,0 +1,1071 @@ +(***********************************************************************) +(* *) +(* 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: command_line.ml,v 1.16 2003/07/17 14:04:03 doligez Exp $ *) + +(************************ 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_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_breakpoints ppf lexbuf = + eol lexbuf; + if !breakpoints = [] then fprintf ppf "No breakpoint.@." + else + (fprintf ppf "Num Address Where@."; + List.iter + (function (num, {ev_pos = pc; ev_module = md; ev_char = char}) -> + fprintf ppf "%3d %10d in %s, character %d@." num pc md + char.Lexing.pos_cnum) + (List.rev !breakpoints)) + +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." }; + (* 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 `camlrun -D socket 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 new file mode 100644 index 00000000..aca2ffc7 --- /dev/null +++ b/debugger/command_line.mli @@ -0,0 +1,22 @@ +(***********************************************************************) +(* *) +(* 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: command_line.mli,v 1.4 2000/03/07 18:22:14 weis Exp $ *) + +(************************ 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 new file mode 100644 index 00000000..777304f7 --- /dev/null +++ b/debugger/debugcom.ml @@ -0,0 +1,278 @@ +(***********************************************************************) +(* *) +(* 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: debugcom.ml,v 1.12 2002/10/29 17:53:23 doligez Exp $ *) + +(* 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 new file mode 100644 index 00000000..ac26e45f --- /dev/null +++ b/debugger/debugcom.mli @@ -0,0 +1,102 @@ +(***********************************************************************) +(* *) +(* 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: debugcom.mli,v 1.8 2002/10/29 17:53:23 doligez Exp $ *) + +(* 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 new file mode 100644 index 00000000..f25f7f8b --- /dev/null +++ b/debugger/debugger_config.ml @@ -0,0 +1,75 @@ +(***********************************************************************) +(* *) +(* 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: debugger_config.ml,v 1.10 2002/11/17 16:42:10 xleroy Exp $ *) + +(**************************** 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 new file mode 100644 index 00000000..a3a9b05c --- /dev/null +++ b/debugger/debugger_config.mli @@ -0,0 +1,35 @@ +(***********************************************************************) +(* *) +(* 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: debugger_config.mli,v 1.5 2002/11/17 16:42:10 xleroy Exp $ *) + +(********************** 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 new file mode 100644 index 00000000..9905fbc1 --- /dev/null +++ b/debugger/envaux.ml @@ -0,0 +1,83 @@ +(***********************************************************************) +(* *) +(* 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: envaux.ml,v 1.7 2000/03/06 22:11:17 weis Exp $ *) + +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 new file mode 100644 index 00000000..b8bfe75f --- /dev/null +++ b/debugger/envaux.mli @@ -0,0 +1,33 @@ +(***********************************************************************) +(* *) +(* 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: envaux.mli,v 1.5 2000/03/06 22:11:20 weis Exp $ *) + +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 new file mode 100644 index 00000000..0299454b --- /dev/null +++ b/debugger/eval.ml @@ -0,0 +1,207 @@ +(***********************************************************************) +(* *) +(* 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: eval.ml,v 1.28 2003/07/02 09:14:30 xleroy Exp $ *) + +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 new file mode 100644 index 00000000..8e809253 --- /dev/null +++ b/debugger/eval.mli @@ -0,0 +1,40 @@ +(***********************************************************************) +(* *) +(* 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: eval.mli,v 1.6 2000/03/06 22:11:21 weis Exp $ *) + +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 new file mode 100644 index 00000000..d2b8f0e6 --- /dev/null +++ b/debugger/events.ml @@ -0,0 +1,65 @@ +(***********************************************************************) +(* *) +(* 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.ml,v 1.5 2002/11/02 22:36:42 doligez Exp $ *) + +(********************************* 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 new file mode 100644 index 00000000..c9e4a6f1 --- /dev/null +++ b/debugger/events.mli @@ -0,0 +1,31 @@ +(***********************************************************************) +(* *) +(* 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.mli,v 1.3 1999/11/17 18:57:24 xleroy Exp $ *) + +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 new file mode 100644 index 00000000..5eeeee97 --- /dev/null +++ b/debugger/exec.ml @@ -0,0 +1,50 @@ +(***********************************************************************) +(* *) +(* 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: exec.ml,v 1.4 1999/11/17 18:57:24 xleroy Exp $ *) + +(* 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 new file mode 100644 index 00000000..679fab57 --- /dev/null +++ b/debugger/exec.mli @@ -0,0 +1,19 @@ +(***********************************************************************) +(* *) +(* 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: exec.mli,v 1.4 1999/11/17 18:57:24 xleroy Exp $ *) + +(* Handling of keyboard interrupts *) + +val protect : (unit -> unit) -> unit +val unprotect : (unit -> unit) -> unit diff --git a/debugger/frames.ml b/debugger/frames.ml new file mode 100644 index 00000000..b0788898 --- /dev/null +++ b/debugger/frames.ml @@ -0,0 +1,129 @@ +(***********************************************************************) +(* *) +(* 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.ml,v 1.9 2002/11/02 22:36:42 doligez Exp $ *) + +(***************************** 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 new file mode 100644 index 00000000..dd09b4f1 --- /dev/null +++ b/debugger/frames.mli @@ -0,0 +1,55 @@ +(***********************************************************************) +(* *) +(* 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.mli,v 1.3 1999/11/17 18:57:24 xleroy Exp $ *) + +(****************************** 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 new file mode 100644 index 00000000..9a8279c1 --- /dev/null +++ b/debugger/history.ml @@ -0,0 +1,44 @@ +(***********************************************************************) +(* *) +(* 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: history.ml,v 1.5 2002/10/29 17:53:24 doligez Exp $ *) + +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 new file mode 100644 index 00000000..9d805a12 --- /dev/null +++ b/debugger/history.mli @@ -0,0 +1,20 @@ +(***********************************************************************) +(* *) +(* 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: history.mli,v 1.4 2002/10/29 17:53:24 doligez Exp $ *) + +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 new file mode 100644 index 00000000..b32fccd1 --- /dev/null +++ b/debugger/input_handling.ml @@ -0,0 +1,148 @@ +(***********************************************************************) +(* *) +(* 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_handling.ml,v 1.4 1999/11/17 18:57:25 xleroy Exp $ *) + +(**************************** 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 new file mode 100644 index 00000000..047e0aa8 --- /dev/null +++ b/debugger/input_handling.mli @@ -0,0 +1,63 @@ +(***********************************************************************) +(* *) +(* 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_handling.mli,v 1.2 1999/11/17 18:57:25 xleroy Exp $ *) + +(***************************** 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 new file mode 100644 index 00000000..d549aca7 --- /dev/null +++ b/debugger/int64ops.ml @@ -0,0 +1,26 @@ +(***********************************************************************) +(* *) +(* 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: int64ops.ml,v 1.1 2002/10/29 17:53:24 doligez Exp $ *) + +(****************** 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 new file mode 100644 index 00000000..4808590e --- /dev/null +++ b/debugger/int64ops.mli @@ -0,0 +1,26 @@ +(***********************************************************************) +(* *) +(* 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: int64ops.mli,v 1.1 2002/10/29 17:53:24 doligez Exp $ *) + +(****************** 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 new file mode 100644 index 00000000..017801b6 --- /dev/null +++ b/debugger/lexer.mll @@ -0,0 +1,98 @@ +(***********************************************************************) +(* *) +(* 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: lexer.mll,v 1.8 2003/01/03 15:39:54 doligez Exp $ *) + +{ + +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 new file mode 100644 index 00000000..0d6fdf20 --- /dev/null +++ b/debugger/loadprinter.ml @@ -0,0 +1,172 @@ +(***********************************************************************) +(* *) +(* 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: loadprinter.ml,v 1.18 2003/07/17 13:55:37 doligez Exp $ *) + +(* 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 new file mode 100644 index 00000000..21972fb8 --- /dev/null +++ b/debugger/loadprinter.mli @@ -0,0 +1,34 @@ +(***********************************************************************) +(* *) +(* 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: loadprinter.mli,v 1.4 2000/03/07 18:22:15 weis Exp $ *) + +(* 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 new file mode 100644 index 00000000..86121315 --- /dev/null +++ b/debugger/main.ml @@ -0,0 +1,132 @@ +(***********************************************************************) +(* *) +(* 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: main.ml,v 1.13 2002/11/02 22:36:42 doligez Exp $ *) + +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 new file mode 100644 index 00000000..9d38ed77 --- /dev/null +++ b/debugger/parameters.ml @@ -0,0 +1,35 @@ +(***********************************************************************) +(* *) +(* 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: parameters.ml,v 1.3 2002/02/14 15:17:10 doligez Exp $ *) + +(* 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 new file mode 100644 index 00000000..3d8b3e20 --- /dev/null +++ b/debugger/parameters.mli @@ -0,0 +1,26 @@ +(***********************************************************************) +(* *) +(* 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: parameters.mli,v 1.2 1999/11/17 18:57:26 xleroy Exp $ *) + +(* 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 new file mode 100644 index 00000000..829412b6 --- /dev/null +++ b/debugger/parser.mly @@ -0,0 +1,239 @@ +/***********************************************************************/ +/* */ +/* 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: parser.mly,v 1.7 2002/10/29 17:53:24 doligez Exp $ */ + +%{ + +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 new file mode 100644 index 00000000..ff10352f --- /dev/null +++ b/debugger/parser_aux.mli @@ -0,0 +1,34 @@ +(***********************************************************************) +(* *) +(* 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: parser_aux.mli,v 1.4 1999/11/17 18:57:26 xleroy Exp $ *) + +(*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 new file mode 100644 index 00000000..ccec2cd0 --- /dev/null +++ b/debugger/pattern_matching.ml @@ -0,0 +1,251 @@ +(***********************************************************************) +(* *) +(* 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: pattern_matching.ml,v 1.4 2000/12/28 13:03:41 weis Exp $ *) + +(************************ 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 new file mode 100644 index 00000000..c60a6fc7 --- /dev/null +++ b/debugger/pattern_matching.mli @@ -0,0 +1,21 @@ +(***********************************************************************) +(* *) +(* 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: pattern_matching.mli,v 1.2 1999/11/17 18:57:26 xleroy Exp $ *) + +(************************ 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/primitives.ml b/debugger/primitives.ml new file mode 100644 index 00000000..db1185ba --- /dev/null +++ b/debugger/primitives.ml @@ -0,0 +1,194 @@ +(***********************************************************************) +(* *) +(* 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: primitives.ml,v 1.6 2002/10/29 17:53:24 doligez Exp $ *) + +(*********************** 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 new file mode 100644 index 00000000..587c5a20 --- /dev/null +++ b/debugger/primitives.mli @@ -0,0 +1,86 @@ +(***********************************************************************) +(* *) +(* 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: primitives.mli,v 1.2 1999/11/17 18:57:26 xleroy Exp $ *) + +(********************* 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 new file mode 100644 index 00000000..b6244f2e --- /dev/null +++ b/debugger/printval.ml @@ -0,0 +1,111 @@ +(***********************************************************************) +(* *) +(* 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: printval.ml,v 1.21 2002/02/13 11:09:17 ddr Exp $ *) + +(* 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 new file mode 100644 index 00000000..1488162a --- /dev/null +++ b/debugger/printval.mli @@ -0,0 +1,33 @@ +(***********************************************************************) +(* *) +(* 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: printval.mli,v 1.10 2001/07/03 11:04:09 xleroy Exp $ *) + +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 new file mode 100644 index 00000000..813fc12a --- /dev/null +++ b/debugger/program_loading.ml @@ -0,0 +1,114 @@ +(***********************************************************************) +(* *) +(* 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.ml,v 1.6 1999/11/17 18:57:27 xleroy Exp $ *) + +(* 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 new file mode 100644 index 00000000..c858ecf5 --- /dev/null +++ b/debugger/program_loading.mli @@ -0,0 +1,34 @@ +(***********************************************************************) +(* *) +(* 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.mli,v 1.3 1999/11/17 18:57:27 xleroy Exp $ *) + +(*** 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 new file mode 100644 index 00000000..5d5810d4 --- /dev/null +++ b/debugger/program_management.ml @@ -0,0 +1,157 @@ +(***********************************************************************) +(* *) +(* 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_management.ml,v 1.11 2002/11/02 22:36:42 doligez Exp $ *) + +(* 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 new file mode 100644 index 00000000..e2a4e92c --- /dev/null +++ b/debugger/program_management.mli @@ -0,0 +1,27 @@ +(***********************************************************************) +(* *) +(* 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_management.mli,v 1.2 1999/11/17 18:57:27 xleroy Exp $ *) + +(*** 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 new file mode 100644 index 00000000..2ebd0b7d --- /dev/null +++ b/debugger/show_information.ml @@ -0,0 +1,94 @@ +(***********************************************************************) +(* *) +(* 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: show_information.ml,v 1.12 2002/11/02 22:36:44 doligez Exp $ *) + +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 new file mode 100644 index 00000000..711d7b4d --- /dev/null +++ b/debugger/show_information.mli @@ -0,0 +1,26 @@ +(***********************************************************************) +(* *) +(* 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: show_information.mli,v 1.3 2000/03/06 22:11:25 weis Exp $ *) + +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 new file mode 100644 index 00000000..9d9f50a3 --- /dev/null +++ b/debugger/show_source.ml @@ -0,0 +1,79 @@ +(***********************************************************************) +(* *) +(* 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: show_source.ml,v 1.12 2000/03/07 18:22:18 weis Exp $ *) + +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 new file mode 100644 index 00000000..ba696f6d --- /dev/null +++ b/debugger/show_source.mli @@ -0,0 +1,23 @@ +(***********************************************************************) +(* *) +(* 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: show_source.mli,v 1.3 1999/11/17 18:57:28 xleroy Exp $ *) + +(* 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 new file mode 100644 index 00000000..9ea7e546 --- /dev/null +++ b/debugger/source.ml @@ -0,0 +1,153 @@ +(***********************************************************************) +(* *) +(* 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.ml,v 1.7 2002/06/07 07:35:38 xleroy Exp $ *) + +(************************ 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 new file mode 100644 index 00000000..c85c3f6e --- /dev/null +++ b/debugger/source.mli @@ -0,0 +1,58 @@ +(***********************************************************************) +(* *) +(* 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.mli,v 1.2 1999/11/17 18:57:28 xleroy Exp $ *) + +(************************ 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 new file mode 100644 index 00000000..130f3d54 --- /dev/null +++ b/debugger/symbols.ml @@ -0,0 +1,169 @@ +(***********************************************************************) +(* *) +(* 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: symbols.ml,v 1.17 2002/11/02 22:36:45 doligez Exp $ *) + +(* 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 new file mode 100644 index 00000000..cbeccfdd --- /dev/null +++ b/debugger/symbols.mli @@ -0,0 +1,44 @@ +(***********************************************************************) +(* *) +(* 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: symbols.mli,v 1.6 1999/11/17 18:57:29 xleroy Exp $ *) + +(* 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 new file mode 100644 index 00000000..0e607c04 --- /dev/null +++ b/debugger/time_travel.ml @@ -0,0 +1,642 @@ +(***********************************************************************) +(* *) +(* 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.ml,v 1.16 2002/10/29 17:53:24 doligez Exp $ *) + +(**************************** 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 new file mode 100644 index 00000000..2824c995 --- /dev/null +++ b/debugger/time_travel.mli @@ -0,0 +1,36 @@ +(***********************************************************************) +(* *) +(* 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.mli,v 1.5 2002/10/29 17:53:24 doligez Exp $ *) + +(**************************** 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 new file mode 100644 index 00000000..59954f20 --- /dev/null +++ b/debugger/trap_barrier.ml @@ -0,0 +1,47 @@ +(***********************************************************************) +(* *) +(* 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.ml,v 1.3 1999/11/17 18:57:29 xleroy Exp $ *) + +(************************** 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 new file mode 100644 index 00000000..00a2ab2f --- /dev/null +++ b/debugger/trap_barrier.mli @@ -0,0 +1,27 @@ +(***********************************************************************) +(* *) +(* 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.mli,v 1.2 1999/11/17 18:57:29 xleroy Exp $ *) + +(************************* 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 new file mode 100644 index 00000000..747e53ae --- /dev/null +++ b/debugger/unix_tools.ml @@ -0,0 +1,141 @@ +(***********************************************************************) +(* *) +(* 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: unix_tools.ml,v 1.8 2002/11/02 22:36:45 doligez Exp $ *) + +(****************** 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 new file mode 100644 index 00000000..bf2a9557 --- /dev/null +++ b/debugger/unix_tools.mli @@ -0,0 +1,34 @@ +(***********************************************************************) +(* *) +(* 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: unix_tools.mli,v 1.4 2002/11/02 22:36:45 doligez Exp $ *) + +(**************************** 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 new file mode 100644 index 00000000..10b343d5 --- /dev/null +++ b/driver/compile.ml @@ -0,0 +1,118 @@ +(***********************************************************************) +(* *) +(* 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: compile.ml,v 1.52 2003/07/17 08:38:27 xleroy Exp $ *) + +(* 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. *) + +let initial_env () = + init_path(); + 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 = + 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 = + 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 new file mode 100644 index 00000000..bacb06ad --- /dev/null +++ b/driver/compile.mli @@ -0,0 +1,24 @@ +(***********************************************************************) +(* *) +(* 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.mli,v 1.7 2000/03/06 22:11:30 weis Exp $ *) + +(* 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 new file mode 100644 index 00000000..b6d1a987 --- /dev/null +++ b/driver/errors.ml @@ -0,0 +1,69 @@ +(***********************************************************************) +(* *) +(* 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: errors.ml,v 1.25 2003/06/19 15:53:49 xleroy Exp $ *) + +(* 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 new file mode 100644 index 00000000..c8004280 --- /dev/null +++ b/driver/errors.mli @@ -0,0 +1,18 @@ +(***********************************************************************) +(* *) +(* 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: errors.mli,v 1.5 2000/03/06 22:11:31 weis Exp $ *) + +(* Error report *) +open Format + +val report_error: formatter -> exn -> unit diff --git a/driver/main.ml b/driver/main.ml new file mode 100644 index 00000000..fab38463 --- /dev/null +++ b/driver/main.ml @@ -0,0 +1,156 @@ +(***********************************************************************) +(* *) +(* 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: main.ml,v 1.64 2003/07/17 08:38:27 xleroy Exp $ *) + +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 new file mode 100644 index 00000000..e91c60c6 --- /dev/null +++ b/driver/main.mli @@ -0,0 +1,17 @@ +(***********************************************************************) +(* *) +(* 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: main.mli,v 1.1 2000/01/07 16:03:04 doligez Exp $ *) + +(* + 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 new file mode 100644 index 00000000..133fdd9f --- /dev/null +++ b/driver/main_args.ml @@ -0,0 +1,156 @@ +(***********************************************************************) +(* *) +(* 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: main_args.ml,v 1.42 2003/07/17 08:38:27 xleroy Exp $ *) + +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 new file mode 100644 index 00000000..cf154d8b --- /dev/null +++ b/driver/main_args.mli @@ -0,0 +1,66 @@ +(***********************************************************************) +(* *) +(* 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: main_args.mli,v 1.25 2003/07/17 08:38:27 xleroy Exp $ *) + +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 new file mode 100644 index 00000000..2aeb2de2 --- /dev/null +++ b/driver/ocamlcomp.sh.in @@ -0,0 +1,5 @@ +#!/bin/sh + +topdir=`dirname $0` + +exec @compiler@ -nostdlib -I $topdir/stdlib "$@" diff --git a/driver/optcompile.ml b/driver/optcompile.ml new file mode 100644 index 00000000..5a15e39d --- /dev/null +++ b/driver/optcompile.ml @@ -0,0 +1,109 @@ +(***********************************************************************) +(* *) +(* 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: optcompile.ml,v 1.46 2003/07/17 08:38:27 xleroy Exp $ *) + +(* 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 () = + init_path(); + 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 = + 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 = + 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 new file mode 100644 index 00000000..83dc75dd --- /dev/null +++ b/driver/optcompile.mli @@ -0,0 +1,24 @@ +(***********************************************************************) +(* *) +(* 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: optcompile.mli,v 1.7 2000/03/07 05:02:32 garrigue Exp $ *) + +(* 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 new file mode 100644 index 00000000..8307706c --- /dev/null +++ b/driver/opterrors.ml @@ -0,0 +1,71 @@ +(***********************************************************************) +(* *) +(* 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: opterrors.ml,v 1.18 2003/06/19 15:53:49 xleroy Exp $ *) + +(* 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 new file mode 100644 index 00000000..296ec689 --- /dev/null +++ b/driver/opterrors.mli @@ -0,0 +1,17 @@ +(***********************************************************************) +(* *) +(* 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: opterrors.mli,v 1.5 2000/03/07 05:02:32 garrigue Exp $ *) + +(* Error report *) + +val report_error: Format.formatter -> exn -> unit diff --git a/driver/optmain.ml b/driver/optmain.ml new file mode 100644 index 00000000..fa36152b --- /dev/null +++ b/driver/optmain.ml @@ -0,0 +1,204 @@ +(***********************************************************************) +(* *) +(* 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: optmain.ml,v 1.79 2003/07/17 08:38:27 xleroy Exp $ *) + +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 new file mode 100644 index 00000000..8bd6aee5 --- /dev/null +++ b/driver/optmain.mli @@ -0,0 +1,17 @@ +(***********************************************************************) +(* *) +(* 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: optmain.mli,v 1.1 2000/01/07 16:03:04 doligez Exp $ *) + +(* + this "empty" file is here to speed up garbage collection in ocamlopt.opt +*) diff --git a/driver/pparse.ml b/driver/pparse.ml new file mode 100644 index 00000000..1fa79938 --- /dev/null +++ b/driver/pparse.ml @@ -0,0 +1,81 @@ +(***********************************************************************) +(* *) +(* 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: pparse.ml,v 1.2 2002/11/01 17:06:42 doligez Exp $ *) + +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 new file mode 100644 index 00000000..f8ff8fda --- /dev/null +++ b/driver/pparse.mli @@ -0,0 +1,22 @@ +(***********************************************************************) +(* *) +(* 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: pparse.mli,v 1.1 2002/02/08 10:14:31 ddr Exp $ *) + +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 new file mode 100644 index 00000000..e7e261fc --- /dev/null +++ b/emacs/.cvsignore @@ -0,0 +1,2 @@ +ocamltags + diff --git a/emacs/Makefile b/emacs/Makefile new file mode 100644 index 00000000..43b3c7b1 --- /dev/null +++ b/emacs/Makefile @@ -0,0 +1,54 @@ +# $Id: Makefile,v 1.10 2003/06/12 11:39:04 doligez Exp $ + +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 + +# 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.el") \ + (byte-compile-file "inf-caml.el") \ + (byte-compile-file "caml-help.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 + +simple-install: + @echo "Installing in $(EMACSDIR)..." + if test -d $(EMACSDIR); then : ; else mkdir -p $(EMACSDIR); fi + cp $(FILES) $(EMACSDIR) + cd $(EMACSDIR); $(EMACS) --batch --eval '$(COMPILECMD)' + +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 new file mode 100644 index 00000000..0edd7425 --- /dev/null +++ b/emacs/README @@ -0,0 +1,198 @@ + O'Caml emacs mode, snapshot of $Date: 2002/08/05 02:05:42 $ + +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 new file mode 100644 index 00000000..8e1366f4 --- /dev/null +++ b/emacs/README.itz @@ -0,0 +1,177 @@ +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 new file mode 100644 index 00000000..63b4a480 --- /dev/null +++ b/emacs/caml-compat.el @@ -0,0 +1,28 @@ +;; 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-font.el b/emacs/caml-font.el new file mode 100644 index 00000000..678b2a50 --- /dev/null +++ b/emacs/caml-font.el @@ -0,0 +1,125 @@ +;; 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 new file mode 100644 index 00000000..881a5572 --- /dev/null +++ b/emacs/caml-help.el @@ -0,0 +1,799 @@ +;; 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.) +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + +;; 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)) module) + (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)) default) + (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 qualified identifiers. + +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)) + (module) + (entry (cdr module-entry)) + (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* ((table 'ocaml-completion) + (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) + "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 + (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 + (view-file-other-window + (concat location (ocaml-uncapitalize module) ".mli")) + (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\\|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 help for 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) + (if (and ocaml-links section (equal (car ocaml-links) section)) + (cdr 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* ((start (event-start click)) + (pos (posn-point start)) + (buf (window-buffer (posn-window start))) + (window (selected-window)) + (link)) + (setq link + (with-current-buffer buf + (buffer-substring (previous-property-change + pos buf (- pos 100)) + (next-property-change + pos buf (+ pos 100))))) + (if (string-match (concat "^" ocaml-longident-regexp "$") link) + (ocaml-goto-help (match-string 1 link) (match-string 2 link)) + (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) + (if (cdr (ocaml-info-links section)) + (let ((regexp (concat "[^A-Za-z0-9'_]\\(" + ocaml-longident-regexp "\\|" + (mapconcat 'car (cdr ocaml-links) "\\|") + "\\)[^A-Za-z0-9'_]")) + (case-fold-search nil)) + (goto-char (point-min)) + (unwind-protect + (save-excursion + (setq buffer-read-only nil) + (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))) + ) + (setq buffer-read-only t)) + ))) + + + +;; bindings + +(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 new file mode 100644 index 00000000..7b48a811 --- /dev/null +++ b/emacs/caml-hilit.el @@ -0,0 +1,53 @@ +; 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 new file mode 100644 index 00000000..4e50b210 --- /dev/null +++ b/emacs/caml-types.el @@ -0,0 +1,196 @@ +;(***********************************************************************) +;(* *) +;(* 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: caml-types.el,v 1.8 2003/06/12 12:52:17 doligez Exp $ *) + +; WARNING: +; This code is experimental. Everything may change at any time. + +; An emacs-lisp complement to the "-dtypes" option of ocamlc and ocamlopt. +; Load this file in your emacs, then C-c C-t will show you the +; type of the expression (or pattern) that contains the cursor. +; The expression is highlighted in the current buffer. +; The type is highlighted in "foo.annot" (if your file is "foo.ml"), +; which is convenient when the type doesn't fit on a line. + + +; Hints on using the type display: + +; . If you want the type of an identifier, put the cursor in any +; occurrence of this identifier (as expression or as pattern) and +; type C-c C-t +; . If you want the result type of a function application, put the +; cursor at the first space after the function name +; . If you want the type of a list, put the cursor on a bracket, +; or 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. +; . To get rid of the highlighting, put the cursor in a comment +; and type C-c C-t. +; . The mark in the foo.annot file is set to the beginning of the +; type, so you can type C-x C-x in that file to view the type. + + + +; TO DO: +; - make emacs scroll the foo.annot file to show the type +; - (?) integrate this file into caml.el + + +; Format of the *.annot files: + +; 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". + + +; (global-set-key "\C-c\C-t" 'caml-types-show-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))) + +(setq caml-types-expr-ovl (make-overlay 1 1)) +(overlay-put caml-types-expr-ovl 'face 'region) +(setq caml-types-type-ovl (make-overlay 1 1)) +(overlay-put caml-types-type-ovl 'face 'region) + +(defun caml-types-show-type () + "Highlight the smallest expression that contains the cursor, + and display its type in the minibuffer." + (interactive) + (let* ((target-buf (current-buffer)) + (target-file (file-name-nondirectory (buffer-file-name))) + (target-date (nth 5 (file-attributes (buffer-file-name)))) + (target-line (1+ (count-lines (point-min) (line-beginning-position)))) + (target-bol (line-beginning-position)) + (target-cnum (point)) + (type-file (concat (file-name-sans-extension (buffer-file-name)) + ".annot")) + (type-date (nth 5 (file-attributes type-file))) + (type-buf (caml-types-find-file type-file))) + (if (caml-types-date< type-date target-date) + (message (format "%s is more recent than %s" target-file type-file)) + (save-excursion + (set-buffer type-buf) + (goto-char (point-min)) + (let ((loc (caml-types-find-location target-file target-line + target-bol target-cnum))) + (if (null loc) + (progn + (move-overlay caml-types-expr-ovl 1 1) + (move-overlay caml-types-type-ovl 1 1) + (message "The cursor is not within a typechecked expression or pattern.")) + (let ((left (caml-types-get-pos target-buf (nth 0 loc) (nth 1 loc))) + (right (caml-types-get-pos target-buf + (nth 2 loc) (nth 3 loc)))) + (move-overlay caml-types-expr-ovl left right target-buf)) + (re-search-forward "^type(") ;; not strictly correct + (forward-line 1) + (re-search-forward " \\(\\([^\n)]\\|.)\\|\n[^)]\\)*\\)\n)") + (move-overlay caml-types-type-ovl (match-beginning 1) (match-end 1) + type-buf) + (message (format "type: %s" (match-string 1))) + ; *** this doesn't seem to work, I don't know why... + ; *** (goto-char type-point) + ; *** workaround: set the mark instead + (set-mark (match-beginning 1)) + (set-buffer target-buf))))))) + +(defun caml-types-date< (date1 date2) + (or (< (car date1) (car date2)) + (and (= (car date1) (car date2)) + (< (nth 1 date1) (nth 1 date2))))) + +(defun caml-types-find-location (targ-file targ-line targ-bol targ-cnum) + (let (found) + (catch 'exit + (while (re-search-forward caml-types-location-re () t) + (let ((left-file (file-name-nondirectory (match-string 1))) + (left-line (string-to-int (match-string 3))) + (left-bol (string-to-int (match-string 4))) + (left-cnum (string-to-int (match-string 5))) + (right-file (file-name-nondirectory (match-string 6))) + (right-line (string-to-int (match-string 8))) + (right-bol (string-to-int (match-string 9))) + (right-cnum (string-to-int (match-string 10)))) + (if (and (caml-types-pos<= left-file left-line left-bol left-cnum + targ-file targ-line targ-bol targ-cnum) + (caml-types-pos> right-file right-line right-bol right-cnum + targ-file targ-line targ-bol targ-cnum)) + (throw 'exit (list left-line (- left-cnum left-bol) + right-line (- right-cnum right-bol))))))))) + + +;; 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<= (file1 line1 bol1 cnum1 file2 line2 bol2 cnum2) + (if (string= file1 "") + (<= cnum1 cnum2) + (and (string= file1 file2) + (or (< line1 line2) + (and (= line1 line2) + (<= (- cnum1 bol1) (- cnum2 bol2))))))) + +(defun caml-types-pos> (file1 line1 bol1 cnum1 file2 line2 bol2 cnum2) + (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 line col) + (save-excursion + (set-buffer buf) + (goto-line line) + (forward-char col) + (point))) + +; find-file-read-only-noselect seems to be missing from emacs... +(defun caml-types-find-file (name) + (or (and (get-file-buffer name) + (find-file-noselect name)) + (let ((buf (find-file-noselect name))) + (save-excursion + (set-buffer buf) + (toggle-read-only 1)) + buf))) diff --git a/emacs/caml.el b/emacs/caml.el new file mode 100644 index 00000000..09df4809 --- /dev/null +++ b/emacs/caml.el @@ -0,0 +1,1840 @@ +;;; 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 nil + "Non nil when using xemacs.") + +(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)) + (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)) + (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 ])) + "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) + +;;; caml.el ends here + +(provide 'caml) diff --git a/emacs/camldebug.el b/emacs/camldebug.el new file mode 100644 index 00000000..8d7b856e --- /dev/null +++ b/emacs/camldebug.el @@ -0,0 +1,754 @@ +;;; 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 new file mode 100644 index 00000000..f24a7a71 --- /dev/null +++ b/emacs/inf-caml.el @@ -0,0 +1,348 @@ +;;; 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 new file mode 100644 index 00000000..79873c90 --- /dev/null +++ b/emacs/ocamltags.in @@ -0,0 +1,128 @@ +":" ; @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: ocamltags.in,v 1.5 1999/11/29 19:03:30 doligez Exp $ + +(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 new file mode 100644 index 00000000..9f4f308d --- /dev/null +++ b/lex/.cvsignore @@ -0,0 +1,6 @@ +parser.ml +parser.mli +lexer.ml +ocamllex +ocamllex.opt +parser.output diff --git a/lex/.depend b/lex/.depend new file mode 100644 index 00000000..3ec916f0 --- /dev/null +++ b/lex/.depend @@ -0,0 +1,32 @@ +common.cmi: lexgen.cmi syntax.cmi +compact.cmi: lexgen.cmi +lexer.cmi: parser.cmi +lexgen.cmi: syntax.cmi +outputbis.cmi: common.cmi lexgen.cmi syntax.cmi +output.cmi: common.cmi compact.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 +outputbis.cmo: common.cmi lexgen.cmi syntax.cmi outputbis.cmi +outputbis.cmx: common.cmx lexgen.cmx syntax.cmx outputbis.cmi +output.cmo: common.cmi compact.cmi lexgen.cmi syntax.cmi output.cmi +output.cmx: common.cmx compact.cmx lexgen.cmx syntax.cmx output.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 new file mode 100644 index 00000000..bd0a81e1 --- /dev/null +++ b/lex/Makefile @@ -0,0 +1,71 @@ +######################################################################### +# # +# 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: Makefile,v 1.17 2002/11/01 15:31:11 doligez Exp $ + +# 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 new file mode 100644 index 00000000..db2baf06 --- /dev/null +++ b/lex/Makefile.Mac @@ -0,0 +1,63 @@ +######################################################################### +# # +# 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.Mac,v 1.3 1999/11/17 18:57:33 xleroy Exp $ + +# 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 new file mode 100644 index 00000000..73e2f7f3 --- /dev/null +++ b/lex/Makefile.Mac.depend @@ -0,0 +1,17 @@ +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 new file mode 100644 index 00000000..fa7abb25 --- /dev/null +++ b/lex/Makefile.nt @@ -0,0 +1,73 @@ +######################################################################### +# # +# 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: Makefile.nt,v 1.9 2003/01/06 14:57:22 xleroy Exp $ + +# 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 new file mode 100644 index 00000000..d50f3ba4 --- /dev/null +++ b/lex/common.ml @@ -0,0 +1,145 @@ +(***********************************************************************) +(* *) +(* 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 = + if loc.start_pos < loc.end_pos then begin + fprintf oc "# %d \"%s\"\n" loc.start_line sourcefile; + for i = 1 to loc.start_col do output_char oc ' ' done; + seek_in ic loc.start_pos; + copy_chars ic oc loc.start_pos loc.end_pos; + 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 + diff --git a/lex/common.mli b/lex/common.mli new file mode 100644 index 00000000..c2e52cc3 --- /dev/null +++ b/lex/common.mli @@ -0,0 +1,23 @@ +(***********************************************************************) +(* *) +(* 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 -> 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 diff --git a/lex/compact.ml b/lex/compact.ml new file mode 100644 index 00000000..f6fe4a3b --- /dev/null +++ b/lex/compact.ml @@ -0,0 +1,234 @@ +(***********************************************************************) +(* *) +(* 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: compact.ml,v 1.7 2002/10/28 16:46:49 maranget Exp $ *) + +(* 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 new file mode 100644 index 00000000..3023db94 --- /dev/null +++ b/lex/compact.mli @@ -0,0 +1,33 @@ +(***********************************************************************) +(* *) +(* 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: compact.mli,v 1.4 2002/10/28 16:46:49 maranget Exp $ *) + +(* 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 new file mode 100644 index 00000000..84c2a771 --- /dev/null +++ b/lex/cset.ml @@ -0,0 +1,94 @@ +(***********************************************************************) +(* *) +(* 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 new file mode 100644 index 00000000..0ebcac0e --- /dev/null +++ b/lex/cset.mli @@ -0,0 +1,32 @@ +(***********************************************************************) +(* *) +(* 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 new file mode 100644 index 00000000..5c66bc4d --- /dev/null +++ b/lex/lexer.mli @@ -0,0 +1,20 @@ +(***********************************************************************) +(* *) +(* 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: lexer.mli,v 1.5 1999/11/17 18:57:33 xleroy Exp $ *) + +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 new file mode 100644 index 00000000..8a173f45 --- /dev/null +++ b/lex/lexer.mll @@ -0,0 +1,273 @@ +(***********************************************************************) +(* *) +(* 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: lexer.mll,v 1.19 2002/10/31 14:21:20 maranget Exp $ *) + +(* 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 new file mode 100644 index 00000000..a4d529bb --- /dev/null +++ b/lex/lexgen.ml @@ -0,0 +1,1174 @@ +(***********************************************************************) +(* *) +(* 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: lexgen.ml,v 1.15 2003/02/24 10:59:19 maranget Exp $ *) + +(* 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 new file mode 100644 index 00000000..3c713e9b --- /dev/null +++ b/lex/lexgen.mli @@ -0,0 +1,59 @@ +(***********************************************************************) +(* *) +(* 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: lexgen.mli,v 1.5 2002/10/28 16:46:49 maranget Exp $ *) + + +(* 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 new file mode 100644 index 00000000..4b421a1b --- /dev/null +++ b/lex/main.ml @@ -0,0 +1,101 @@ +(***********************************************************************) +(* *) +(* 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: main.ml,v 1.14 2002/11/02 22:36:45 doligez Exp $ *) + +(* The lexer generator. Command-line parsing. *) + +open Syntax +open Lexgen + +let ml_automata = ref false +let source_name = ref "" +let output_name = ref "";; + +let usage = "usage: ocamlex [options] sourcefile" + +let _ = + Arg.parse + ["-ml", Arg.Set ml_automata, + " Output code that does not use the Lexing module"; + "-o", Arg.String (fun x -> source_name := x), + " Set output file name to "; + ] + (fun name -> source_name := name) + usage + + +let main () = + let source_name = !source_name in + let dest_name = + if !output_name <> "" then + !output_name + else 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 +(* + let (entries, transitions) = Lexmin.zyva (entries,transitions) in + let tables = Compact.compact_tables transitions in + Output.output_lexdef source_name ic oc + def.header tables entries def.trailer; +*) + 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 new file mode 100644 index 00000000..174b64c0 --- /dev/null +++ b/lex/output.ml @@ -0,0 +1,138 @@ +(***********************************************************************) +(* *) +(* 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.ml,v 1.20 2002/12/10 09:14:30 maranget Exp $ *) + +(* 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 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 state =\n" + e.auto_name output_args e.auto_args ; + fprintf oc " match Lexing.%sengine lex_tables state lexbuf with\n " + (if e.auto_mem_size == 0 then "" else "new_") ; + List.iter + (fun (num, env, loc) -> + fprintf oc " | "; + fprintf oc "%d -> (\n" num; + output_env oc env ; + copy_chunk sourcefile ic oc oci loc; + 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 = + 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 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; + 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 diff --git a/lex/output.mli b/lex/output.mli new file mode 100644 index 00000000..2c763e98 --- /dev/null +++ b/lex/output.mli @@ -0,0 +1,25 @@ +(***********************************************************************) +(* *) +(* 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.mli,v 1.8 2002/12/09 10:44:46 maranget Exp $ *) + +(* 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 new file mode 100644 index 00000000..5c5766e2 --- /dev/null +++ b/lex/outputbis.ml @@ -0,0 +1,188 @@ +(***********************************************************************) +(* *) +(* 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: outputbis.ml,v 1.3 2002/12/09 10:44:46 maranget Exp $ *) + +(* Output the DFA tables and its entry points *) + +open Printf +open Syntax +open Lexgen +open Common + +let output_auto_defs oc = + fprintf oc "let __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 __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 ; + __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 " __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 __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 __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 = + __init_lexbuf lexbuf %d; %a match __state%d lexbuf 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; + 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; + 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 diff --git a/lex/outputbis.mli b/lex/outputbis.mli new file mode 100644 index 00000000..01192a5e --- /dev/null +++ b/lex/outputbis.mli @@ -0,0 +1,21 @@ +(***********************************************************************) +(* *) +(* 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: outputbis.mli,v 1.3 2002/12/09 10:44:46 maranget Exp $ *) +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 new file mode 100644 index 00000000..f58f6bb8 --- /dev/null +++ b/lex/parser.mly @@ -0,0 +1,176 @@ +/***********************************************************************/ +/* */ +/* 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: parser.mly,v 1.18 2003/02/24 10:59:20 maranget Exp $ */ + +/* 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 char_class c1 c2 = Cset.interval c1 c2 + +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 new file mode 100644 index 00000000..d2e70d99 --- /dev/null +++ b/lex/syntax.ml @@ -0,0 +1,44 @@ +(***********************************************************************) +(* *) +(* 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: syntax.ml,v 1.8 2002/12/09 10:44:46 maranget Exp $ *) + +(* 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 new file mode 100644 index 00000000..c8063bdc --- /dev/null +++ b/lex/syntax.mli @@ -0,0 +1,41 @@ +(***********************************************************************) +(* *) +(* 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: syntax.mli,v 1.8 2002/12/09 10:44:46 maranget Exp $ *) + +(* 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 new file mode 100644 index 00000000..402f52be --- /dev/null +++ b/lex/table.ml @@ -0,0 +1,56 @@ +(***********************************************************************) +(* *) +(* 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 new file mode 100644 index 00000000..e5d55f96 --- /dev/null +++ b/lex/table.mli @@ -0,0 +1,33 @@ +(***********************************************************************) +(* *) +(* 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 new file mode 100644 index 00000000..efe28a12 --- /dev/null +++ b/maccaml/.cvsignore @@ -0,0 +1,12 @@ +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 new file mode 100644 index 00000000..85f938fb --- /dev/null +++ b/maccaml/Makefile.Mac @@ -0,0 +1,121 @@ +######################################################################### +# # +# 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.Mac,v 1.22 2001/12/13 13:59:26 doligez Exp $ + +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 new file mode 100644 index 00000000..b225a6e0 --- /dev/null +++ b/maccaml/Makefile.Mac.depend @@ -0,0 +1,2032 @@ +#*** 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 new file mode 100644 index 00000000..144c7328 --- /dev/null +++ b/maccaml/SHORTCUTS @@ -0,0 +1,9 @@ +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 new file mode 100644 index 00000000..652f7a04 --- /dev/null +++ b/maccaml/WASTE/.cvsignore @@ -0,0 +1 @@ +WASTE*1.3*Distribution diff --git a/maccaml/WASTE/Makefile b/maccaml/WASTE/Makefile new file mode 100644 index 00000000..39e41c40 --- /dev/null +++ b/maccaml/WASTE/Makefile @@ -0,0 +1,507 @@ +######################################################################### +# # +# 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,v 1.2 2000/04/05 18:30:16 doligez Exp $ + + +# 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 new file mode 100644 index 00000000..fd8e5e1e --- /dev/null +++ b/maccaml/WASTE/README @@ -0,0 +1,5 @@ +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 new file mode 100644 index 00000000..1d999807 --- /dev/null +++ b/maccaml/aboutbox.c @@ -0,0 +1,125 @@ +/***********************************************************************/ +/* */ +/* 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: aboutbox.c,v 1.5 2001/12/07 13:39:45 xleroy Exp $ */ + +#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 new file mode 100644 index 00000000..ca775025 --- /dev/null +++ b/maccaml/appleevents.c @@ -0,0 +1,147 @@ +/***********************************************************************/ +/* */ +/* 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: appleevents.c,v 1.5 2001/12/07 13:39:45 xleroy Exp $ */ + +#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 new file mode 100644 index 00000000..70c1ce2c --- /dev/null +++ b/maccaml/appli.r @@ -0,0 +1,808 @@ +/***********************************************************************/ +/* */ +/* 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: appli.r,v 1.4 2001/12/07 13:39:45 xleroy Exp $ */ + + +#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 new file mode 100644 index 00000000..c66f91e5 --- /dev/null +++ b/maccaml/clipboard.c @@ -0,0 +1,40 @@ +/***********************************************************************/ +/* */ +/* 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: clipboard.c,v 1.3 2001/12/07 13:39:45 xleroy Exp $ */ + +#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 new file mode 100644 index 00000000..a148602f --- /dev/null +++ b/maccaml/drag.c @@ -0,0 +1,241 @@ +/***********************************************************************/ +/* */ +/* 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: drag.c,v 1.5 2001/12/07 13:39:45 xleroy Exp $ */ + +#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 mme fentre 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 new file mode 100644 index 00000000..2a924f1d --- /dev/null +++ b/maccaml/dummy_fragment.c @@ -0,0 +1 @@ +/* This file intentionally left blank. */ diff --git a/maccaml/errors.c b/maccaml/errors.c new file mode 100644 index 00000000..a3d98e3c --- /dev/null +++ b/maccaml/errors.c @@ -0,0 +1,114 @@ +/***********************************************************************/ +/* */ +/* 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: errors.c,v 1.6 2001/12/07 13:39:45 xleroy Exp $ */ + +#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 new file mode 100644 index 00000000..fdb2d402 --- /dev/null +++ b/maccaml/events.c @@ -0,0 +1,319 @@ +/***********************************************************************/ +/* */ +/* 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: events.c,v 1.12 2001/12/07 13:39:45 xleroy Exp $ */ + +#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 new file mode 100644 index 00000000..a2b9918c --- /dev/null +++ b/maccaml/files.c @@ -0,0 +1,427 @@ +/***********************************************************************/ +/* */ +/* 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: files.c,v 1.5 2001/12/07 13:39:46 xleroy Exp $ */ + +#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 fentre, 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 new file mode 100644 index 00000000..efe66e80 --- /dev/null +++ b/maccaml/glue.c @@ -0,0 +1,557 @@ +/***********************************************************************/ +/* */ +/* 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: glue.c,v 1.12 2001/12/07 13:39:46 xleroy Exp $ */ + +#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 new file mode 100644 index 00000000..38ce0953 --- /dev/null +++ b/maccaml/graph.c @@ -0,0 +1,1179 @@ +/***********************************************************************/ +/* */ +/* 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: graph.c,v 1.17 2001/12/07 13:39:46 xleroy Exp $ */ + +#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 new file mode 100644 index 00000000..c17e6b57 --- /dev/null +++ b/maccaml/lcontrols.c @@ -0,0 +1,246 @@ +/* + 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: lcontrols.c,v 1.2 2001/07/12 13:00:55 doligez Exp $ */ + +#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 new file mode 100644 index 00000000..79456ad7 --- /dev/null +++ b/maccaml/lib.c @@ -0,0 +1,35 @@ +/***********************************************************************/ +/* */ +/* 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: lib.c,v 1.3 2001/12/07 13:39:46 xleroy Exp $ */ + +#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 new file mode 100644 index 00000000..dd4294a3 --- /dev/null +++ b/maccaml/main.c @@ -0,0 +1,125 @@ +/***********************************************************************/ +/* */ +/* 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: main.c,v 1.7 2001/12/07 13:39:47 xleroy Exp $ */ + +#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 new file mode 100644 index 00000000..862d8fcc --- /dev/null +++ b/maccaml/main.h @@ -0,0 +1,264 @@ +/***********************************************************************/ +/* */ +/* 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: main.h,v 1.14 2001/12/07 13:39:47 xleroy Exp $ */ + +#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 new file mode 100644 index 00000000..2ef0c2d8 --- /dev/null +++ b/maccaml/mcmemory.c @@ -0,0 +1,31 @@ +/***********************************************************************/ +/* */ +/* 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: mcmemory.c,v 1.2 2001/12/07 13:39:47 xleroy Exp $ */ + +#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 new file mode 100644 index 00000000..9e1b4416 --- /dev/null +++ b/maccaml/mcmisc.c @@ -0,0 +1,24 @@ +/***********************************************************************/ +/* */ +/* 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: mcmisc.c,v 1.2 2001/12/07 13:39:47 xleroy Exp $ */ + +#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 new file mode 100644 index 00000000..56a7b1cd --- /dev/null +++ b/maccaml/menus.c @@ -0,0 +1,339 @@ +/***********************************************************************/ +/* */ +/* 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: menus.c,v 1.9 2001/12/07 13:39:47 xleroy Exp $ */ + +#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 new file mode 100644 index 00000000..5f190fe4 --- /dev/null +++ b/maccaml/modalfilter.c @@ -0,0 +1,83 @@ +/***********************************************************************/ +/* */ +/* 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: modalfilter.c,v 1.3 2001/12/07 13:39:47 xleroy Exp $ */ + +#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 new file mode 100644 index 00000000..b5fa5aac --- /dev/null +++ b/maccaml/ocaml.r @@ -0,0 +1,479 @@ +/***********************************************************************/ +/* */ +/* 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: ocaml.r,v 1.10 2001/12/07 13:39:47 xleroy Exp $ */ + +#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 new file mode 100644 index 00000000..06db8b4c --- /dev/null +++ b/maccaml/ocamlconstants.h @@ -0,0 +1,187 @@ +/***********************************************************************/ +/* */ +/* 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: ocamlconstants.h,v 1.3 2001/12/07 13:39:48 xleroy Exp $ */ + +#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 new file mode 100644 index 00000000..0947d201 --- /dev/null +++ b/maccaml/ocamlmkappli @@ -0,0 +1,89 @@ +######################################################################### +# # +# 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,v 1.2 2001/03/13 16:37:33 doligez Exp $ + + +# 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 new file mode 100644 index 00000000..4a87ba59 --- /dev/null +++ b/maccaml/prefs.c @@ -0,0 +1,127 @@ +/***********************************************************************/ +/* */ +/* 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: prefs.c,v 1.6 2001/12/07 13:39:48 xleroy Exp $ */ + +#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 new file mode 100644 index 00000000..abec3890 --- /dev/null +++ b/maccaml/prim_bigarray @@ -0,0 +1,18 @@ +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 new file mode 100644 index 00000000..35c00284 --- /dev/null +++ b/maccaml/prim_graph @@ -0,0 +1,41 @@ +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 new file mode 100644 index 00000000..9a30b253 --- /dev/null +++ b/maccaml/prim_num @@ -0,0 +1,28 @@ +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 new file mode 100644 index 00000000..00e31ec5 --- /dev/null +++ b/maccaml/prim_str @@ -0,0 +1,8 @@ +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 new file mode 100644 index 00000000..fbf0f0d3 --- /dev/null +++ b/maccaml/print.c @@ -0,0 +1,131 @@ +/***********************************************************************/ +/* */ +/* 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: print.c,v 1.4 2001/12/07 13:39:48 xleroy Exp $ */ + +#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 new file mode 100644 index 00000000..430d4d5f --- /dev/null +++ b/maccaml/scroll.c @@ -0,0 +1,325 @@ +/***********************************************************************/ +/* */ +/* 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: scroll.c,v 1.5 2001/12/07 13:39:48 xleroy Exp $ */ + +#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 new file mode 100644 index 00000000..c6eb3b61 --- /dev/null +++ b/maccaml/windows.c @@ -0,0 +1,852 @@ +/***********************************************************************/ +/* */ +/* 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: windows.c,v 1.6 2001/12/07 13:39:48 xleroy Exp $ */ + +#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 new file mode 100644 index 00000000..7c6a1573 --- /dev/null +++ b/man/Makefile @@ -0,0 +1,22 @@ +######################################################################### +# # +# 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: Makefile,v 1.3 2002/04/24 09:09:35 xleroy Exp $ + +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 new file mode 100644 index 00000000..466896dc --- /dev/null +++ b/man/ocaml.help @@ -0,0 +1,138 @@ +- +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 "